vectorise: Put it out of its misery
[ghc.git] / compiler / typecheck / TcBinds.hs
1 {-
2 (c) The University of Glasgow 2006
3 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4
5 \section[TcBinds]{TcBinds}
6 -}
7
8 {-# LANGUAGE CPP, RankNTypes, ScopedTypeVariables #-}
9 {-# LANGUAGE FlexibleContexts #-}
10 {-# LANGUAGE TypeFamilies #-}
11
12 module TcBinds ( tcLocalBinds, tcTopBinds, tcRecSelBinds,
13 tcHsBootSigs, tcPolyCheck,
14 addTypecheckedBinds,
15 chooseInferredQuantifiers,
16 badBootDeclErr ) where
17
18 import GhcPrelude
19
20 import {-# SOURCE #-} TcMatches ( tcGRHSsPat, tcMatchesFun )
21 import {-# SOURCE #-} TcExpr ( tcMonoExpr )
22 import {-# SOURCE #-} TcPatSyn ( tcInferPatSynDecl, tcCheckPatSynDecl
23 , tcPatSynBuilderBind )
24 import CoreSyn (Tickish (..))
25 import CostCentre (mkUserCC, CCFlavour(DeclCC))
26 import DynFlags
27 import FastString
28 import HsSyn
29 import HscTypes( isHsBootOrSig )
30 import TcSigs
31 import TcRnMonad
32 import TcEnv
33 import TcUnify
34 import TcSimplify
35 import TcEvidence
36 import TcHsType
37 import TcPat
38 import TcMType
39 import FamInstEnv( normaliseType )
40 import FamInst( tcGetFamInstEnvs )
41 import TyCon
42 import TcType
43 import Type( mkStrLitTy, tidyOpenType, splitTyConApp_maybe, mkCastTy)
44 import TysPrim
45 import TysWiredIn( mkBoxedTupleTy )
46 import Id
47 import Var
48 import VarSet
49 import VarEnv( TidyEnv )
50 import Module
51 import Name
52 import NameSet
53 import NameEnv
54 import SrcLoc
55 import Bag
56 import ErrUtils
57 import Digraph
58 import Maybes
59 import Util
60 import BasicTypes
61 import Outputable
62 import PrelNames( ipClassName )
63 import TcValidity (checkValidType)
64 import UniqFM
65 import UniqSet
66 import qualified GHC.LanguageExtensions as LangExt
67 import ConLike
68
69 import Control.Monad
70
71 #include "HsVersions.h"
72
73 {- *********************************************************************
74 * *
75 A useful helper function
76 * *
77 ********************************************************************* -}
78
79 addTypecheckedBinds :: TcGblEnv -> [LHsBinds GhcTc] -> TcGblEnv
80 addTypecheckedBinds tcg_env binds
81 | isHsBootOrSig (tcg_src tcg_env) = tcg_env
82 -- Do not add the code for record-selector bindings
83 -- when compiling hs-boot files
84 | otherwise = tcg_env { tcg_binds = foldr unionBags
85 (tcg_binds tcg_env)
86 binds }
87
88 {-
89 ************************************************************************
90 * *
91 \subsection{Type-checking bindings}
92 * *
93 ************************************************************************
94
95 @tcBindsAndThen@ typechecks a @HsBinds@. The "and then" part is because
96 it needs to know something about the {\em usage} of the things bound,
97 so that it can create specialisations of them. So @tcBindsAndThen@
98 takes a function which, given an extended environment, E, typechecks
99 the scope of the bindings returning a typechecked thing and (most
100 important) an LIE. It is this LIE which is then used as the basis for
101 specialising the things bound.
102
103 @tcBindsAndThen@ also takes a "combiner" which glues together the
104 bindings and the "thing" to make a new "thing".
105
106 The real work is done by @tcBindWithSigsAndThen@.
107
108 Recursive and non-recursive binds are handled in essentially the same
109 way: because of uniques there are no scoping issues left. The only
110 difference is that non-recursive bindings can bind primitive values.
111
112 Even for non-recursive binding groups we add typings for each binder
113 to the LVE for the following reason. When each individual binding is
114 checked the type of its LHS is unified with that of its RHS; and
115 type-checking the LHS of course requires that the binder is in scope.
116
117 At the top-level the LIE is sure to contain nothing but constant
118 dictionaries, which we resolve at the module level.
119
120 Note [Polymorphic recursion]
121 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
122 The game plan for polymorphic recursion in the code above is
123
124 * Bind any variable for which we have a type signature
125 to an Id with a polymorphic type. Then when type-checking
126 the RHSs we'll make a full polymorphic call.
127
128 This fine, but if you aren't a bit careful you end up with a horrendous
129 amount of partial application and (worse) a huge space leak. For example:
130
131 f :: Eq a => [a] -> [a]
132 f xs = ...f...
133
134 If we don't take care, after typechecking we get
135
136 f = /\a -> \d::Eq a -> let f' = f a d
137 in
138 \ys:[a] -> ...f'...
139
140 Notice the stupid construction of (f a d), which is of course
141 identical to the function we're executing. In this case, the
142 polymorphic recursion isn't being used (but that's a very common case).
143 This can lead to a massive space leak, from the following top-level defn
144 (post-typechecking)
145
146 ff :: [Int] -> [Int]
147 ff = f Int dEqInt
148
149 Now (f dEqInt) evaluates to a lambda that has f' as a free variable; but
150 f' is another thunk which evaluates to the same thing... and you end
151 up with a chain of identical values all hung onto by the CAF ff.
152
153 ff = f Int dEqInt
154
155 = let f' = f Int dEqInt in \ys. ...f'...
156
157 = let f' = let f' = f Int dEqInt in \ys. ...f'...
158 in \ys. ...f'...
159
160 Etc.
161
162 NOTE: a bit of arity anaysis would push the (f a d) inside the (\ys...),
163 which would make the space leak go away in this case
164
165 Solution: when typechecking the RHSs we always have in hand the
166 *monomorphic* Ids for each binding. So we just need to make sure that
167 if (Method f a d) shows up in the constraints emerging from (...f...)
168 we just use the monomorphic Id. We achieve this by adding monomorphic Ids
169 to the "givens" when simplifying constraints. That's what the "lies_avail"
170 is doing.
171
172 Then we get
173
174 f = /\a -> \d::Eq a -> letrec
175 fm = \ys:[a] -> ...fm...
176 in
177 fm
178 -}
179
180 tcTopBinds :: [(RecFlag, LHsBinds GhcRn)] -> [LSig GhcRn]
181 -> TcM (TcGblEnv, TcLclEnv)
182 -- The TcGblEnv contains the new tcg_binds and tcg_spects
183 -- The TcLclEnv has an extended type envt for the new bindings
184 tcTopBinds binds sigs
185 = do { -- Pattern synonym bindings populate the global environment
186 (binds', (tcg_env, tcl_env)) <- tcValBinds TopLevel binds sigs $
187 do { gbl <- getGblEnv
188 ; lcl <- getLclEnv
189 ; return (gbl, lcl) }
190 ; specs <- tcImpPrags sigs -- SPECIALISE prags for imported Ids
191
192 ; complete_matches <- setEnvs (tcg_env, tcl_env) $ tcCompleteSigs sigs
193 ; traceTc "complete_matches" (ppr binds $$ ppr sigs)
194 ; traceTc "complete_matches" (ppr complete_matches)
195
196 ; let { tcg_env' = tcg_env { tcg_imp_specs
197 = specs ++ tcg_imp_specs tcg_env
198 , tcg_complete_matches
199 = complete_matches
200 ++ tcg_complete_matches tcg_env }
201 `addTypecheckedBinds` map snd binds' }
202
203 ; return (tcg_env', tcl_env) }
204 -- The top level bindings are flattened into a giant
205 -- implicitly-mutually-recursive LHsBinds
206
207
208 -- Note [Typechecking Complete Matches]
209 -- Much like when a user bundled a pattern synonym, the result types of
210 -- all the constructors in the match pragma must be consistent.
211 --
212 -- If we allowed pragmas with inconsistent types then it would be
213 -- impossible to ever match every constructor in the list and so
214 -- the pragma would be useless.
215
216
217
218
219
220 -- This is only used in `tcCompleteSig`. We fold over all the conlikes,
221 -- this accumulator keeps track of the first `ConLike` with a concrete
222 -- return type. After fixing the return type, all other constructors with
223 -- a fixed return type must agree with this.
224 --
225 -- The fields of `Fixed` cache the first conlike and its return type so
226 -- that that we can compare all the other conlikes to it. The conlike is
227 -- stored for error messages.
228 --
229 -- `Nothing` in the case that the type is fixed by a type signature
230 data CompleteSigType = AcceptAny | Fixed (Maybe ConLike) TyCon
231
232 tcCompleteSigs :: [LSig GhcRn] -> TcM [CompleteMatch]
233 tcCompleteSigs sigs =
234 let
235 doOne :: Sig GhcRn -> TcM (Maybe CompleteMatch)
236 doOne c@(CompleteMatchSig _ _ lns mtc)
237 = fmap Just $ do
238 addErrCtxt (text "In" <+> ppr c) $
239 case mtc of
240 Nothing -> infer_complete_match
241 Just tc -> check_complete_match tc
242 where
243
244 checkCLTypes acc = foldM checkCLType (acc, []) (unLoc lns)
245
246 infer_complete_match = do
247 (res, cls) <- checkCLTypes AcceptAny
248 case res of
249 AcceptAny -> failWithTc ambiguousError
250 Fixed _ tc -> return $ mkMatch cls tc
251
252 check_complete_match tc_name = do
253 ty_con <- tcLookupLocatedTyCon tc_name
254 (_, cls) <- checkCLTypes (Fixed Nothing ty_con)
255 return $ mkMatch cls ty_con
256
257 mkMatch :: [ConLike] -> TyCon -> CompleteMatch
258 mkMatch cls ty_con = CompleteMatch {
259 completeMatchConLikes = map conLikeName cls,
260 completeMatchTyCon = tyConName ty_con
261 }
262 doOne _ = return Nothing
263
264 ambiguousError :: SDoc
265 ambiguousError =
266 text "A type signature must be provided for a set of polymorphic"
267 <+> text "pattern synonyms."
268
269
270 -- See note [Typechecking Complete Matches]
271 checkCLType :: (CompleteSigType, [ConLike]) -> Located Name
272 -> TcM (CompleteSigType, [ConLike])
273 checkCLType (cst, cs) n = do
274 cl <- addLocM tcLookupConLike n
275 let (_,_,_,_,_,_, res_ty) = conLikeFullSig cl
276 res_ty_con = fst <$> splitTyConApp_maybe res_ty
277 case (cst, res_ty_con) of
278 (AcceptAny, Nothing) -> return (AcceptAny, cl:cs)
279 (AcceptAny, Just tc) -> return (Fixed (Just cl) tc, cl:cs)
280 (Fixed mfcl tc, Nothing) -> return (Fixed mfcl tc, cl:cs)
281 (Fixed mfcl tc, Just tc') ->
282 if tc == tc'
283 then return (Fixed mfcl tc, cl:cs)
284 else case mfcl of
285 Nothing ->
286 addErrCtxt (text "In" <+> ppr cl) $
287 failWithTc typeSigErrMsg
288 Just cl -> failWithTc (errMsg cl)
289 where
290 typeSigErrMsg :: SDoc
291 typeSigErrMsg =
292 text "Couldn't match expected type"
293 <+> quotes (ppr tc)
294 <+> text "with"
295 <+> quotes (ppr tc')
296
297 errMsg :: ConLike -> SDoc
298 errMsg fcl =
299 text "Cannot form a group of complete patterns from patterns"
300 <+> quotes (ppr fcl) <+> text "and" <+> quotes (ppr cl)
301 <+> text "as they match different type constructors"
302 <+> parens (quotes (ppr tc)
303 <+> text "resp."
304 <+> quotes (ppr tc'))
305 in mapMaybeM (addLocM doOne) sigs
306
307 tcRecSelBinds :: HsValBinds GhcRn -> TcM TcGblEnv
308 tcRecSelBinds (XValBindsLR (NValBinds binds sigs))
309 = tcExtendGlobalValEnv [sel_id | L _ (IdSig _ sel_id) <- sigs] $
310 do { (rec_sel_binds, tcg_env) <- discardWarnings $
311 tcValBinds TopLevel binds sigs getGblEnv
312 ; let tcg_env' = tcg_env `addTypecheckedBinds` map snd rec_sel_binds
313 ; return tcg_env' }
314 tcRecSelBinds (ValBinds {}) = panic "tcRecSelBinds"
315
316 tcHsBootSigs :: [(RecFlag, LHsBinds GhcRn)] -> [LSig GhcRn] -> TcM [Id]
317 -- A hs-boot file has only one BindGroup, and it only has type
318 -- signatures in it. The renamer checked all this
319 tcHsBootSigs binds sigs
320 = do { checkTc (null binds) badBootDeclErr
321 ; concat <$> mapM (addLocM tc_boot_sig) (filter isTypeLSig sigs) }
322 where
323 tc_boot_sig (TypeSig _ lnames hs_ty) = mapM f lnames
324 where
325 f (L _ name)
326 = do { sigma_ty <- tcHsSigWcType (FunSigCtxt name False) hs_ty
327 ; return (mkVanillaGlobal name sigma_ty) }
328 -- Notice that we make GlobalIds, not LocalIds
329 tc_boot_sig s = pprPanic "tcHsBootSigs/tc_boot_sig" (ppr s)
330
331 badBootDeclErr :: MsgDoc
332 badBootDeclErr = text "Illegal declarations in an hs-boot file"
333
334 ------------------------
335 tcLocalBinds :: HsLocalBinds GhcRn -> TcM thing
336 -> TcM (HsLocalBinds GhcTcId, thing)
337
338 tcLocalBinds (EmptyLocalBinds x) thing_inside
339 = do { thing <- thing_inside
340 ; return (EmptyLocalBinds x, thing) }
341
342 tcLocalBinds (HsValBinds x (XValBindsLR (NValBinds binds sigs))) thing_inside
343 = do { (binds', thing) <- tcValBinds NotTopLevel binds sigs thing_inside
344 ; return (HsValBinds x (XValBindsLR (NValBinds binds' sigs)), thing) }
345 tcLocalBinds (HsValBinds _ (ValBinds {})) _ = panic "tcLocalBinds"
346
347 tcLocalBinds (HsIPBinds x (IPBinds _ ip_binds)) thing_inside
348 = do { ipClass <- tcLookupClass ipClassName
349 ; (given_ips, ip_binds') <-
350 mapAndUnzipM (wrapLocSndM (tc_ip_bind ipClass)) ip_binds
351
352 -- If the binding binds ?x = E, we must now
353 -- discharge any ?x constraints in expr_lie
354 -- See Note [Implicit parameter untouchables]
355 ; (ev_binds, result) <- checkConstraints (IPSkol ips)
356 [] given_ips thing_inside
357
358 ; return (HsIPBinds x (IPBinds ev_binds ip_binds') , result) }
359 where
360 ips = [ip | L _ (IPBind _ (Left (L _ ip)) _) <- ip_binds]
361
362 -- I wonder if we should do these one at at time
363 -- Consider ?x = 4
364 -- ?y = ?x + 1
365 tc_ip_bind ipClass (IPBind _ (Left (L _ ip)) expr)
366 = do { ty <- newOpenFlexiTyVarTy
367 ; let p = mkStrLitTy $ hsIPNameFS ip
368 ; ip_id <- newDict ipClass [ p, ty ]
369 ; expr' <- tcMonoExpr expr (mkCheckExpType ty)
370 ; let d = toDict ipClass p ty `fmap` expr'
371 ; return (ip_id, (IPBind noExt (Right ip_id) d)) }
372 tc_ip_bind _ (IPBind _ (Right {}) _) = panic "tc_ip_bind"
373 tc_ip_bind _ (XCIPBind _) = panic "tc_ip_bind"
374
375 -- Coerces a `t` into a dictionry for `IP "x" t`.
376 -- co : t -> IP "x" t
377 toDict ipClass x ty = mkHsWrap $ mkWpCastR $
378 wrapIP $ mkClassPred ipClass [x,ty]
379
380 tcLocalBinds (HsIPBinds _ (XHsIPBinds _ )) _ = panic "tcLocalBinds"
381 tcLocalBinds (XHsLocalBindsLR _) _ = panic "tcLocalBinds"
382
383 {- Note [Implicit parameter untouchables]
384 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
385 We add the type variables in the types of the implicit parameters
386 as untouchables, not so much because we really must not unify them,
387 but rather because we otherwise end up with constraints like this
388 Num alpha, Implic { wanted = alpha ~ Int }
389 The constraint solver solves alpha~Int by unification, but then
390 doesn't float that solved constraint out (it's not an unsolved
391 wanted). Result disaster: the (Num alpha) is again solved, this
392 time by defaulting. No no no.
393
394 However [Oct 10] this is all handled automatically by the
395 untouchable-range idea.
396 -}
397
398 tcValBinds :: TopLevelFlag
399 -> [(RecFlag, LHsBinds GhcRn)] -> [LSig GhcRn]
400 -> TcM thing
401 -> TcM ([(RecFlag, LHsBinds GhcTcId)], thing)
402
403 tcValBinds top_lvl binds sigs thing_inside
404 = do { let patsyns = getPatSynBinds binds
405
406 -- Typecheck the signature
407 ; (poly_ids, sig_fn) <- tcAddPatSynPlaceholders patsyns $
408 tcTySigs sigs
409
410 ; let prag_fn = mkPragEnv sigs (foldr (unionBags . snd) emptyBag binds)
411
412 -- Extend the envt right away with all the Ids
413 -- declared with complete type signatures
414 -- Do not extend the TcBinderStack; instead
415 -- we extend it on a per-rhs basis in tcExtendForRhs
416 ; tcExtendSigIds top_lvl poly_ids $ do
417 { (binds', (extra_binds', thing)) <- tcBindGroups top_lvl sig_fn prag_fn binds $ do
418 { thing <- thing_inside
419 -- See Note [Pattern synonym builders don't yield dependencies]
420 -- in RnBinds
421 ; patsyn_builders <- mapM tcPatSynBuilderBind patsyns
422 ; let extra_binds = [ (NonRecursive, builder) | builder <- patsyn_builders ]
423 ; return (extra_binds, thing) }
424 ; return (binds' ++ extra_binds', thing) }}
425
426 ------------------------
427 tcBindGroups :: TopLevelFlag -> TcSigFun -> TcPragEnv
428 -> [(RecFlag, LHsBinds GhcRn)] -> TcM thing
429 -> TcM ([(RecFlag, LHsBinds GhcTcId)], thing)
430 -- Typecheck a whole lot of value bindings,
431 -- one strongly-connected component at a time
432 -- Here a "strongly connected component" has the strightforward
433 -- meaning of a group of bindings that mention each other,
434 -- ignoring type signatures (that part comes later)
435
436 tcBindGroups _ _ _ [] thing_inside
437 = do { thing <- thing_inside
438 ; return ([], thing) }
439
440 tcBindGroups top_lvl sig_fn prag_fn (group : groups) thing_inside
441 = do { -- See Note [Closed binder groups]
442 type_env <- getLclTypeEnv
443 ; let closed = isClosedBndrGroup type_env (snd group)
444 ; (group', (groups', thing))
445 <- tc_group top_lvl sig_fn prag_fn group closed $
446 tcBindGroups top_lvl sig_fn prag_fn groups thing_inside
447 ; return (group' ++ groups', thing) }
448
449 -- Note [Closed binder groups]
450 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~
451 --
452 -- A mutually recursive group is "closed" if all of the free variables of
453 -- the bindings are closed. For example
454 --
455 -- > h = \x -> let f = ...g...
456 -- > g = ....f...x...
457 -- > in ...
458 --
459 -- Here @g@ is not closed because it mentions @x@; and hence neither is @f@
460 -- closed.
461 --
462 -- So we need to compute closed-ness on each strongly connected components,
463 -- before we sub-divide it based on what type signatures it has.
464 --
465
466 ------------------------
467 tc_group :: forall thing.
468 TopLevelFlag -> TcSigFun -> TcPragEnv
469 -> (RecFlag, LHsBinds GhcRn) -> IsGroupClosed -> TcM thing
470 -> TcM ([(RecFlag, LHsBinds GhcTcId)], thing)
471
472 -- Typecheck one strongly-connected component of the original program.
473 -- We get a list of groups back, because there may
474 -- be specialisations etc as well
475
476 tc_group top_lvl sig_fn prag_fn (NonRecursive, binds) closed thing_inside
477 -- A single non-recursive binding
478 -- We want to keep non-recursive things non-recursive
479 -- so that we desugar unlifted bindings correctly
480 = do { let bind = case bagToList binds of
481 [bind] -> bind
482 [] -> panic "tc_group: empty list of binds"
483 _ -> panic "tc_group: NonRecursive binds is not a singleton bag"
484 ; (bind', thing) <- tc_single top_lvl sig_fn prag_fn bind closed
485 thing_inside
486 ; return ( [(NonRecursive, bind')], thing) }
487
488 tc_group top_lvl sig_fn prag_fn (Recursive, binds) closed thing_inside
489 = -- To maximise polymorphism, we do a new
490 -- strongly-connected-component analysis, this time omitting
491 -- any references to variables with type signatures.
492 -- (This used to be optional, but isn't now.)
493 -- See Note [Polymorphic recursion] in HsBinds.
494 do { traceTc "tc_group rec" (pprLHsBinds binds)
495 ; when hasPatSyn $ recursivePatSynErr binds
496 ; (binds1, thing) <- go sccs
497 ; return ([(Recursive, binds1)], thing) }
498 -- Rec them all together
499 where
500 hasPatSyn = anyBag (isPatSyn . unLoc) binds
501 isPatSyn PatSynBind{} = True
502 isPatSyn _ = False
503
504 sccs :: [SCC (LHsBind GhcRn)]
505 sccs = stronglyConnCompFromEdgedVerticesUniq (mkEdges sig_fn binds)
506
507 go :: [SCC (LHsBind GhcRn)] -> TcM (LHsBinds GhcTcId, thing)
508 go (scc:sccs) = do { (binds1, ids1) <- tc_scc scc
509 ; (binds2, thing) <- tcExtendLetEnv top_lvl sig_fn
510 closed ids1 $
511 go sccs
512 ; return (binds1 `unionBags` binds2, thing) }
513 go [] = do { thing <- thing_inside; return (emptyBag, thing) }
514
515 tc_scc (AcyclicSCC bind) = tc_sub_group NonRecursive [bind]
516 tc_scc (CyclicSCC binds) = tc_sub_group Recursive binds
517
518 tc_sub_group rec_tc binds =
519 tcPolyBinds sig_fn prag_fn Recursive rec_tc closed binds
520
521 recursivePatSynErr :: OutputableBndrId name => LHsBinds name -> TcM a
522 recursivePatSynErr binds
523 = failWithTc $
524 hang (text "Recursive pattern synonym definition with following bindings:")
525 2 (vcat $ map pprLBind . bagToList $ binds)
526 where
527 pprLoc loc = parens (text "defined at" <+> ppr loc)
528 pprLBind (L loc bind) = pprWithCommas ppr (collectHsBindBinders bind) <+>
529 pprLoc loc
530
531 tc_single :: forall thing.
532 TopLevelFlag -> TcSigFun -> TcPragEnv
533 -> LHsBind GhcRn -> IsGroupClosed -> TcM thing
534 -> TcM (LHsBinds GhcTcId, thing)
535 tc_single _top_lvl sig_fn _prag_fn
536 (L _ (PatSynBind _ psb@PSB{ psb_id = L _ name }))
537 _ thing_inside
538 = do { (aux_binds, tcg_env) <- tc_pat_syn_decl
539 ; thing <- setGblEnv tcg_env thing_inside
540 ; return (aux_binds, thing)
541 }
542 where
543 tc_pat_syn_decl :: TcM (LHsBinds GhcTcId, TcGblEnv)
544 tc_pat_syn_decl = case sig_fn name of
545 Nothing -> tcInferPatSynDecl psb
546 Just (TcPatSynSig tpsi) -> tcCheckPatSynDecl psb tpsi
547 Just _ -> panic "tc_single"
548
549 tc_single top_lvl sig_fn prag_fn lbind closed thing_inside
550 = do { (binds1, ids) <- tcPolyBinds sig_fn prag_fn
551 NonRecursive NonRecursive
552 closed
553 [lbind]
554 ; thing <- tcExtendLetEnv top_lvl sig_fn closed ids thing_inside
555 ; return (binds1, thing) }
556
557 ------------------------
558 type BKey = Int -- Just number off the bindings
559
560 mkEdges :: TcSigFun -> LHsBinds GhcRn -> [Node BKey (LHsBind GhcRn)]
561 -- See Note [Polymorphic recursion] in HsBinds.
562 mkEdges sig_fn binds
563 = [ DigraphNode bind key [key | n <- nonDetEltsUniqSet (bind_fvs (unLoc bind)),
564 Just key <- [lookupNameEnv key_map n], no_sig n ]
565 | (bind, key) <- keyd_binds
566 ]
567 -- It's OK to use nonDetEltsUFM here as stronglyConnCompFromEdgedVertices
568 -- is still deterministic even if the edges are in nondeterministic order
569 -- as explained in Note [Deterministic SCC] in Digraph.
570 where
571 bind_fvs (FunBind { fun_ext = fvs }) = fvs
572 bind_fvs (PatBind { pat_ext = fvs }) = fvs
573 bind_fvs _ = emptyNameSet
574
575 no_sig :: Name -> Bool
576 no_sig n = not (hasCompleteSig sig_fn n)
577
578 keyd_binds = bagToList binds `zip` [0::BKey ..]
579
580 key_map :: NameEnv BKey -- Which binding it comes from
581 key_map = mkNameEnv [(bndr, key) | (L _ bind, key) <- keyd_binds
582 , bndr <- collectHsBindBinders bind ]
583
584 ------------------------
585 tcPolyBinds :: TcSigFun -> TcPragEnv
586 -> RecFlag -- Whether the group is really recursive
587 -> RecFlag -- Whether it's recursive after breaking
588 -- dependencies based on type signatures
589 -> IsGroupClosed -- Whether the group is closed
590 -> [LHsBind GhcRn] -- None are PatSynBind
591 -> TcM (LHsBinds GhcTcId, [TcId])
592
593 -- Typechecks a single bunch of values bindings all together,
594 -- and generalises them. The bunch may be only part of a recursive
595 -- group, because we use type signatures to maximise polymorphism
596 --
597 -- Returns a list because the input may be a single non-recursive binding,
598 -- in which case the dependency order of the resulting bindings is
599 -- important.
600 --
601 -- Knows nothing about the scope of the bindings
602 -- None of the bindings are pattern synonyms
603
604 tcPolyBinds sig_fn prag_fn rec_group rec_tc closed bind_list
605 = setSrcSpan loc $
606 recoverM (recoveryCode binder_names sig_fn) $ do
607 -- Set up main recover; take advantage of any type sigs
608
609 { traceTc "------------------------------------------------" Outputable.empty
610 ; traceTc "Bindings for {" (ppr binder_names)
611 ; dflags <- getDynFlags
612 ; let plan = decideGeneralisationPlan dflags bind_list closed sig_fn
613 ; traceTc "Generalisation plan" (ppr plan)
614 ; result@(_, poly_ids) <- case plan of
615 NoGen -> tcPolyNoGen rec_tc prag_fn sig_fn bind_list
616 InferGen mn -> tcPolyInfer rec_tc prag_fn sig_fn mn bind_list
617 CheckGen lbind sig -> tcPolyCheck prag_fn sig lbind
618
619 ; traceTc "} End of bindings for" (vcat [ ppr binder_names, ppr rec_group
620 , vcat [ppr id <+> ppr (idType id) | id <- poly_ids]
621 ])
622
623 ; return result }
624 where
625 binder_names = collectHsBindListBinders bind_list
626 loc = foldr1 combineSrcSpans (map getLoc bind_list)
627 -- The mbinds have been dependency analysed and
628 -- may no longer be adjacent; so find the narrowest
629 -- span that includes them all
630
631 --------------
632 -- If typechecking the binds fails, then return with each
633 -- signature-less binder given type (forall a.a), to minimise
634 -- subsequent error messages
635 recoveryCode :: [Name] -> TcSigFun -> TcM (LHsBinds GhcTcId, [Id])
636 recoveryCode binder_names sig_fn
637 = do { traceTc "tcBindsWithSigs: error recovery" (ppr binder_names)
638 ; let poly_ids = map mk_dummy binder_names
639 ; return (emptyBag, poly_ids) }
640 where
641 mk_dummy name
642 | Just sig <- sig_fn name
643 , Just poly_id <- completeSigPolyId_maybe sig
644 = poly_id
645 | otherwise
646 = mkLocalId name forall_a_a
647
648 forall_a_a :: TcType
649 forall_a_a = mkSpecForAllTys [runtimeRep1TyVar, openAlphaTyVar] openAlphaTy
650
651 {- *********************************************************************
652 * *
653 tcPolyNoGen
654 * *
655 ********************************************************************* -}
656
657 tcPolyNoGen -- No generalisation whatsoever
658 :: RecFlag -- Whether it's recursive after breaking
659 -- dependencies based on type signatures
660 -> TcPragEnv -> TcSigFun
661 -> [LHsBind GhcRn]
662 -> TcM (LHsBinds GhcTcId, [TcId])
663
664 tcPolyNoGen rec_tc prag_fn tc_sig_fn bind_list
665 = do { (binds', mono_infos) <- tcMonoBinds rec_tc tc_sig_fn
666 (LetGblBndr prag_fn)
667 bind_list
668 ; mono_ids' <- mapM tc_mono_info mono_infos
669 ; return (binds', mono_ids') }
670 where
671 tc_mono_info (MBI { mbi_poly_name = name, mbi_mono_id = mono_id })
672 = do { _specs <- tcSpecPrags mono_id (lookupPragEnv prag_fn name)
673 ; return mono_id }
674 -- NB: tcPrags generates error messages for
675 -- specialisation pragmas for non-overloaded sigs
676 -- Indeed that is why we call it here!
677 -- So we can safely ignore _specs
678
679
680 {- *********************************************************************
681 * *
682 tcPolyCheck
683 * *
684 ********************************************************************* -}
685
686 tcPolyCheck :: TcPragEnv
687 -> TcIdSigInfo -- Must be a complete signature
688 -> LHsBind GhcRn -- Must be a FunBind
689 -> TcM (LHsBinds GhcTcId, [TcId])
690 -- There is just one binding,
691 -- it is a Funbind
692 -- it has a complete type signature,
693 tcPolyCheck prag_fn
694 (CompleteSig { sig_bndr = poly_id
695 , sig_ctxt = ctxt
696 , sig_loc = sig_loc })
697 (L loc (FunBind { fun_id = L nm_loc name
698 , fun_matches = matches }))
699 = setSrcSpan sig_loc $
700 do { traceTc "tcPolyCheck" (ppr poly_id $$ ppr sig_loc)
701 ; (tv_prs, theta, tau) <- tcInstType tcInstSkolTyVars poly_id
702 -- See Note [Instantiate sig with fresh variables]
703
704 ; mono_name <- newNameAt (nameOccName name) nm_loc
705 ; ev_vars <- newEvVars theta
706 ; let mono_id = mkLocalId mono_name tau
707 skol_info = SigSkol ctxt (idType poly_id) tv_prs
708 skol_tvs = map snd tv_prs
709
710 ; (ev_binds, (co_fn, matches'))
711 <- checkConstraints skol_info skol_tvs ev_vars $
712 tcExtendBinderStack [TcIdBndr mono_id NotTopLevel] $
713 tcExtendTyVarEnv2 tv_prs $
714 setSrcSpan loc $
715 tcMatchesFun (L nm_loc mono_name) matches (mkCheckExpType tau)
716
717 ; let prag_sigs = lookupPragEnv prag_fn name
718 ; spec_prags <- tcSpecPrags poly_id prag_sigs
719 ; poly_id <- addInlinePrags poly_id prag_sigs
720
721 ; mod <- getModule
722 ; tick <- funBindTicks nm_loc mono_id mod prag_sigs
723 ; let bind' = FunBind { fun_id = L nm_loc mono_id
724 , fun_matches = matches'
725 , fun_co_fn = co_fn
726 , fun_ext = placeHolderNamesTc
727 , fun_tick = tick }
728
729 export = ABE { abe_ext = noExt
730 , abe_wrap = idHsWrapper
731 , abe_poly = poly_id
732 , abe_mono = mono_id
733 , abe_prags = SpecPrags spec_prags }
734
735 abs_bind = L loc $
736 AbsBinds { abs_ext = noExt
737 , abs_tvs = skol_tvs
738 , abs_ev_vars = ev_vars
739 , abs_ev_binds = [ev_binds]
740 , abs_exports = [export]
741 , abs_binds = unitBag (L loc bind')
742 , abs_sig = True }
743
744 ; return (unitBag abs_bind, [poly_id]) }
745
746 tcPolyCheck _prag_fn sig bind
747 = pprPanic "tcPolyCheck" (ppr sig $$ ppr bind)
748
749 funBindTicks :: SrcSpan -> TcId -> Module -> [LSig GhcRn]
750 -> TcM [Tickish TcId]
751 funBindTicks loc fun_id mod sigs
752 | (mb_cc_str : _) <- [ cc_name | L _ (SCCFunSig _ _ _ cc_name) <- sigs ]
753 -- this can only be a singleton list, as duplicate pragmas are rejected
754 -- by the renamer
755 , let cc_str
756 | Just cc_str <- mb_cc_str
757 = sl_fs $ unLoc cc_str
758 | otherwise
759 = getOccFS (Var.varName fun_id)
760 cc_name = moduleNameFS (moduleName mod) `appendFS` consFS '.' cc_str
761 = do
762 flavour <- DeclCC <$> getCCIndexM cc_name
763 let cc = mkUserCC cc_name mod loc flavour
764 return [ProfNote cc True True]
765 | otherwise
766 = return []
767
768 {- Note [Instantiate sig with fresh variables]
769 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
770 It's vital to instantiate a type signature with fresh variables.
771 For example:
772 type T = forall a. [a] -> [a]
773 f :: T;
774 f = g where { g :: T; g = <rhs> }
775
776 We must not use the same 'a' from the defn of T at both places!!
777 (Instantiation is only necessary because of type synonyms. Otherwise,
778 it's all cool; each signature has distinct type variables from the renamer.)
779 -}
780
781
782 {- *********************************************************************
783 * *
784 tcPolyInfer
785 * *
786 ********************************************************************* -}
787
788 tcPolyInfer
789 :: RecFlag -- Whether it's recursive after breaking
790 -- dependencies based on type signatures
791 -> TcPragEnv -> TcSigFun
792 -> Bool -- True <=> apply the monomorphism restriction
793 -> [LHsBind GhcRn]
794 -> TcM (LHsBinds GhcTcId, [TcId])
795 tcPolyInfer rec_tc prag_fn tc_sig_fn mono bind_list
796 = do { (tclvl, wanted, (binds', mono_infos))
797 <- pushLevelAndCaptureConstraints $
798 tcMonoBinds rec_tc tc_sig_fn LetLclBndr bind_list
799
800 ; let name_taus = [ (mbi_poly_name info, idType (mbi_mono_id info))
801 | info <- mono_infos ]
802 sigs = [ sig | MBI { mbi_sig = Just sig } <- mono_infos ]
803 infer_mode = if mono then ApplyMR else NoRestrictions
804
805 ; mapM_ (checkOverloadedSig mono) sigs
806
807 ; traceTc "simplifyInfer call" (ppr tclvl $$ ppr name_taus $$ ppr wanted)
808 ; (qtvs, givens, ev_binds, insoluble)
809 <- simplifyInfer tclvl infer_mode sigs name_taus wanted
810
811 ; let inferred_theta = map evVarPred givens
812 ; exports <- checkNoErrs $
813 mapM (mkExport prag_fn insoluble qtvs inferred_theta) mono_infos
814
815 ; loc <- getSrcSpanM
816 ; let poly_ids = map abe_poly exports
817 abs_bind = L loc $
818 AbsBinds { abs_ext = noExt
819 , abs_tvs = qtvs
820 , abs_ev_vars = givens, abs_ev_binds = [ev_binds]
821 , abs_exports = exports, abs_binds = binds'
822 , abs_sig = False }
823
824 ; traceTc "Binding:" (ppr (poly_ids `zip` map idType poly_ids))
825 ; return (unitBag abs_bind, poly_ids) }
826 -- poly_ids are guaranteed zonked by mkExport
827
828 --------------
829 mkExport :: TcPragEnv
830 -> Bool -- True <=> there was an insoluble type error
831 -- when typechecking the bindings
832 -> [TyVar] -> TcThetaType -- Both already zonked
833 -> MonoBindInfo
834 -> TcM (ABExport GhcTc)
835 -- Only called for generalisation plan InferGen, not by CheckGen or NoGen
836 --
837 -- mkExport generates exports with
838 -- zonked type variables,
839 -- zonked poly_ids
840 -- The former is just because no further unifications will change
841 -- the quantified type variables, so we can fix their final form
842 -- right now.
843 -- The latter is needed because the poly_ids are used to extend the
844 -- type environment; see the invariant on TcEnv.tcExtendIdEnv
845
846 -- Pre-condition: the qtvs and theta are already zonked
847
848 mkExport prag_fn insoluble qtvs theta
849 mono_info@(MBI { mbi_poly_name = poly_name
850 , mbi_sig = mb_sig
851 , mbi_mono_id = mono_id })
852 = do { mono_ty <- zonkTcType (idType mono_id)
853 ; poly_id <- mkInferredPolyId insoluble qtvs theta poly_name mb_sig mono_ty
854
855 -- NB: poly_id has a zonked type
856 ; poly_id <- addInlinePrags poly_id prag_sigs
857 ; spec_prags <- tcSpecPrags poly_id prag_sigs
858 -- tcPrags requires a zonked poly_id
859
860 -- See Note [Impedance matching]
861 -- NB: we have already done checkValidType, including an ambiguity check,
862 -- on the type; either when we checked the sig or in mkInferredPolyId
863 ; let poly_ty = idType poly_id
864 sel_poly_ty = mkInfSigmaTy qtvs theta mono_ty
865 -- This type is just going into tcSubType,
866 -- so Inferred vs. Specified doesn't matter
867
868 ; wrap <- if sel_poly_ty `eqType` poly_ty -- NB: eqType ignores visibility
869 then return idHsWrapper -- Fast path; also avoids complaint when we infer
870 -- an ambiguous type and have AllowAmbiguousType
871 -- e..g infer x :: forall a. F a -> Int
872 else addErrCtxtM (mk_impedance_match_msg mono_info sel_poly_ty poly_ty) $
873 tcSubType_NC sig_ctxt sel_poly_ty poly_ty
874
875 ; warn_missing_sigs <- woptM Opt_WarnMissingLocalSignatures
876 ; when warn_missing_sigs $
877 localSigWarn Opt_WarnMissingLocalSignatures poly_id mb_sig
878
879 ; return (ABE { abe_ext = noExt
880 , abe_wrap = wrap
881 -- abe_wrap :: idType poly_id ~ (forall qtvs. theta => mono_ty)
882 , abe_poly = poly_id
883 , abe_mono = mono_id
884 , abe_prags = SpecPrags spec_prags }) }
885 where
886 prag_sigs = lookupPragEnv prag_fn poly_name
887 sig_ctxt = InfSigCtxt poly_name
888
889 mkInferredPolyId :: Bool -- True <=> there was an insoluble error when
890 -- checking the binding group for this Id
891 -> [TyVar] -> TcThetaType
892 -> Name -> Maybe TcIdSigInst -> TcType
893 -> TcM TcId
894 mkInferredPolyId insoluble qtvs inferred_theta poly_name mb_sig_inst mono_ty
895 | Just (TISI { sig_inst_sig = sig }) <- mb_sig_inst
896 , CompleteSig { sig_bndr = poly_id } <- sig
897 = return poly_id
898
899 | otherwise -- Either no type sig or partial type sig
900 = checkNoErrs $ -- The checkNoErrs ensures that if the type is ambiguous
901 -- we don't carry on to the impedance matching, and generate
902 -- a duplicate ambiguity error. There is a similar
903 -- checkNoErrs for complete type signatures too.
904 do { fam_envs <- tcGetFamInstEnvs
905 ; let (_co, mono_ty') = normaliseType fam_envs Nominal mono_ty
906 -- Unification may not have normalised the type,
907 -- (see Note [Lazy flattening] in TcFlatten) so do it
908 -- here to make it as uncomplicated as possible.
909 -- Example: f :: [F Int] -> Bool
910 -- should be rewritten to f :: [Char] -> Bool, if possible
911 --
912 -- We can discard the coercion _co, because we'll reconstruct
913 -- it in the call to tcSubType below
914
915 ; (binders, theta') <- chooseInferredQuantifiers inferred_theta
916 (tyCoVarsOfType mono_ty') qtvs mb_sig_inst
917
918 ; let inferred_poly_ty = mkForAllTys binders (mkPhiTy theta' mono_ty')
919
920 ; traceTc "mkInferredPolyId" (vcat [ppr poly_name, ppr qtvs, ppr theta'
921 , ppr inferred_poly_ty])
922 ; unless insoluble $
923 addErrCtxtM (mk_inf_msg poly_name inferred_poly_ty) $
924 checkValidType (InfSigCtxt poly_name) inferred_poly_ty
925 -- See Note [Validity of inferred types]
926 -- If we found an insoluble error in the function definition, don't
927 -- do this check; otherwise (Trac #14000) we may report an ambiguity
928 -- error for a rather bogus type.
929
930 ; return (mkLocalIdOrCoVar poly_name inferred_poly_ty) }
931
932
933 chooseInferredQuantifiers :: TcThetaType -- inferred
934 -> TcTyVarSet -- tvs free in tau type
935 -> [TcTyVar] -- inferred quantified tvs
936 -> Maybe TcIdSigInst
937 -> TcM ([TyVarBinder], TcThetaType)
938 chooseInferredQuantifiers inferred_theta tau_tvs qtvs Nothing
939 = -- No type signature (partial or complete) for this binder,
940 do { let free_tvs = closeOverKinds (growThetaTyVars inferred_theta tau_tvs)
941 -- Include kind variables! Trac #7916
942 my_theta = pickCapturedPreds free_tvs inferred_theta
943 binders = [ mkTyVarBinder Inferred tv
944 | tv <- qtvs
945 , tv `elemVarSet` free_tvs ]
946 ; return (binders, my_theta) }
947
948 chooseInferredQuantifiers inferred_theta tau_tvs qtvs
949 (Just (TISI { sig_inst_sig = sig -- Always PartialSig
950 , sig_inst_wcx = wcx
951 , sig_inst_theta = annotated_theta
952 , sig_inst_skols = annotated_tvs }))
953 = -- Choose quantifiers for a partial type signature
954 do { psig_qtv_prs <- zonkSigTyVarPairs annotated_tvs
955
956 -- Check whether the quantified variables of the
957 -- partial signature have been unified together
958 -- See Note [Quantified variables in partial type signatures]
959 ; mapM_ report_dup_sig_tv_err (findDupSigTvs psig_qtv_prs)
960
961 -- Check whether a quantified variable of the partial type
962 -- signature is not actually quantified. How can that happen?
963 -- See Note [Quantification and partial signatures] Wrinkle 4
964 -- in TcSimplify
965 ; mapM_ report_mono_sig_tv_err [ n | (n,tv) <- psig_qtv_prs
966 , not (tv `elem` qtvs) ]
967
968 ; let psig_qtvs = mkVarSet (map snd psig_qtv_prs)
969
970 ; annotated_theta <- zonkTcTypes annotated_theta
971 ; (free_tvs, my_theta) <- choose_psig_context psig_qtvs annotated_theta wcx
972
973 ; let keep_me = free_tvs `unionVarSet` psig_qtvs
974 final_qtvs = [ mkTyVarBinder vis tv
975 | tv <- qtvs -- Pulling from qtvs maintains original order
976 , tv `elemVarSet` keep_me
977 , let vis | tv `elemVarSet` psig_qtvs = Specified
978 | otherwise = Inferred ]
979
980 ; return (final_qtvs, my_theta) }
981 where
982 report_dup_sig_tv_err (n1,n2)
983 | PartialSig { psig_name = fn_name, psig_hs_ty = hs_ty } <- sig
984 = addErrTc (hang (text "Couldn't match" <+> quotes (ppr n1)
985 <+> text "with" <+> quotes (ppr n2))
986 2 (hang (text "both bound by the partial type signature:")
987 2 (ppr fn_name <+> dcolon <+> ppr hs_ty)))
988
989 | otherwise -- Can't happen; by now we know it's a partial sig
990 = pprPanic "report_sig_tv_err" (ppr sig)
991
992 report_mono_sig_tv_err n
993 | PartialSig { psig_name = fn_name, psig_hs_ty = hs_ty } <- sig
994 = addErrTc (hang (text "Can't quantify over" <+> quotes (ppr n))
995 2 (hang (text "bound by the partial type signature:")
996 2 (ppr fn_name <+> dcolon <+> ppr hs_ty)))
997 | otherwise -- Can't happen; by now we know it's a partial sig
998 = pprPanic "report_sig_tv_err" (ppr sig)
999
1000 choose_psig_context :: VarSet -> TcThetaType -> Maybe TcType
1001 -> TcM (VarSet, TcThetaType)
1002 choose_psig_context _ annotated_theta Nothing
1003 = do { let free_tvs = closeOverKinds (tyCoVarsOfTypes annotated_theta
1004 `unionVarSet` tau_tvs)
1005 ; return (free_tvs, annotated_theta) }
1006
1007 choose_psig_context psig_qtvs annotated_theta (Just wc_var_ty)
1008 = do { let free_tvs = closeOverKinds (growThetaTyVars inferred_theta seed_tvs)
1009 -- growThetaVars just like the no-type-sig case
1010 -- Omitting this caused #12844
1011 seed_tvs = tyCoVarsOfTypes annotated_theta -- These are put there
1012 `unionVarSet` tau_tvs -- by the user
1013
1014 ; let keep_me = psig_qtvs `unionVarSet` free_tvs
1015 my_theta = pickCapturedPreds keep_me inferred_theta
1016
1017 -- Fill in the extra-constraints wildcard hole with inferred_theta,
1018 -- so that the Hole constraint we have already emitted
1019 -- (in tcHsPartialSigType) can report what filled it in.
1020 -- NB: my_theta already includes all the annotated constraints
1021 ; let inferred_diff = [ pred
1022 | pred <- my_theta
1023 , all (not . (`eqType` pred)) annotated_theta ]
1024 ; ctuple <- mk_ctuple inferred_diff
1025
1026 ; case tcGetCastedTyVar_maybe wc_var_ty of
1027 -- We know that wc_co must have type kind(wc_var) ~ Constraint, as it
1028 -- comes from the checkExpectedKind in TcHsType.tcWildCardOcc. So, to
1029 -- make the kinds work out, we reverse the cast here.
1030 Just (wc_var, wc_co) -> writeMetaTyVar wc_var (ctuple `mkCastTy` mkTcSymCo wc_co)
1031 Nothing -> pprPanic "chooseInferredQuantifiers 1" (ppr wc_var_ty)
1032
1033 ; traceTc "completeTheta" $
1034 vcat [ ppr sig
1035 , ppr annotated_theta, ppr inferred_theta
1036 , ppr inferred_diff ]
1037 ; return (free_tvs, my_theta) }
1038
1039 mk_ctuple preds = return (mkBoxedTupleTy preds)
1040 -- Hack alert! See TcHsType:
1041 -- Note [Extra-constraint holes in partial type signatures]
1042
1043
1044 mk_impedance_match_msg :: MonoBindInfo
1045 -> TcType -> TcType
1046 -> TidyEnv -> TcM (TidyEnv, SDoc)
1047 -- This is a rare but rather awkward error messages
1048 mk_impedance_match_msg (MBI { mbi_poly_name = name, mbi_sig = mb_sig })
1049 inf_ty sig_ty tidy_env
1050 = do { (tidy_env1, inf_ty) <- zonkTidyTcType tidy_env inf_ty
1051 ; (tidy_env2, sig_ty) <- zonkTidyTcType tidy_env1 sig_ty
1052 ; let msg = vcat [ text "When checking that the inferred type"
1053 , nest 2 $ ppr name <+> dcolon <+> ppr inf_ty
1054 , text "is as general as its" <+> what <+> text "signature"
1055 , nest 2 $ ppr name <+> dcolon <+> ppr sig_ty ]
1056 ; return (tidy_env2, msg) }
1057 where
1058 what = case mb_sig of
1059 Nothing -> text "inferred"
1060 Just sig | isPartialSig sig -> text "(partial)"
1061 | otherwise -> empty
1062
1063
1064 mk_inf_msg :: Name -> TcType -> TidyEnv -> TcM (TidyEnv, SDoc)
1065 mk_inf_msg poly_name poly_ty tidy_env
1066 = do { (tidy_env1, poly_ty) <- zonkTidyTcType tidy_env poly_ty
1067 ; let msg = vcat [ text "When checking the inferred type"
1068 , nest 2 $ ppr poly_name <+> dcolon <+> ppr poly_ty ]
1069 ; return (tidy_env1, msg) }
1070
1071
1072 -- | Warn the user about polymorphic local binders that lack type signatures.
1073 localSigWarn :: WarningFlag -> Id -> Maybe TcIdSigInst -> TcM ()
1074 localSigWarn flag id mb_sig
1075 | Just _ <- mb_sig = return ()
1076 | not (isSigmaTy (idType id)) = return ()
1077 | otherwise = warnMissingSignatures flag msg id
1078 where
1079 msg = text "Polymorphic local binding with no type signature:"
1080
1081 warnMissingSignatures :: WarningFlag -> SDoc -> Id -> TcM ()
1082 warnMissingSignatures flag msg id
1083 = do { env0 <- tcInitTidyEnv
1084 ; let (env1, tidy_ty) = tidyOpenType env0 (idType id)
1085 ; addWarnTcM (Reason flag) (env1, mk_msg tidy_ty) }
1086 where
1087 mk_msg ty = sep [ msg, nest 2 $ pprPrefixName (idName id) <+> dcolon <+> ppr ty ]
1088
1089 checkOverloadedSig :: Bool -> TcIdSigInst -> TcM ()
1090 -- Example:
1091 -- f :: Eq a => a -> a
1092 -- K f = e
1093 -- The MR applies, but the signature is overloaded, and it's
1094 -- best to complain about this directly
1095 -- c.f Trac #11339
1096 checkOverloadedSig monomorphism_restriction_applies sig
1097 | not (null (sig_inst_theta sig))
1098 , monomorphism_restriction_applies
1099 , let orig_sig = sig_inst_sig sig
1100 = setSrcSpan (sig_loc orig_sig) $
1101 failWith $
1102 hang (text "Overloaded signature conflicts with monomorphism restriction")
1103 2 (ppr orig_sig)
1104 | otherwise
1105 = return ()
1106
1107 {- Note [Partial type signatures and generalisation]
1108 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1109 If /any/ of the signatures in the gropu is a partial type signature
1110 f :: _ -> Int
1111 then we *always* use the InferGen plan, and hence tcPolyInfer.
1112 We do this even for a local binding with -XMonoLocalBinds, when
1113 we normally use NoGen.
1114
1115 Reasons:
1116 * The TcSigInfo for 'f' has a unification variable for the '_',
1117 whose TcLevel is one level deeper than the current level.
1118 (See pushTcLevelM in tcTySig.) But NoGen doesn't increase
1119 the TcLevel like InferGen, so we lose the level invariant.
1120
1121 * The signature might be f :: forall a. _ -> a
1122 so it really is polymorphic. It's not clear what it would
1123 mean to use NoGen on this, and indeed the ASSERT in tcLhs,
1124 in the (Just sig) case, checks that if there is a signature
1125 then we are using LetLclBndr, and hence a nested AbsBinds with
1126 increased TcLevel
1127
1128 It might be possible to fix these difficulties somehow, but there
1129 doesn't seem much point. Indeed, adding a partial type signature is a
1130 way to get per-binding inferred generalisation.
1131
1132 We apply the MR if /all/ of the partial signatures lack a context.
1133 In particular (Trac #11016):
1134 f2 :: (?loc :: Int) => _
1135 f2 = ?loc
1136 It's stupid to apply the MR here. This test includes an extra-constraints
1137 wildcard; that is, we don't apply the MR if you write
1138 f3 :: _ => blah
1139
1140 Note [Quantified variables in partial type signatures]
1141 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1142 Consider
1143 f :: forall a. a -> a -> _
1144 f x y = g x y
1145 g :: forall b. b -> b -> _
1146 g x y = [x, y]
1147
1148 Here, 'f' and 'g' are mutually recursive, and we end up unifying 'a' and 'b'
1149 together, which is fine. So we bind 'a' and 'b' to SigTvs, which can then
1150 unify with each other.
1151
1152 But now consider:
1153 f :: forall a b. a -> b -> _
1154 f x y = [x, y]
1155
1156 We want to get an error from this, because 'a' and 'b' get unified.
1157 So we make a test, one per parital signature, to check that the
1158 explicitly-quantified type variables have not been unified together.
1159 Trac #14449 showed this up.
1160
1161
1162 Note [Validity of inferred types]
1163 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1164 We need to check inferred type for validity, in case it uses language
1165 extensions that are not turned on. The principle is that if the user
1166 simply adds the inferred type to the program source, it'll compile fine.
1167 See #8883.
1168
1169 Examples that might fail:
1170 - the type might be ambiguous
1171
1172 - an inferred theta that requires type equalities e.g. (F a ~ G b)
1173 or multi-parameter type classes
1174 - an inferred type that includes unboxed tuples
1175
1176
1177 Note [Impedance matching]
1178 ~~~~~~~~~~~~~~~~~~~~~~~~~
1179 Consider
1180 f 0 x = x
1181 f n x = g [] (not x)
1182
1183 g [] y = f 10 y
1184 g _ y = f 9 y
1185
1186 After typechecking we'll get
1187 f_mono_ty :: a -> Bool -> Bool
1188 g_mono_ty :: [b] -> Bool -> Bool
1189 with constraints
1190 (Eq a, Num a)
1191
1192 Note that f is polymorphic in 'a' and g in 'b'; and these are not linked.
1193 The types we really want for f and g are
1194 f :: forall a. (Eq a, Num a) => a -> Bool -> Bool
1195 g :: forall b. [b] -> Bool -> Bool
1196
1197 We can get these by "impedance matching":
1198 tuple :: forall a b. (Eq a, Num a) => (a -> Bool -> Bool, [b] -> Bool -> Bool)
1199 tuple a b d1 d1 = let ...bind f_mono, g_mono in (f_mono, g_mono)
1200
1201 f a d1 d2 = case tuple a Any d1 d2 of (f, g) -> f
1202 g b = case tuple Integer b dEqInteger dNumInteger of (f,g) -> g
1203
1204 Suppose the shared quantified tyvars are qtvs and constraints theta.
1205 Then we want to check that
1206 forall qtvs. theta => f_mono_ty is more polymorphic than f's polytype
1207 and the proof is the impedance matcher.
1208
1209 Notice that the impedance matcher may do defaulting. See Trac #7173.
1210
1211 It also cleverly does an ambiguity check; for example, rejecting
1212 f :: F a -> F a
1213 where F is a non-injective type function.
1214 -}
1215
1216
1217 {-
1218 Note [SPECIALISE pragmas]
1219 ~~~~~~~~~~~~~~~~~~~~~~~~~
1220 There is no point in a SPECIALISE pragma for a non-overloaded function:
1221 reverse :: [a] -> [a]
1222 {-# SPECIALISE reverse :: [Int] -> [Int] #-}
1223
1224 But SPECIALISE INLINE *can* make sense for GADTS:
1225 data Arr e where
1226 ArrInt :: !Int -> ByteArray# -> Arr Int
1227 ArrPair :: !Int -> Arr e1 -> Arr e2 -> Arr (e1, e2)
1228
1229 (!:) :: Arr e -> Int -> e
1230 {-# SPECIALISE INLINE (!:) :: Arr Int -> Int -> Int #-}
1231 {-# SPECIALISE INLINE (!:) :: Arr (a, b) -> Int -> (a, b) #-}
1232 (ArrInt _ ba) !: (I# i) = I# (indexIntArray# ba i)
1233 (ArrPair _ a1 a2) !: i = (a1 !: i, a2 !: i)
1234
1235 When (!:) is specialised it becomes non-recursive, and can usefully
1236 be inlined. Scary! So we only warn for SPECIALISE *without* INLINE
1237 for a non-overloaded function.
1238
1239 ************************************************************************
1240 * *
1241 tcMonoBinds
1242 * *
1243 ************************************************************************
1244
1245 @tcMonoBinds@ deals with a perhaps-recursive group of HsBinds.
1246 The signatures have been dealt with already.
1247 -}
1248
1249 data MonoBindInfo = MBI { mbi_poly_name :: Name
1250 , mbi_sig :: Maybe TcIdSigInst
1251 , mbi_mono_id :: TcId }
1252
1253 tcMonoBinds :: RecFlag -- Whether the binding is recursive for typechecking purposes
1254 -- i.e. the binders are mentioned in their RHSs, and
1255 -- we are not rescued by a type signature
1256 -> TcSigFun -> LetBndrSpec
1257 -> [LHsBind GhcRn]
1258 -> TcM (LHsBinds GhcTcId, [MonoBindInfo])
1259 tcMonoBinds is_rec sig_fn no_gen
1260 [ L b_loc (FunBind { fun_id = L nm_loc name,
1261 fun_matches = matches, fun_ext = fvs })]
1262 -- Single function binding,
1263 | NonRecursive <- is_rec -- ...binder isn't mentioned in RHS
1264 , Nothing <- sig_fn name -- ...with no type signature
1265 = -- Note [Single function non-recursive binding special-case]
1266 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1267 -- In this very special case we infer the type of the
1268 -- right hand side first (it may have a higher-rank type)
1269 -- and *then* make the monomorphic Id for the LHS
1270 -- e.g. f = \(x::forall a. a->a) -> <body>
1271 -- We want to infer a higher-rank type for f
1272 setSrcSpan b_loc $
1273 do { ((co_fn, matches'), rhs_ty)
1274 <- tcInferInst $ \ exp_ty ->
1275 -- tcInferInst: see TcUnify,
1276 -- Note [Deep instantiation of InferResult]
1277 tcExtendBinderStack [TcIdBndr_ExpType name exp_ty NotTopLevel] $
1278 -- We extend the error context even for a non-recursive
1279 -- function so that in type error messages we show the
1280 -- type of the thing whose rhs we are type checking
1281 tcMatchesFun (L nm_loc name) matches exp_ty
1282
1283 ; mono_id <- newLetBndr no_gen name rhs_ty
1284 ; return (unitBag $ L b_loc $
1285 FunBind { fun_id = L nm_loc mono_id,
1286 fun_matches = matches', fun_ext = fvs,
1287 fun_co_fn = co_fn, fun_tick = [] },
1288 [MBI { mbi_poly_name = name
1289 , mbi_sig = Nothing
1290 , mbi_mono_id = mono_id }]) }
1291
1292 tcMonoBinds _ sig_fn no_gen binds
1293 = do { tc_binds <- mapM (wrapLocM (tcLhs sig_fn no_gen)) binds
1294
1295 -- Bring the monomorphic Ids, into scope for the RHSs
1296 ; let mono_infos = getMonoBindInfo tc_binds
1297 rhs_id_env = [ (name, mono_id)
1298 | MBI { mbi_poly_name = name
1299 , mbi_sig = mb_sig
1300 , mbi_mono_id = mono_id } <- mono_infos
1301 , case mb_sig of
1302 Just sig -> isPartialSig sig
1303 Nothing -> True ]
1304 -- A monomorphic binding for each term variable that lacks
1305 -- a complete type sig. (Ones with a sig are already in scope.)
1306
1307 ; traceTc "tcMonoBinds" $ vcat [ ppr n <+> ppr id <+> ppr (idType id)
1308 | (n,id) <- rhs_id_env]
1309 ; binds' <- tcExtendRecIds rhs_id_env $
1310 mapM (wrapLocM tcRhs) tc_binds
1311
1312 ; return (listToBag binds', mono_infos) }
1313
1314
1315 ------------------------
1316 -- tcLhs typechecks the LHS of the bindings, to construct the environment in which
1317 -- we typecheck the RHSs. Basically what we are doing is this: for each binder:
1318 -- if there's a signature for it, use the instantiated signature type
1319 -- otherwise invent a type variable
1320 -- You see that quite directly in the FunBind case.
1321 --
1322 -- But there's a complication for pattern bindings:
1323 -- data T = MkT (forall a. a->a)
1324 -- MkT f = e
1325 -- Here we can guess a type variable for the entire LHS (which will be refined to T)
1326 -- but we want to get (f::forall a. a->a) as the RHS environment.
1327 -- The simplest way to do this is to typecheck the pattern, and then look up the
1328 -- bound mono-ids. Then we want to retain the typechecked pattern to avoid re-doing
1329 -- it; hence the TcMonoBind data type in which the LHS is done but the RHS isn't
1330
1331 data TcMonoBind -- Half completed; LHS done, RHS not done
1332 = TcFunBind MonoBindInfo SrcSpan (MatchGroup GhcRn (LHsExpr GhcRn))
1333 | TcPatBind [MonoBindInfo] (LPat GhcTcId) (GRHSs GhcRn (LHsExpr GhcRn))
1334 TcSigmaType
1335
1336 tcLhs :: TcSigFun -> LetBndrSpec -> HsBind GhcRn -> TcM TcMonoBind
1337 -- Only called with plan InferGen (LetBndrSpec = LetLclBndr)
1338 -- or NoGen (LetBndrSpec = LetGblBndr)
1339 -- CheckGen is used only for functions with a complete type signature,
1340 -- and tcPolyCheck doesn't use tcMonoBinds at all
1341
1342 tcLhs sig_fn no_gen (FunBind { fun_id = L nm_loc name, fun_matches = matches })
1343 | Just (TcIdSig sig) <- sig_fn name
1344 = -- There is a type signature.
1345 -- It must be partial; if complete we'd be in tcPolyCheck!
1346 -- e.g. f :: _ -> _
1347 -- f x = ...g...
1348 -- Just g = ...f...
1349 -- Hence always typechecked with InferGen
1350 do { mono_info <- tcLhsSigId no_gen (name, sig)
1351 ; return (TcFunBind mono_info nm_loc matches) }
1352
1353 | otherwise -- No type signature
1354 = do { mono_ty <- newOpenFlexiTyVarTy
1355 ; mono_id <- newLetBndr no_gen name mono_ty
1356 ; let mono_info = MBI { mbi_poly_name = name
1357 , mbi_sig = Nothing
1358 , mbi_mono_id = mono_id }
1359 ; return (TcFunBind mono_info nm_loc matches) }
1360
1361 tcLhs sig_fn no_gen (PatBind { pat_lhs = pat, pat_rhs = grhss })
1362 = -- See Note [Typechecking pattern bindings]
1363 do { sig_mbis <- mapM (tcLhsSigId no_gen) sig_names
1364
1365 ; let inst_sig_fun = lookupNameEnv $ mkNameEnv $
1366 [ (mbi_poly_name mbi, mbi_mono_id mbi)
1367 | mbi <- sig_mbis ]
1368
1369 -- See Note [Existentials in pattern bindings]
1370 ; ((pat', nosig_mbis), pat_ty)
1371 <- addErrCtxt (patMonoBindsCtxt pat grhss) $
1372 tcInferNoInst $ \ exp_ty ->
1373 tcLetPat inst_sig_fun no_gen pat exp_ty $
1374 mapM lookup_info nosig_names
1375
1376 ; let mbis = sig_mbis ++ nosig_mbis
1377
1378 ; traceTc "tcLhs" (vcat [ ppr id <+> dcolon <+> ppr (idType id)
1379 | mbi <- mbis, let id = mbi_mono_id mbi ]
1380 $$ ppr no_gen)
1381
1382 ; return (TcPatBind mbis pat' grhss pat_ty) }
1383 where
1384 bndr_names = collectPatBinders pat
1385 (nosig_names, sig_names) = partitionWith find_sig bndr_names
1386
1387 find_sig :: Name -> Either Name (Name, TcIdSigInfo)
1388 find_sig name = case sig_fn name of
1389 Just (TcIdSig sig) -> Right (name, sig)
1390 _ -> Left name
1391
1392 -- After typechecking the pattern, look up the binder
1393 -- names that lack a signature, which the pattern has brought
1394 -- into scope.
1395 lookup_info :: Name -> TcM MonoBindInfo
1396 lookup_info name
1397 = do { mono_id <- tcLookupId name
1398 ; return (MBI { mbi_poly_name = name
1399 , mbi_sig = Nothing
1400 , mbi_mono_id = mono_id }) }
1401
1402 tcLhs _ _ other_bind = pprPanic "tcLhs" (ppr other_bind)
1403 -- AbsBind, VarBind impossible
1404
1405 -------------------
1406 tcLhsSigId :: LetBndrSpec -> (Name, TcIdSigInfo) -> TcM MonoBindInfo
1407 tcLhsSigId no_gen (name, sig)
1408 = do { inst_sig <- tcInstSig sig
1409 ; mono_id <- newSigLetBndr no_gen name inst_sig
1410 ; return (MBI { mbi_poly_name = name
1411 , mbi_sig = Just inst_sig
1412 , mbi_mono_id = mono_id }) }
1413
1414 ------------
1415 newSigLetBndr :: LetBndrSpec -> Name -> TcIdSigInst -> TcM TcId
1416 newSigLetBndr (LetGblBndr prags) name (TISI { sig_inst_sig = id_sig })
1417 | CompleteSig { sig_bndr = poly_id } <- id_sig
1418 = addInlinePrags poly_id (lookupPragEnv prags name)
1419 newSigLetBndr no_gen name (TISI { sig_inst_tau = tau })
1420 = newLetBndr no_gen name tau
1421
1422 -------------------
1423 tcRhs :: TcMonoBind -> TcM (HsBind GhcTcId)
1424 tcRhs (TcFunBind info@(MBI { mbi_sig = mb_sig, mbi_mono_id = mono_id })
1425 loc matches)
1426 = tcExtendIdBinderStackForRhs [info] $
1427 tcExtendTyVarEnvForRhs mb_sig $
1428 do { traceTc "tcRhs: fun bind" (ppr mono_id $$ ppr (idType mono_id))
1429 ; (co_fn, matches') <- tcMatchesFun (L loc (idName mono_id))
1430 matches (mkCheckExpType $ idType mono_id)
1431 ; return ( FunBind { fun_id = L loc mono_id
1432 , fun_matches = matches'
1433 , fun_co_fn = co_fn
1434 , fun_ext = placeHolderNamesTc
1435 , fun_tick = [] } ) }
1436
1437 tcRhs (TcPatBind infos pat' grhss pat_ty)
1438 = -- When we are doing pattern bindings we *don't* bring any scoped
1439 -- type variables into scope unlike function bindings
1440 -- Wny not? They are not completely rigid.
1441 -- That's why we have the special case for a single FunBind in tcMonoBinds
1442 tcExtendIdBinderStackForRhs infos $
1443 do { traceTc "tcRhs: pat bind" (ppr pat' $$ ppr pat_ty)
1444 ; grhss' <- addErrCtxt (patMonoBindsCtxt pat' grhss) $
1445 tcGRHSsPat grhss pat_ty
1446 ; return ( PatBind { pat_lhs = pat', pat_rhs = grhss'
1447 , pat_ext = NPatBindTc placeHolderNamesTc pat_ty
1448 , pat_ticks = ([],[]) } )}
1449
1450 tcExtendTyVarEnvForRhs :: Maybe TcIdSigInst -> TcM a -> TcM a
1451 tcExtendTyVarEnvForRhs Nothing thing_inside
1452 = thing_inside
1453 tcExtendTyVarEnvForRhs (Just sig) thing_inside
1454 = tcExtendTyVarEnvFromSig sig thing_inside
1455
1456 tcExtendTyVarEnvFromSig :: TcIdSigInst -> TcM a -> TcM a
1457 tcExtendTyVarEnvFromSig sig_inst thing_inside
1458 | TISI { sig_inst_skols = skol_prs, sig_inst_wcs = wcs } <- sig_inst
1459 -- Note [Use tcExtendTyVar not scopeTyVars in tcRhs]
1460 = tcExtendTyVarEnv2 wcs $
1461 tcExtendTyVarEnv2 skol_prs $
1462 thing_inside
1463
1464 tcExtendIdBinderStackForRhs :: [MonoBindInfo] -> TcM a -> TcM a
1465 -- Extend the TcBinderStack for the RHS of the binding, with
1466 -- the monomorphic Id. That way, if we have, say
1467 -- f = \x -> blah
1468 -- and something goes wrong in 'blah', we get a "relevant binding"
1469 -- looking like f :: alpha -> beta
1470 -- This applies if 'f' has a type signature too:
1471 -- f :: forall a. [a] -> [a]
1472 -- f x = True
1473 -- We can't unify True with [a], and a relevant binding is f :: [a] -> [a]
1474 -- If we had the *polymorphic* version of f in the TcBinderStack, it
1475 -- would not be reported as relevant, because its type is closed
1476 tcExtendIdBinderStackForRhs infos thing_inside
1477 = tcExtendBinderStack [ TcIdBndr mono_id NotTopLevel
1478 | MBI { mbi_mono_id = mono_id } <- infos ]
1479 thing_inside
1480 -- NotTopLevel: it's a monomorphic binding
1481
1482 ---------------------
1483 getMonoBindInfo :: [Located TcMonoBind] -> [MonoBindInfo]
1484 getMonoBindInfo tc_binds
1485 = foldr (get_info . unLoc) [] tc_binds
1486 where
1487 get_info (TcFunBind info _ _) rest = info : rest
1488 get_info (TcPatBind infos _ _ _) rest = infos ++ rest
1489
1490
1491 {- Note [Typechecking pattern bindings]
1492 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1493 Look at:
1494 - typecheck/should_compile/ExPat
1495 - Trac #12427, typecheck/should_compile/T12427{a,b}
1496
1497 data T where
1498 MkT :: Integral a => a -> Int -> T
1499
1500 and suppose t :: T. Which of these pattern bindings are ok?
1501
1502 E1. let { MkT p _ = t } in <body>
1503
1504 E2. let { MkT _ q = t } in <body>
1505
1506 E3. let { MkT (toInteger -> r) _ = t } in <body>
1507
1508 * (E1) is clearly wrong because the existential 'a' escapes.
1509 What type could 'p' possibly have?
1510
1511 * (E2) is fine, despite the existential pattern, because
1512 q::Int, and nothing escapes.
1513
1514 * Even (E3) is fine. The existential pattern binds a dictionary
1515 for (Integral a) which the view pattern can use to convert the
1516 a-valued field to an Integer, so r :: Integer.
1517
1518 An easy way to see all three is to imagine the desugaring.
1519 For (E2) it would look like
1520 let q = case t of MkT _ q' -> q'
1521 in <body>
1522
1523
1524 We typecheck pattern bindings as follows. First tcLhs does this:
1525
1526 1. Take each type signature q :: ty, partial or complete, and
1527 instantiate it (with tcLhsSigId) to get a MonoBindInfo. This
1528 gives us a fresh "mono_id" qm :: instantiate(ty), where qm has
1529 a fresh name.
1530
1531 Any fresh unification variables in instantiate(ty) born here, not
1532 deep under implications as would happen if we allocated them when
1533 we encountered q during tcPat.
1534
1535 2. Build a little environment mapping "q" -> "qm" for those Ids
1536 with signatures (inst_sig_fun)
1537
1538 3. Invoke tcLetPat to typecheck the pattern.
1539
1540 - We pass in the current TcLevel. This is captured by
1541 TcPat.tcLetPat, and put into the pc_lvl field of PatCtxt, in
1542 PatEnv.
1543
1544 - When tcPat finds an existential constructor, it binds fresh
1545 type variables and dictionaries as usual, increments the TcLevel,
1546 and emits an implication constraint.
1547
1548 - When we come to a binder (TcPat.tcPatBndr), it looks it up
1549 in the little environment (the pc_sig_fn field of PatCtxt).
1550
1551 Success => There was a type signature, so just use it,
1552 checking compatibility with the expected type.
1553
1554 Failure => No type sigature.
1555 Infer case: (happens only outside any constructor pattern)
1556 use a unification variable
1557 at the outer level pc_lvl
1558
1559 Check case: use promoteTcType to promote the type
1560 to the outer level pc_lvl. This is the
1561 place where we emit a constraint that'll blow
1562 up if existential capture takes place
1563
1564 Result: the type of the binder is always at pc_lvl. This is
1565 crucial.
1566
1567 4. Throughout, when we are making up an Id for the pattern-bound variables
1568 (newLetBndr), we have two cases:
1569
1570 - If we are generalising (generalisation plan is InferGen or
1571 CheckGen), then the let_bndr_spec will be LetLclBndr. In that case
1572 we want to bind a cloned, local version of the variable, with the
1573 type given by the pattern context, *not* by the signature (even if
1574 there is one; see Trac #7268). The mkExport part of the
1575 generalisation step will do the checking and impedance matching
1576 against the signature.
1577
1578 - If for some some reason we are not generalising (plan = NoGen), the
1579 LetBndrSpec will be LetGblBndr. In that case we must bind the
1580 global version of the Id, and do so with precisely the type given
1581 in the signature. (Then we unify with the type from the pattern
1582 context type.)
1583
1584
1585 And that's it! The implication constraints check for the skolem
1586 escape. It's quite simple and neat, and more expressive than before
1587 e.g. GHC 8.0 rejects (E2) and (E3).
1588
1589 Example for (E1), starting at level 1. We generate
1590 p :: beta:1, with constraints (forall:3 a. Integral a => a ~ beta)
1591 The (a~beta) can't float (because of the 'a'), nor be solved (because
1592 beta is untouchable.)
1593
1594 Example for (E2), we generate
1595 q :: beta:1, with constraint (forall:3 a. Integral a => Int ~ beta)
1596 The beta is untoucable, but floats out of the constraint and can
1597 be solved absolutely fine.
1598
1599 Note [Use tcExtendTyVar not scopeTyVars in tcRhs]
1600 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1601 Normally, any place that corresponds to Λ or ∀ in Core should be flagged
1602 with a call to scopeTyVars, which arranges for an implication constraint
1603 to be made, bumps the TcLevel, and (crucially) prevents a unification
1604 variable created outside the scope of a local skolem to unify with that
1605 skolem.
1606
1607 We do not need to do this here, however.
1608
1609 - Note that this happens only in the case of a partial signature.
1610 Complete signatures go via tcPolyCheck, not tcPolyInfer.
1611
1612 - The TcLevel is incremented in tcPolyInfer, right outside the call
1613 to tcMonoBinds. We thus don't have to worry about outer metatvs unifying
1614 with local skolems.
1615
1616 - The other potential concern is that we need SkolemInfo associated with
1617 the skolems. This, too, is OK, though: the constraints pass through
1618 simplifyInfer (which doesn't report errors), at the end of which
1619 the skolems will get quantified and put into an implication constraint.
1620 Thus, by the time any errors are reported, the SkolemInfo will be
1621 in place.
1622
1623 ************************************************************************
1624 * *
1625 Generalisation
1626 * *
1627 ********************************************************************* -}
1628
1629 data GeneralisationPlan
1630 = NoGen -- No generalisation, no AbsBinds
1631
1632 | InferGen -- Implicit generalisation; there is an AbsBinds
1633 Bool -- True <=> apply the MR; generalise only unconstrained type vars
1634
1635 | CheckGen (LHsBind GhcRn) TcIdSigInfo
1636 -- One FunBind with a signature
1637 -- Explicit generalisation
1638
1639 -- A consequence of the no-AbsBinds choice (NoGen) is that there is
1640 -- no "polymorphic Id" and "monmomorphic Id"; there is just the one
1641
1642 instance Outputable GeneralisationPlan where
1643 ppr NoGen = text "NoGen"
1644 ppr (InferGen b) = text "InferGen" <+> ppr b
1645 ppr (CheckGen _ s) = text "CheckGen" <+> ppr s
1646
1647 decideGeneralisationPlan
1648 :: DynFlags -> [LHsBind GhcRn] -> IsGroupClosed -> TcSigFun
1649 -> GeneralisationPlan
1650 decideGeneralisationPlan dflags lbinds closed sig_fn
1651 | has_partial_sigs = InferGen (and partial_sig_mrs)
1652 | Just (bind, sig) <- one_funbind_with_sig = CheckGen bind sig
1653 | do_not_generalise closed = NoGen
1654 | otherwise = InferGen mono_restriction
1655 where
1656 binds = map unLoc lbinds
1657
1658 partial_sig_mrs :: [Bool]
1659 -- One for each partial signature (so empty => no partial sigs)
1660 -- The Bool is True if the signature has no constraint context
1661 -- so we should apply the MR
1662 -- See Note [Partial type signatures and generalisation]
1663 partial_sig_mrs
1664 = [ null theta
1665 | TcIdSig (PartialSig { psig_hs_ty = hs_ty })
1666 <- mapMaybe sig_fn (collectHsBindListBinders lbinds)
1667 , let (_, L _ theta, _) = splitLHsSigmaTy (hsSigWcType hs_ty) ]
1668
1669 has_partial_sigs = not (null partial_sig_mrs)
1670
1671 mono_restriction = xopt LangExt.MonomorphismRestriction dflags
1672 && any restricted binds
1673
1674 do_not_generalise (IsGroupClosed _ True) = False
1675 -- The 'True' means that all of the group's
1676 -- free vars have ClosedTypeId=True; so we can ignore
1677 -- -XMonoLocalBinds, and generalise anyway
1678 do_not_generalise _ = xopt LangExt.MonoLocalBinds dflags
1679
1680 -- With OutsideIn, all nested bindings are monomorphic
1681 -- except a single function binding with a signature
1682 one_funbind_with_sig
1683 | [lbind@(L _ (FunBind { fun_id = v }))] <- lbinds
1684 , Just (TcIdSig sig) <- sig_fn (unLoc v)
1685 = Just (lbind, sig)
1686 | otherwise
1687 = Nothing
1688
1689 -- The Haskell 98 monomorphism restriction
1690 restricted (PatBind {}) = True
1691 restricted (VarBind { var_id = v }) = no_sig v
1692 restricted (FunBind { fun_id = v, fun_matches = m }) = restricted_match m
1693 && no_sig (unLoc v)
1694 restricted b = pprPanic "isRestrictedGroup/unrestricted" (ppr b)
1695
1696 restricted_match mg = matchGroupArity mg == 0
1697 -- No args => like a pattern binding
1698 -- Some args => a function binding
1699
1700 no_sig n = not (hasCompleteSig sig_fn n)
1701
1702 isClosedBndrGroup :: TcTypeEnv -> Bag (LHsBind GhcRn) -> IsGroupClosed
1703 isClosedBndrGroup type_env binds
1704 = IsGroupClosed fv_env type_closed
1705 where
1706 type_closed = allUFM (nameSetAll is_closed_type_id) fv_env
1707
1708 fv_env :: NameEnv NameSet
1709 fv_env = mkNameEnv $ concatMap (bindFvs . unLoc) binds
1710
1711 bindFvs :: HsBindLR GhcRn GhcRn -> [(Name, NameSet)]
1712 bindFvs (FunBind { fun_id = L _ f, fun_ext = fvs })
1713 = let open_fvs = get_open_fvs fvs
1714 in [(f, open_fvs)]
1715 bindFvs (PatBind { pat_lhs = pat, pat_ext = fvs })
1716 = let open_fvs = get_open_fvs fvs
1717 in [(b, open_fvs) | b <- collectPatBinders pat]
1718 bindFvs _
1719 = []
1720
1721 get_open_fvs fvs = filterNameSet (not . is_closed) fvs
1722
1723 is_closed :: Name -> ClosedTypeId
1724 is_closed name
1725 | Just thing <- lookupNameEnv type_env name
1726 = case thing of
1727 AGlobal {} -> True
1728 ATcId { tct_info = ClosedLet } -> True
1729 _ -> False
1730
1731 | otherwise
1732 = True -- The free-var set for a top level binding mentions
1733
1734
1735 is_closed_type_id :: Name -> Bool
1736 -- We're already removed Global and ClosedLet Ids
1737 is_closed_type_id name
1738 | Just thing <- lookupNameEnv type_env name
1739 = case thing of
1740 ATcId { tct_info = NonClosedLet _ cl } -> cl
1741 ATcId { tct_info = NotLetBound } -> False
1742 ATyVar {} -> False
1743 -- In-scope type variables are not closed!
1744 _ -> pprPanic "is_closed_id" (ppr name)
1745
1746 | otherwise
1747 = True -- The free-var set for a top level binding mentions
1748 -- imported things too, so that we can report unused imports
1749 -- These won't be in the local type env.
1750 -- Ditto class method etc from the current module
1751
1752
1753 {- *********************************************************************
1754 * *
1755 Error contexts and messages
1756 * *
1757 ********************************************************************* -}
1758
1759 -- This one is called on LHS, when pat and grhss are both Name
1760 -- and on RHS, when pat is TcId and grhss is still Name
1761 patMonoBindsCtxt :: (OutputableBndrId (GhcPass p), Outputable body)
1762 => LPat (GhcPass p) -> GRHSs GhcRn body -> SDoc
1763 patMonoBindsCtxt pat grhss
1764 = hang (text "In a pattern binding:") 2 (pprPatBind pat grhss)