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