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