2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 \section[TcBinds]{TcBinds}
7 module TcBinds ( tcBindsAndThen, tcTopBinds,
8 tcSpecSigs, tcBindWithSigs ) where
10 #include "HsVersions.h"
12 import {-# SOURCE #-} TcMatches ( tcGRHSs, tcMatchesFun )
13 import {-# SOURCE #-} TcExpr ( tcExpr )
15 import CmdLineOpts ( opt_NoMonomorphismRestriction )
16 import HsSyn ( HsExpr(..), HsBinds(..), MonoBinds(..), Sig(..), StmtCtxt(..),
17 Match(..), collectMonoBinders, andMonoBinds
19 import RnHsSyn ( RenamedHsBinds, RenamedSig, RenamedMonoBinds )
20 import TcHsSyn ( TcMonoBinds, TcId, zonkId, mkHsLet )
23 import Inst ( LIE, emptyLIE, mkLIE, plusLIE, InstOrigin(..),
24 newDicts, tyVarsOfInst, instToId,
25 getAllFunDepsOfLIE, getIPsOfLIE, zonkFunDeps
27 import TcEnv ( tcExtendLocalValEnv,
28 newSpecPragmaId, newLocalId,
30 tcGetGlobalTyVars, tcExtendGlobalTyVars
32 import TcSimplify ( tcSimplify, tcSimplifyAndCheck, tcSimplifyToDicts )
33 import TcImprove ( tcImprove )
34 import TcMonoType ( tcHsSigType, checkSigTyVars,
35 TcSigInfo(..), tcTySig, maybeSig, sigCtxt
37 import TcPat ( tcPat )
38 import TcSimplify ( bindInstsOfLocalFuns )
39 import TcType ( TcThetaType, newTyVarTy, newTyVar,
40 zonkTcTypes, zonkTcThetaType, zonkTcTyVarToTyVar
42 import TcUnify ( unifyTauTy, unifyTauTyLists )
44 import CoreFVs ( idFreeTyVars )
45 import Id ( mkVanillaId, setInlinePragma )
46 import Var ( idType, idName )
47 import IdInfo ( InlinePragInfo(..) )
48 import Name ( Name, getOccName, getSrcLoc )
50 import Type ( mkTyVarTy, tyVarsOfTypes, mkTyConApp,
51 mkForAllTys, mkFunTys,
52 mkPredTy, mkForAllTy, isUnLiftedType,
53 isUnboxedType, unboxedTypeKind, boxedTypeKind, openTypeKind
55 import FunDeps ( oclose )
56 import Var ( tyVarKind )
60 import Maybes ( maybeToBool )
61 import BasicTypes ( TopLevelFlag(..), RecFlag(..), isNotTopLevel )
62 import FiniteMap ( listToFM, lookupFM )
63 import PrelNames ( ioTyConName, mainKey, hasKey )
68 %************************************************************************
70 \subsection{Type-checking bindings}
72 %************************************************************************
74 @tcBindsAndThen@ typechecks a @HsBinds@. The "and then" part is because
75 it needs to know something about the {\em usage} of the things bound,
76 so that it can create specialisations of them. So @tcBindsAndThen@
77 takes a function which, given an extended environment, E, typechecks
78 the scope of the bindings returning a typechecked thing and (most
79 important) an LIE. It is this LIE which is then used as the basis for
80 specialising the things bound.
82 @tcBindsAndThen@ also takes a "combiner" which glues together the
83 bindings and the "thing" to make a new "thing".
85 The real work is done by @tcBindWithSigsAndThen@.
87 Recursive and non-recursive binds are handled in essentially the same
88 way: because of uniques there are no scoping issues left. The only
89 difference is that non-recursive bindings can bind primitive values.
91 Even for non-recursive binding groups we add typings for each binder
92 to the LVE for the following reason. When each individual binding is
93 checked the type of its LHS is unified with that of its RHS; and
94 type-checking the LHS of course requires that the binder is in scope.
96 At the top-level the LIE is sure to contain nothing but constant
97 dictionaries, which we resolve at the module level.
100 tcTopBinds :: RenamedHsBinds -> TcM ((TcMonoBinds, TcEnv), LIE)
102 = tc_binds_and_then TopLevel glue binds $
103 tcGetEnv `thenNF_Tc` \ env ->
104 returnTc ((EmptyMonoBinds, env), emptyLIE)
106 glue is_rec binds1 (binds2, thing) = (binds1 `AndMonoBinds` binds2, thing)
110 :: (RecFlag -> TcMonoBinds -> thing -> thing) -- Combinator
115 tcBindsAndThen = tc_binds_and_then NotTopLevel
117 tc_binds_and_then top_lvl combiner EmptyBinds do_next
119 tc_binds_and_then top_lvl combiner (MonoBind EmptyMonoBinds sigs is_rec) do_next
122 tc_binds_and_then top_lvl combiner (ThenBinds b1 b2) do_next
123 = tc_binds_and_then top_lvl combiner b1 $
124 tc_binds_and_then top_lvl combiner b2 $
127 tc_binds_and_then top_lvl combiner (MonoBind bind sigs is_rec) do_next
128 = -- TYPECHECK THE SIGNATURES
129 mapTc tcTySig [sig | sig@(Sig name _ _) <- sigs] `thenTc` \ tc_ty_sigs ->
131 tcBindWithSigs top_lvl bind tc_ty_sigs
132 sigs is_rec `thenTc` \ (poly_binds, poly_lie, poly_ids) ->
134 -- Extend the environment to bind the new polymorphic Ids
135 tcExtendLocalValEnv [(idName poly_id, poly_id) | poly_id <- poly_ids] $
137 -- Build bindings and IdInfos corresponding to user pragmas
138 tcSpecSigs sigs `thenTc` \ (prag_binds, prag_lie) ->
140 -- Now do whatever happens next, in the augmented envt
141 do_next `thenTc` \ (thing, thing_lie) ->
143 -- Create specialisations of functions bound here
144 -- We want to keep non-recursive things non-recursive
145 -- so that we desugar unboxed bindings correctly
146 case (top_lvl, is_rec) of
148 -- For the top level don't bother will all this bindInstsOfLocalFuns stuff
149 -- All the top level things are rec'd together anyway, so it's fine to
150 -- leave them to the tcSimplifyTop, and quite a bit faster too
152 -> returnTc (combiner Recursive (poly_binds `andMonoBinds` prag_binds) thing,
153 thing_lie `plusLIE` prag_lie `plusLIE` poly_lie)
155 (NotTopLevel, NonRecursive)
156 -> bindInstsOfLocalFuns
157 (thing_lie `plusLIE` prag_lie)
158 poly_ids `thenTc` \ (thing_lie', lie_binds) ->
161 combiner NonRecursive poly_binds $
162 combiner NonRecursive prag_binds $
163 combiner Recursive lie_binds $
164 -- NB: the binds returned by tcSimplify and bindInstsOfLocalFuns
165 -- aren't guaranteed in dependency order (though we could change
166 -- that); hence the Recursive marker.
169 thing_lie' `plusLIE` poly_lie
172 (NotTopLevel, Recursive)
173 -> bindInstsOfLocalFuns
174 (thing_lie `plusLIE` poly_lie `plusLIE` prag_lie)
175 poly_ids `thenTc` \ (final_lie, lie_binds) ->
179 poly_binds `andMonoBinds`
180 lie_binds `andMonoBinds`
186 An aside. The original version of @tcBindsAndThen@ which lacks a
187 combiner function, appears below. Though it is perfectly well
188 behaved, it cannot be typed by Haskell, because the recursive call is
189 at a different type to the definition itself. There aren't too many
190 examples of this, which is why I thought it worth preserving! [SLPJ]
195 % -> TcM (thing, LIE, thing_ty))
196 % -> TcM ((TcHsBinds, thing), LIE, thing_ty)
198 % tcBindsAndThen EmptyBinds do_next
199 % = do_next `thenTc` \ (thing, lie, thing_ty) ->
200 % returnTc ((EmptyBinds, thing), lie, thing_ty)
202 % tcBindsAndThen (ThenBinds binds1 binds2) do_next
203 % = tcBindsAndThen binds1 (tcBindsAndThen binds2 do_next)
204 % `thenTc` \ ((binds1', (binds2', thing')), lie1, thing_ty) ->
206 % returnTc ((binds1' `ThenBinds` binds2', thing'), lie1, thing_ty)
208 % tcBindsAndThen (MonoBind bind sigs is_rec) do_next
209 % = tcBindAndThen bind sigs do_next
213 %************************************************************************
215 \subsection{tcBindWithSigs}
217 %************************************************************************
219 @tcBindWithSigs@ deals with a single binding group. It does generalisation,
220 so all the clever stuff is in here.
222 * binder_names and mbind must define the same set of Names
224 * The Names in tc_ty_sigs must be a subset of binder_names
226 * The Ids in tc_ty_sigs don't necessarily have to have the same name
227 as the Name in the tc_ty_sig
234 -> [RenamedSig] -- Used solely to get INLINE, NOINLINE sigs
236 -> TcM (TcMonoBinds, LIE, [TcId])
238 tcBindWithSigs top_lvl mbind tc_ty_sigs inline_sigs is_rec
240 -- If typechecking the binds fails, then return with each
241 -- signature-less binder given type (forall a.a), to minimise subsequent
243 newTyVar boxedTypeKind `thenNF_Tc` \ alpha_tv ->
245 forall_a_a = mkForAllTy alpha_tv (mkTyVarTy alpha_tv)
246 binder_names = collectMonoBinders mbind
247 poly_ids = map mk_dummy binder_names
248 mk_dummy name = case maybeSig tc_ty_sigs name of
249 Just (TySigInfo _ poly_id _ _ _ _ _ _) -> poly_id -- Signature
250 Nothing -> mkVanillaId name forall_a_a -- No signature
252 returnTc (EmptyMonoBinds, emptyLIE, poly_ids)
255 -- TYPECHECK THE BINDINGS
256 tcMonoBinds mbind tc_ty_sigs is_rec `thenTc` \ (mbind', lie_req, binder_names, mono_ids) ->
258 -- CHECK THAT THE SIGNATURES MATCH
259 -- (must do this before getTyVarsToGen)
260 checkSigMatch top_lvl binder_names mono_ids tc_ty_sigs `thenTc` \ maybe_sig_theta ->
263 -- Force any unifications dictated by functional dependencies.
264 -- Because unification may happen, it's important that this step
266 -- - computing vars over which to quantify
267 -- - zonking the generalized type vars
268 let lie_avail = case maybe_sig_theta of
271 lie_avail_req = lie_avail `plusLIE` lie_req in
272 tcImprove lie_avail_req `thenTc_`
274 -- COMPUTE VARIABLES OVER WHICH TO QUANTIFY, namely tyvars_to_gen
275 -- The tyvars_not_to_gen are free in the environment, and hence
276 -- candidates for generalisation, but sometimes the monomorphism
277 -- restriction means we can't generalise them nevertheless
279 mono_id_tys = map idType mono_ids
281 getTyVarsToGen is_unrestricted mono_id_tys lie_req `thenNF_Tc` \ (tyvars_not_to_gen, tyvars_to_gen) ->
283 -- Finally, zonk the generalised type variables to real TyVars
284 -- This commits any unbound kind variables to boxed kind
285 -- I'm a little worried that such a kind variable might be
286 -- free in the environment, but I don't think it's possible for
287 -- this to happen when the type variable is not free in the envt
288 -- (which it isn't). SLPJ Nov 98
289 mapTc zonkTcTyVarToTyVar (varSetElems tyvars_to_gen) `thenTc` \ real_tyvars_to_gen_list ->
291 real_tyvars_to_gen = mkVarSet real_tyvars_to_gen_list
292 -- It's important that the final list
293 -- (real_tyvars_to_gen and real_tyvars_to_gen_list) is fully
294 -- zonked, *including boxity*, because they'll be included in the forall types of
295 -- the polymorphic Ids, and instances of these Ids will be generated from them.
297 -- Also NB that tcSimplify takes zonked tyvars as its arg, hence we pass
298 -- real_tyvars_to_gen
302 tcExtendGlobalTyVars tyvars_not_to_gen (
303 let ips = getIPsOfLIE lie_avail_req in
304 if null real_tyvars_to_gen_list && (null ips || not is_unrestricted) then
305 -- No polymorphism, and no IPs, so no need to simplify context
306 returnTc (lie_req, EmptyMonoBinds, [])
308 case maybe_sig_theta of
310 -- No signatures, so just simplify the lie
311 -- NB: no signatures => no polymorphic recursion, so no
312 -- need to use lie_avail (which will be empty anyway)
313 tcSimplify (text "tcBinds1" <+> ppr binder_names)
314 real_tyvars_to_gen lie_req `thenTc` \ (lie_free, dict_binds, lie_bound) ->
315 returnTc (lie_free, dict_binds, map instToId (bagToList lie_bound))
317 Just (sig_theta, lie_avail) ->
318 -- There are signatures, and their context is sig_theta
319 -- Furthermore, lie_avail is an LIE containing the 'method insts'
320 -- for the things bound here
322 zonkTcThetaType sig_theta `thenNF_Tc` \ sig_theta' ->
323 newDicts SignatureOrigin sig_theta' `thenNF_Tc` \ (dicts_sig, dict_ids) ->
324 -- It's important that sig_theta is zonked, because
325 -- dict_id is later used to form the type of the polymorphic thing,
326 -- and forall-types must be zonked so far as their bound variables
330 -- The "givens" is the stuff available. We get that from
331 -- the context of the type signature, BUT ALSO the lie_avail
332 -- so that polymorphic recursion works right (see comments at end of fn)
333 givens = dicts_sig `plusLIE` lie_avail
336 -- Check that the needed dicts can be expressed in
337 -- terms of the signature ones
338 tcAddErrCtxt (bindSigsCtxt tysig_names) $
340 (ptext SLIT("type signature for") <+> pprQuotedList binder_names)
341 real_tyvars_to_gen givens lie_req `thenTc` \ (lie_free, dict_binds) ->
343 returnTc (lie_free, dict_binds, dict_ids)
345 ) `thenTc` \ (lie_free, dict_binds, dicts_bound) ->
347 -- GET THE FINAL MONO_ID_TYS
348 zonkTcTypes mono_id_tys `thenNF_Tc` \ zonked_mono_id_types ->
351 -- CHECK FOR BOGUS UNPOINTED BINDINGS
352 (if any isUnLiftedType zonked_mono_id_types then
353 -- Unlifted bindings must be non-recursive,
354 -- not top level, and non-polymorphic
355 checkTc (isNotTopLevel top_lvl)
356 (unliftedBindErr "Top-level" mbind) `thenTc_`
357 checkTc (case is_rec of {Recursive -> False; NonRecursive -> True})
358 (unliftedBindErr "Recursive" mbind) `thenTc_`
359 checkTc (null real_tyvars_to_gen_list)
360 (unliftedBindErr "Polymorphic" mbind)
365 ASSERT( not (any ((== unboxedTypeKind) . tyVarKind) real_tyvars_to_gen_list) )
366 -- The instCantBeGeneralised stuff in tcSimplify should have
367 -- already raised an error if we're trying to generalise an
368 -- unboxed tyvar (NB: unboxed tyvars are always introduced
369 -- along with a class constraint) and it's better done there
370 -- because we have more precise origin information.
371 -- That's why we just use an ASSERT here.
374 -- BUILD THE POLYMORPHIC RESULT IDs
375 mapNF_Tc zonkId mono_ids `thenNF_Tc` \ zonked_mono_ids ->
377 exports = zipWith mk_export binder_names zonked_mono_ids
378 dict_tys = map idType dicts_bound
380 inlines = mkNameSet [name | InlineSig name _ loc <- inline_sigs]
381 no_inlines = listToFM ([(name, IMustNotBeINLINEd False phase) | NoInlineSig name phase loc <- inline_sigs] ++
382 [(name, IMustNotBeINLINEd True phase) | InlineSig name phase loc <- inline_sigs, maybeToBool phase])
383 -- "INLINE n foo" means inline foo, but not until at least phase n
384 -- "NOINLINE n foo" means don't inline foo until at least phase n, and even
385 -- then only if it is small enough etc.
386 -- "NOINLINE foo" means don't inline foo ever, which we signal with a (IMustNotBeINLINEd Nothing)
387 -- See comments in CoreUnfold.blackListed for the Authorised Version
389 mk_export binder_name zonked_mono_id
391 attachNoInlinePrag no_inlines poly_id,
395 case maybeSig tc_ty_sigs binder_name of
396 Just (TySigInfo _ sig_poly_id sig_tyvars _ _ _ _ _) ->
397 (sig_tyvars, sig_poly_id)
398 Nothing -> (real_tyvars_to_gen_list, new_poly_id)
400 new_poly_id = mkVanillaId binder_name poly_ty
401 poly_ty = mkForAllTys real_tyvars_to_gen_list
403 $ idType (zonked_mono_id)
404 -- It's important to build a fully-zonked poly_ty, because
405 -- we'll slurp out its free type variables when extending the
406 -- local environment (tcExtendLocalValEnv); if it's not zonked
407 -- it appears to have free tyvars that aren't actually free
410 pat_binders :: [Name]
411 pat_binders = collectMonoBinders (justPatBindings mbind EmptyMonoBinds)
413 -- CHECK FOR UNBOXED BINDERS IN PATTERN BINDINGS
414 mapTc (\id -> checkTc (not (idName id `elem` pat_binders
415 && isUnboxedType (idType id)))
416 (unboxedPatBindErr id)) zonked_mono_ids
421 -- pprTrace "binding.." (ppr ((dicts_bound, dict_binds), exports, [idType poly_id | (_, poly_id, _) <- exports])) $
422 AbsBinds real_tyvars_to_gen_list
426 (dict_binds `andMonoBinds` mbind'),
428 [poly_id | (_, poly_id, _) <- exports]
431 tysig_names = [name | (TySigInfo name _ _ _ _ _ _ _) <- tc_ty_sigs]
432 is_unrestricted | opt_NoMonomorphismRestriction = True
433 | otherwise = isUnRestrictedGroup tysig_names mbind
435 justPatBindings bind@(PatMonoBind _ _ _) binds = bind `andMonoBinds` binds
436 justPatBindings (AndMonoBinds b1 b2) binds =
437 justPatBindings b1 (justPatBindings b2 binds)
438 justPatBindings other_bind binds = binds
440 attachNoInlinePrag no_inlines bndr
441 = case lookupFM no_inlines (idName bndr) of
442 Just prag -> bndr `setInlinePragma` prag
446 Polymorphic recursion
447 ~~~~~~~~~~~~~~~~~~~~~
448 The game plan for polymorphic recursion in the code above is
450 * Bind any variable for which we have a type signature
451 to an Id with a polymorphic type. Then when type-checking
452 the RHSs we'll make a full polymorphic call.
454 This fine, but if you aren't a bit careful you end up with a horrendous
455 amount of partial application and (worse) a huge space leak. For example:
457 f :: Eq a => [a] -> [a]
460 If we don't take care, after typechecking we get
462 f = /\a -> \d::Eq a -> let f' = f a d
466 Notice the the stupid construction of (f a d), which is of course
467 identical to the function we're executing. In this case, the
468 polymorphic recursion isn't being used (but that's a very common case).
471 f = /\a -> \d::Eq a -> letrec
472 fm = \ys:[a] -> ...fm...
476 This can lead to a massive space leak, from the following top-level defn
482 Now (f dEqInt) evaluates to a lambda that has f' as a free variable; but
483 f' is another thunk which evaluates to the same thing... and you end
484 up with a chain of identical values all hung onto by the CAF ff.
488 = let f' = f Int dEqInt in \ys. ...f'...
490 = let f' = let f' = f Int dEqInt in \ys. ...f'...
494 Solution: when typechecking the RHSs we always have in hand the
495 *monomorphic* Ids for each binding. So we just need to make sure that
496 if (Method f a d) shows up in the constraints emerging from (...f...)
497 we just use the monomorphic Id. We achieve this by adding monomorphic Ids
498 to the "givens" when simplifying constraints. That's what the "lies_avail"
502 %************************************************************************
504 \subsection{getTyVarsToGen}
506 %************************************************************************
508 @getTyVarsToGen@ decides what type variables to generalise over.
510 For a "restricted group" -- see the monomorphism restriction
511 for a definition -- we bind no dictionaries, and
512 remove from tyvars_to_gen any constrained type variables
514 *Don't* simplify dicts at this point, because we aren't going
515 to generalise over these dicts. By the time we do simplify them
516 we may well know more. For example (this actually came up)
518 f x = array ... xs where xs = [1,2,3,4,5]
519 We don't want to generate lots of (fromInt Int 1), (fromInt Int 2)
520 stuff. If we simplify only at the f-binding (not the xs-binding)
521 we'll know that the literals are all Ints, and we can just produce
524 Find all the type variables involved in overloading, the
525 "constrained_tyvars". These are the ones we *aren't* going to
526 generalise. We must be careful about doing this:
528 (a) If we fail to generalise a tyvar which is not actually
529 constrained, then it will never, ever get bound, and lands
530 up printed out in interface files! Notorious example:
531 instance Eq a => Eq (Foo a b) where ..
532 Here, b is not constrained, even though it looks as if it is.
533 Another, more common, example is when there's a Method inst in
534 the LIE, whose type might very well involve non-overloaded
537 (b) On the other hand, we mustn't generalise tyvars which are constrained,
538 because we are going to pass on out the unmodified LIE, with those
539 tyvars in it. They won't be in scope if we've generalised them.
541 So we are careful, and do a complete simplification just to find the
542 constrained tyvars. We don't use any of the results, except to
543 find which tyvars are constrained.
546 getTyVarsToGen is_unrestricted mono_id_tys lie
547 = tcGetGlobalTyVars `thenNF_Tc` \ free_tyvars ->
548 zonkTcTypes mono_id_tys `thenNF_Tc` \ zonked_mono_id_tys ->
550 body_tyvars = tyVarsOfTypes zonked_mono_id_tys `minusVarSet` free_tyvars
551 fds = getAllFunDepsOfLIE lie
555 -- We need to augment the type variables that appear explicitly in
556 -- the type by those that are determined by the functional dependencies.
557 -- e.g. suppose our type is C a b => a -> a
558 -- with the fun-dep a->b
559 -- Then we should generalise over b too; otherwise it will be
560 -- reported as ambiguous.
561 zonkFunDeps fds `thenNF_Tc` \ fds' ->
563 extended_tyvars = oclose fds' body_tyvars
565 returnNF_Tc (emptyVarSet, extended_tyvars)
567 -- This recover and discard-errs is to avoid duplicate error
568 -- messages; this, after all, is an "extra" call to tcSimplify
569 recoverNF_Tc (returnNF_Tc (emptyVarSet, body_tyvars)) $
572 tcSimplify (text "getTVG") body_tyvars lie `thenTc` \ (_, _, constrained_dicts) ->
574 -- ASSERT: dicts_sig is already zonked!
575 constrained_tyvars = foldrBag (unionVarSet . tyVarsOfInst) emptyVarSet constrained_dicts
576 reduced_tyvars_to_gen = body_tyvars `minusVarSet` constrained_tyvars
578 returnTc (constrained_tyvars, reduced_tyvars_to_gen)
583 isUnRestrictedGroup :: [Name] -- Signatures given for these
587 is_elem v vs = isIn "isUnResMono" v vs
589 isUnRestrictedGroup sigs (PatMonoBind other _ _) = False
590 isUnRestrictedGroup sigs (VarMonoBind v _) = v `is_elem` sigs
591 isUnRestrictedGroup sigs (FunMonoBind v _ matches _) = any isUnRestrictedMatch matches ||
593 isUnRestrictedGroup sigs (AndMonoBinds mb1 mb2) = isUnRestrictedGroup sigs mb1 &&
594 isUnRestrictedGroup sigs mb2
595 isUnRestrictedGroup sigs EmptyMonoBinds = True
597 isUnRestrictedMatch (Match _ [] Nothing _) = False -- No args, no signature
598 isUnRestrictedMatch other = True -- Some args or a signature
602 %************************************************************************
604 \subsection{tcMonoBind}
606 %************************************************************************
608 @tcMonoBinds@ deals with a single @MonoBind@.
609 The signatures have been dealt with already.
612 tcMonoBinds :: RenamedMonoBinds
617 [Name], -- Bound names
618 [TcId]) -- Corresponding monomorphic bound things
620 tcMonoBinds mbinds tc_ty_sigs is_rec
621 = tc_mb_pats mbinds `thenTc` \ (complete_it, lie_req_pat, tvs, ids, lie_avail) ->
623 id_list = bagToList ids
624 (names, mono_ids) = unzip id_list
626 -- This last defn is the key one:
627 -- extend the val envt with bindings for the
628 -- things bound in this group, overriding the monomorphic
629 -- ids with the polymorphic ones from the pattern
630 extra_val_env = case is_rec of
631 Recursive -> map mk_bind id_list
634 -- Don't know how to deal with pattern-bound existentials yet
635 checkTc (isEmptyBag tvs && isEmptyBag lie_avail)
636 (existentialExplode mbinds) `thenTc_`
638 -- *Before* checking the RHSs, but *after* checking *all* the patterns,
639 -- extend the envt with bindings for all the bound ids;
640 -- and *then* override with the polymorphic Ids from the signatures
641 -- That is the whole point of the "complete_it" stuff.
643 -- There's a further wrinkle: we have to delay extending the environment
644 -- until after we've dealt with any pattern-bound signature type variables
645 -- Consider f (x::a) = ...f...
646 -- We're going to check that a isn't unified with anything in the envt,
647 -- so f itself had better not be! So we pass the envt binding f into
648 -- complete_it, which extends the actual envt in TcMatches.tcMatch, after
649 -- dealing with the signature tyvars
651 complete_it extra_val_env `thenTc` \ (mbinds', lie_req_rhss) ->
653 returnTc (mbinds', lie_req_pat `plusLIE` lie_req_rhss, names, mono_ids)
656 -- This function is used when dealing with a LHS binder; we make a monomorphic
657 -- version of the Id. We check for type signatures
658 tc_pat_bndr name pat_ty
659 = case maybeSig tc_ty_sigs name of
661 -> newLocalId (getOccName name) pat_ty (getSrcLoc name)
663 Just (TySigInfo _ _ _ _ _ mono_id _ _)
664 -> tcAddSrcLoc (getSrcLoc name) $
665 unifyTauTy (idType mono_id) pat_ty `thenTc_`
668 mk_bind (name, mono_id) = case maybeSig tc_ty_sigs name of
669 Nothing -> (name, mono_id)
670 Just (TySigInfo name poly_id _ _ _ _ _ _) -> (name, poly_id)
672 tc_mb_pats EmptyMonoBinds
673 = returnTc (\ xve -> returnTc (EmptyMonoBinds, emptyLIE), emptyLIE, emptyBag, emptyBag, emptyLIE)
675 tc_mb_pats (AndMonoBinds mb1 mb2)
676 = tc_mb_pats mb1 `thenTc` \ (complete_it1, lie_req1, tvs1, ids1, lie_avail1) ->
677 tc_mb_pats mb2 `thenTc` \ (complete_it2, lie_req2, tvs2, ids2, lie_avail2) ->
679 complete_it xve = complete_it1 xve `thenTc` \ (mb1', lie1) ->
680 complete_it2 xve `thenTc` \ (mb2', lie2) ->
681 returnTc (AndMonoBinds mb1' mb2', lie1 `plusLIE` lie2)
683 returnTc (complete_it,
684 lie_req1 `plusLIE` lie_req2,
685 tvs1 `unionBags` tvs2,
686 ids1 `unionBags` ids2,
687 lie_avail1 `plusLIE` lie_avail2)
689 tc_mb_pats (FunMonoBind name inf matches locn)
690 = newTyVarTy kind `thenNF_Tc` \ bndr_ty ->
691 tc_pat_bndr name bndr_ty `thenTc` \ bndr_id ->
693 complete_it xve = tcAddSrcLoc locn $
694 tcMatchesFun xve name bndr_ty matches `thenTc` \ (matches', lie) ->
695 returnTc (FunMonoBind bndr_id inf matches' locn, lie)
697 returnTc (complete_it, emptyLIE, emptyBag, unitBag (name, bndr_id), emptyLIE)
699 tc_mb_pats bind@(PatMonoBind pat grhss locn)
701 newTyVarTy kind `thenNF_Tc` \ pat_ty ->
703 -- Now typecheck the pattern
704 -- We don't support binding fresh type variables in the
705 -- pattern of a pattern binding. For example, this is illegal:
707 -- whereas this is ok
708 -- (x::Int, y::Bool) = e
710 -- We don't check explicitly for this problem. Instead, we simply
711 -- type check the pattern with tcPat. If the pattern mentions any
712 -- fresh tyvars we simply get an out-of-scope type variable error
713 tcPat tc_pat_bndr pat pat_ty `thenTc` \ (pat', lie_req, tvs, ids, lie_avail) ->
715 complete_it xve = tcAddSrcLoc locn $
716 tcAddErrCtxt (patMonoBindsCtxt bind) $
717 tcExtendLocalValEnv xve $
718 tcGRHSs grhss pat_ty PatBindRhs `thenTc` \ (grhss', lie) ->
719 returnTc (PatMonoBind pat' grhss' locn, lie)
721 returnTc (complete_it, lie_req, tvs, ids, lie_avail)
723 -- Figure out the appropriate kind for the pattern,
724 -- and generate a suitable type variable
725 kind = case is_rec of
726 Recursive -> boxedTypeKind -- Recursive, so no unboxed types
727 NonRecursive -> openTypeKind -- Non-recursive, so we permit unboxed types
730 %************************************************************************
732 \subsection{Signatures}
734 %************************************************************************
736 @checkSigMatch@ does the next step in checking signature matching.
737 The tau-type part has already been unified. What we do here is to
738 check that this unification has not over-constrained the (polymorphic)
739 type variables of the original signature type.
741 The error message here is somewhat unsatisfactory, but it'll do for
745 checkSigMatch :: TopLevelFlag -> [Name] -> [TcId] -> [TcSigInfo] -> TcM (Maybe (TcThetaType, LIE))
746 checkSigMatch top_lvl binder_names mono_ids sigs
748 = -- First unify the main_id with IO t, for any old t
749 tcSetErrCtxt mainTyCheckCtxt (
750 tcLookupTyCon ioTyConName `thenTc` \ ioTyCon ->
751 newTyVarTy boxedTypeKind `thenNF_Tc` \ t_tv ->
752 unifyTauTy ((mkTyConApp ioTyCon [t_tv]))
753 (idType main_mono_id)
756 -- Now check the signatures
757 -- Must do this after the unification with IO t,
758 -- in case of a silly signature like
759 -- main :: forall a. a
760 -- The unification to IO t will bind the type variable 'a',
761 -- which is just waht check_one_sig looks for
762 mapTc check_one_sig sigs `thenTc_`
763 mapTc check_main_ctxt sigs `thenTc_`
764 returnTc (Just ([], emptyLIE))
767 = mapTc check_one_sig sigs `thenTc_`
768 mapTc check_one_ctxt all_sigs_but_first `thenTc_`
769 returnTc (Just (theta1, sig_lie))
772 = returnTc Nothing -- No constraints from type sigs
775 (TySigInfo _ id1 _ theta1 _ _ _ _ : all_sigs_but_first) = sigs
777 sig1_dict_tys = mk_dict_tys theta1
778 n_sig1_dict_tys = length sig1_dict_tys
779 sig_lie = mkLIE (concat [insts | TySigInfo _ _ _ _ _ _ insts _ <- sigs])
781 maybe_main = find_main top_lvl binder_names mono_ids
782 main_bound_here = maybeToBool maybe_main
783 Just main_mono_id = maybe_main
785 -- CHECK THAT THE SIGNATURE TYVARS AND TAU_TYPES ARE OK
786 -- Doesn't affect substitution
787 check_one_sig (TySigInfo _ id sig_tyvars sig_theta sig_tau _ _ src_loc)
788 = tcAddSrcLoc src_loc $
789 tcAddErrCtxtM (sigCtxt (sig_msg id) sig_tyvars sig_theta sig_tau) $
790 checkSigTyVars sig_tyvars (idFreeTyVars id)
793 -- CHECK THAT ALL THE SIGNATURE CONTEXTS ARE UNIFIABLE
794 -- The type signatures on a mutually-recursive group of definitions
795 -- must all have the same context (or none).
797 -- We unify them because, with polymorphic recursion, their types
798 -- might not otherwise be related. This is a rather subtle issue.
800 check_one_ctxt sig@(TySigInfo _ id _ theta _ _ _ src_loc)
801 = tcAddSrcLoc src_loc $
802 tcAddErrCtxt (sigContextsCtxt id1 id) $
803 checkTc (length this_sig_dict_tys == n_sig1_dict_tys)
804 sigContextsErr `thenTc_`
805 unifyTauTyLists sig1_dict_tys this_sig_dict_tys
807 this_sig_dict_tys = mk_dict_tys theta
809 -- CHECK THAT FOR A GROUP INVOLVING Main.main, all
810 -- the signature contexts are empty (what a bore)
811 check_main_ctxt sig@(TySigInfo _ id _ theta _ _ _ src_loc)
812 = tcAddSrcLoc src_loc $
813 checkTc (null theta) (mainContextsErr id)
815 mk_dict_tys theta = map mkPredTy theta
817 sig_msg id = ptext SLIT("When checking the type signature for") <+> quotes (ppr id)
819 -- Search for Main.main in the binder_names, return corresponding mono_id
820 find_main NotTopLevel binder_names mono_ids = Nothing
821 find_main TopLevel binder_names mono_ids = go binder_names mono_ids
823 go (n:ns) (m:ms) | n `hasKey` mainKey = Just m
824 | otherwise = go ns ms
828 %************************************************************************
830 \subsection{SPECIALIZE pragmas}
832 %************************************************************************
834 @tcSpecSigs@ munches up the specialisation "signatures" that arise through *user*
835 pragmas. It is convenient for them to appear in the @[RenamedSig]@
836 part of a binding because then the same machinery can be used for
837 moving them into place as is done for type signatures.
842 f :: Ord a => [a] -> b -> b
843 {-# SPECIALIZE f :: [Int] -> b -> b #-}
846 For this we generate:
848 f* = /\ b -> let d1 = ...
852 where f* is a SpecPragmaId. The **sole** purpose of SpecPragmaIds is to
853 retain a right-hand-side that the simplifier will otherwise discard as
854 dead code... the simplifier has a flag that tells it not to discard
855 SpecPragmaId bindings.
857 In this case the f* retains a call-instance of the overloaded
858 function, f, (including appropriate dictionaries) so that the
859 specialiser will subsequently discover that there's a call of @f@ at
860 Int, and will create a specialisation for @f@. After that, the
861 binding for @f*@ can be discarded.
863 We used to have a form
864 {-# SPECIALISE f :: <type> = g #-}
865 which promised that g implemented f at <type>, but we do that with
867 {-# SPECIALISE (f::<type) = g #-}
870 tcSpecSigs :: [RenamedSig] -> TcM (TcMonoBinds, LIE)
871 tcSpecSigs (SpecSig name poly_ty src_loc : sigs)
872 = -- SPECIALISE f :: forall b. theta => tau = g
873 tcAddSrcLoc src_loc $
874 tcAddErrCtxt (valSpecSigCtxt name poly_ty) $
876 -- Get and instantiate its alleged specialised type
877 tcHsSigType poly_ty `thenTc` \ sig_ty ->
879 -- Check that f has a more general type, and build a RHS for
880 -- the spec-pragma-id at the same time
881 tcExpr (HsVar name) sig_ty `thenTc` \ (spec_expr, spec_lie) ->
883 -- Squeeze out any Methods (see comments with tcSimplifyToDicts)
884 tcSimplifyToDicts spec_lie `thenTc` \ (spec_lie1, spec_binds) ->
886 -- Just specialise "f" by building a SpecPragmaId binding
887 -- It is the thing that makes sure we don't prematurely
888 -- dead-code-eliminate the binding we are really interested in.
889 newSpecPragmaId name sig_ty `thenNF_Tc` \ spec_id ->
891 -- Do the rest and combine
892 tcSpecSigs sigs `thenTc` \ (binds_rest, lie_rest) ->
893 returnTc (binds_rest `andMonoBinds` VarMonoBind spec_id (mkHsLet spec_binds spec_expr),
894 lie_rest `plusLIE` spec_lie1)
896 tcSpecSigs (other_sig : sigs) = tcSpecSigs sigs
897 tcSpecSigs [] = returnTc (EmptyMonoBinds, emptyLIE)
901 %************************************************************************
903 \subsection[TcBinds-errors]{Error contexts and messages}
905 %************************************************************************
909 patMonoBindsCtxt bind
910 = hang (ptext SLIT("In a pattern binding:")) 4 (ppr bind)
912 -----------------------------------------------
914 = sep [ptext SLIT("In a SPECIALIZE pragma for a value:"),
915 nest 4 (ppr v <+> dcolon <+> ppr ty)]
917 -----------------------------------------------
919 = ptext SLIT("variable in a lazy pattern binding has unboxed type: ")
922 -----------------------------------------------
924 = ptext SLIT("When checking the type signature(s) for") <+> pprQuotedList ids
926 -----------------------------------------------
928 = ptext SLIT("Mismatched contexts")
930 sigContextsCtxt s1 s2
931 = hang (hsep [ptext SLIT("When matching the contexts of the signatures for"),
932 quotes (ppr s1), ptext SLIT("and"), quotes (ppr s2)])
933 4 (ptext SLIT("(the signature contexts in a mutually recursive group should all be identical)"))
936 | id `hasKey` mainKey = ptext SLIT("Main.main cannot be overloaded")
938 = quotes (ppr id) <+> ptext SLIT("cannot be overloaded") <> char ',' <> -- sigh; workaround for cpp's inability to deal
939 ptext SLIT("because it is mutually recursive with Main.main") -- with commas inside SLIT strings.
942 = hsep [ptext SLIT("When checking that"), quotes (ptext SLIT("main")),
943 ptext SLIT("has the required type")]
945 -----------------------------------------------
946 unliftedBindErr flavour mbind
947 = hang (text flavour <+> ptext SLIT("bindings for unlifted types aren't allowed"))
950 existentialExplode mbinds
951 = hang (vcat [text "My brain just exploded.",
952 text "I can't handle pattern bindings for existentially-quantified constructors.",
953 text "In the binding group"])