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, lieToList, InstOrigin(..),
24 newDicts, tyVarsOfInsts, instToId
26 import TcEnv ( tcExtendLocalValEnv,
27 newSpecPragmaId, newLocalId,
30 import TcSimplify ( tcSimplifyInfer, tcSimplifyInferCheck, tcSimplifyToDicts )
31 import TcMonoType ( tcHsSigType, checkSigTyVars,
32 TcSigInfo(..), tcTySig, maybeSig, sigCtxt
34 import TcPat ( tcPat )
35 import TcSimplify ( bindInstsOfLocalFuns )
36 import TcType ( newTyVarTy, newTyVar, zonkTcTyVarsAndFV,
39 import TcUnify ( unifyTauTy, unifyTauTyLists )
41 import CoreFVs ( idFreeTyVars )
42 import Id ( mkVanillaId, setInlinePragma )
43 import Var ( idType, idName )
44 import IdInfo ( InlinePragInfo(..) )
45 import Name ( Name, getOccName, getSrcLoc )
47 import Type ( mkTyVarTy,
48 mkForAllTys, mkFunTys, tyVarsOfType,
49 mkPredTy, mkForAllTy, isUnLiftedType,
50 unliftedTypeKind, liftedTypeKind, openTypeKind
52 import Var ( tyVarKind )
56 import Maybes ( maybeToBool )
57 import BasicTypes ( TopLevelFlag(..), RecFlag(..), isNonRec, isNotTopLevel )
58 import FiniteMap ( listToFM, lookupFM )
63 %************************************************************************
65 \subsection{Type-checking bindings}
67 %************************************************************************
69 @tcBindsAndThen@ typechecks a @HsBinds@. The "and then" part is because
70 it needs to know something about the {\em usage} of the things bound,
71 so that it can create specialisations of them. So @tcBindsAndThen@
72 takes a function which, given an extended environment, E, typechecks
73 the scope of the bindings returning a typechecked thing and (most
74 important) an LIE. It is this LIE which is then used as the basis for
75 specialising the things bound.
77 @tcBindsAndThen@ also takes a "combiner" which glues together the
78 bindings and the "thing" to make a new "thing".
80 The real work is done by @tcBindWithSigsAndThen@.
82 Recursive and non-recursive binds are handled in essentially the same
83 way: because of uniques there are no scoping issues left. The only
84 difference is that non-recursive bindings can bind primitive values.
86 Even for non-recursive binding groups we add typings for each binder
87 to the LVE for the following reason. When each individual binding is
88 checked the type of its LHS is unified with that of its RHS; and
89 type-checking the LHS of course requires that the binder is in scope.
91 At the top-level the LIE is sure to contain nothing but constant
92 dictionaries, which we resolve at the module level.
95 tcTopBinds :: RenamedHsBinds -> TcM ((TcMonoBinds, TcEnv), LIE)
97 = tc_binds_and_then TopLevel glue binds $
98 tcGetEnv `thenNF_Tc` \ env ->
99 returnTc ((EmptyMonoBinds, env), emptyLIE)
101 glue is_rec binds1 (binds2, thing) = (binds1 `AndMonoBinds` binds2, thing)
105 :: (RecFlag -> TcMonoBinds -> thing -> thing) -- Combinator
110 tcBindsAndThen = tc_binds_and_then NotTopLevel
112 tc_binds_and_then top_lvl combiner EmptyBinds do_next
114 tc_binds_and_then top_lvl combiner (MonoBind EmptyMonoBinds sigs is_rec) do_next
117 tc_binds_and_then top_lvl combiner (ThenBinds b1 b2) do_next
118 = tc_binds_and_then top_lvl combiner b1 $
119 tc_binds_and_then top_lvl combiner b2 $
122 tc_binds_and_then top_lvl combiner (MonoBind bind sigs is_rec) do_next
123 = -- TYPECHECK THE SIGNATURES
124 mapTc tcTySig [sig | sig@(Sig name _ _) <- sigs] `thenTc` \ tc_ty_sigs ->
126 tcBindWithSigs top_lvl bind tc_ty_sigs
127 sigs is_rec `thenTc` \ (poly_binds, poly_lie, poly_ids) ->
129 -- Extend the environment to bind the new polymorphic Ids
130 tcExtendLocalValEnv [(idName poly_id, poly_id) | poly_id <- poly_ids] $
132 -- Build bindings and IdInfos corresponding to user pragmas
133 tcSpecSigs sigs `thenTc` \ (prag_binds, prag_lie) ->
135 -- Now do whatever happens next, in the augmented envt
136 do_next `thenTc` \ (thing, thing_lie) ->
138 -- Create specialisations of functions bound here
139 -- We want to keep non-recursive things non-recursive
140 -- so that we desugar unlifted bindings correctly
141 case (top_lvl, is_rec) of
143 -- For the top level don't bother will all this bindInstsOfLocalFuns stuff
144 -- All the top level things are rec'd together anyway, so it's fine to
145 -- leave them to the tcSimplifyTop, and quite a bit faster too
147 -> returnTc (combiner Recursive (poly_binds `andMonoBinds` prag_binds) thing,
148 thing_lie `plusLIE` prag_lie `plusLIE` poly_lie)
150 (NotTopLevel, NonRecursive)
151 -> bindInstsOfLocalFuns
152 (thing_lie `plusLIE` prag_lie)
153 poly_ids `thenTc` \ (thing_lie', lie_binds) ->
156 combiner NonRecursive poly_binds $
157 combiner NonRecursive prag_binds $
158 combiner Recursive lie_binds $
159 -- NB: the binds returned by tcSimplify and bindInstsOfLocalFuns
160 -- aren't guaranteed in dependency order (though we could change
161 -- that); hence the Recursive marker.
164 thing_lie' `plusLIE` poly_lie
167 (NotTopLevel, Recursive)
168 -> bindInstsOfLocalFuns
169 (thing_lie `plusLIE` poly_lie `plusLIE` prag_lie)
170 poly_ids `thenTc` \ (final_lie, lie_binds) ->
174 poly_binds `andMonoBinds`
175 lie_binds `andMonoBinds`
182 %************************************************************************
184 \subsection{tcBindWithSigs}
186 %************************************************************************
188 @tcBindWithSigs@ deals with a single binding group. It does generalisation,
189 so all the clever stuff is in here.
191 * binder_names and mbind must define the same set of Names
193 * The Names in tc_ty_sigs must be a subset of binder_names
195 * The Ids in tc_ty_sigs don't necessarily have to have the same name
196 as the Name in the tc_ty_sig
203 -> [RenamedSig] -- Used solely to get INLINE, NOINLINE sigs
205 -> TcM (TcMonoBinds, LIE, [TcId])
207 tcBindWithSigs top_lvl mbind tc_ty_sigs inline_sigs is_rec
209 -- If typechecking the binds fails, then return with each
210 -- signature-less binder given type (forall a.a), to minimise subsequent
212 newTyVar liftedTypeKind `thenNF_Tc` \ alpha_tv ->
214 forall_a_a = mkForAllTy alpha_tv (mkTyVarTy alpha_tv)
215 binder_names = collectMonoBinders mbind
216 poly_ids = map mk_dummy binder_names
217 mk_dummy name = case maybeSig tc_ty_sigs name of
218 Just (TySigInfo _ poly_id _ _ _ _ _ _) -> poly_id -- Signature
219 Nothing -> mkVanillaId name forall_a_a -- No signature
221 returnTc (EmptyMonoBinds, emptyLIE, poly_ids)
224 -- TYPECHECK THE BINDINGS
225 tcMonoBinds mbind tc_ty_sigs is_rec `thenTc` \ (mbind', lie_req, binder_names, mono_ids) ->
227 tau_tvs = varSetElems (foldr (unionVarSet . tyVarsOfType . idType) emptyVarSet mono_ids)
231 generalise binder_names mbind tau_tvs lie_req tc_ty_sigs
232 `thenTc` \ (tc_tyvars_to_gen, lie_free, dict_binds, dict_ids) ->
235 -- ZONK THE GENERALISED TYPE VARIABLES TO REAL TyVars
236 -- This commits any unbound kind variables to boxed kind, by unification
237 -- It's important that the final quanfified type variables
238 -- are fully zonked, *including boxity*, because they'll be
239 -- included in the forall types of the polymorphic Ids.
240 -- At calls of these Ids we'll instantiate fresh type variables from
241 -- them, and we use their boxity then.
242 mapNF_Tc zonkTcTyVarToTyVar tc_tyvars_to_gen `thenNF_Tc` \ real_tyvars_to_gen ->
245 -- It's important that the dict Ids are zonked, including the boxity set
246 -- in the previous step, because they are later used to form the type of
247 -- the polymorphic thing, and forall-types must be zonked so far as
248 -- their bound variables are concerned
249 mapNF_Tc zonkId dict_ids `thenNF_Tc` \ zonked_dict_ids ->
250 mapNF_Tc zonkId mono_ids `thenNF_Tc` \ zonked_mono_ids ->
252 -- CHECK FOR BOGUS UNLIFTED BINDINGS
253 checkUnliftedBinds top_lvl is_rec real_tyvars_to_gen mbind zonked_mono_ids `thenTc_`
255 -- BUILD THE POLYMORPHIC RESULT IDs
257 exports = zipWith mk_export binder_names zonked_mono_ids
258 dict_tys = map idType zonked_dict_ids
260 inlines = mkNameSet [name | InlineSig name _ loc <- inline_sigs]
261 no_inlines = listToFM ([(name, IMustNotBeINLINEd False phase) | NoInlineSig name phase loc <- inline_sigs] ++
262 [(name, IMustNotBeINLINEd True phase) | InlineSig name phase loc <- inline_sigs, maybeToBool phase])
263 -- "INLINE n foo" means inline foo, but not until at least phase n
264 -- "NOINLINE n foo" means don't inline foo until at least phase n, and even
265 -- then only if it is small enough etc.
266 -- "NOINLINE foo" means don't inline foo ever, which we signal with a (IMustNotBeINLINEd Nothing)
267 -- See comments in CoreUnfold.blackListed for the Authorised Version
269 mk_export binder_name zonked_mono_id
271 attachNoInlinePrag no_inlines poly_id,
275 case maybeSig tc_ty_sigs binder_name of
276 Just (TySigInfo _ sig_poly_id sig_tyvars _ _ _ _ _) ->
277 (sig_tyvars, sig_poly_id)
278 Nothing -> (real_tyvars_to_gen, new_poly_id)
280 new_poly_id = mkVanillaId binder_name poly_ty
281 poly_ty = mkForAllTys real_tyvars_to_gen
283 $ idType zonked_mono_id
284 -- It's important to build a fully-zonked poly_ty, because
285 -- we'll slurp out its free type variables when extending the
286 -- local environment (tcExtendLocalValEnv); if it's not zonked
287 -- it appears to have free tyvars that aren't actually free
293 -- pprTrace "binding.." (ppr ((zonked_dict_ids, dict_binds),
294 -- exports, [idType poly_id | (_, poly_id, _) <- exports])) $
295 AbsBinds real_tyvars_to_gen
299 (dict_binds `andMonoBinds` mbind'),
301 [poly_id | (_, poly_id, _) <- exports]
304 attachNoInlinePrag no_inlines bndr
305 = case lookupFM no_inlines (idName bndr) of
306 Just prag -> bndr `setInlinePragma` prag
309 checkUnliftedBinds top_lvl is_rec real_tyvars_to_gen mbind zonked_mono_ids
310 = ASSERT( not (any ((== unliftedTypeKind) . tyVarKind) real_tyvars_to_gen) )
311 -- The instCantBeGeneralised stuff in tcSimplify should have
312 -- already raised an error if we're trying to generalise an
313 -- unboxed tyvar (NB: unboxed tyvars are always introduced
314 -- along with a class constraint) and it's better done there
315 -- because we have more precise origin information.
316 -- That's why we just use an ASSERT here.
318 -- Check that pattern-bound variables are not unlifted
319 (if or [ (idName id `elem` pat_binders) && isUnLiftedType (idType id)
320 | id <- zonked_mono_ids ] then
321 addErrTc (unliftedBindErr "Pattern" mbind)
326 -- Unlifted bindings must be non-recursive,
327 -- not top level, non-polymorphic, and not pattern bound
328 if any (isUnLiftedType . idType) zonked_mono_ids then
329 checkTc (isNotTopLevel top_lvl)
330 (unliftedBindErr "Top-level" mbind) `thenTc_`
331 checkTc (isNonRec is_rec)
332 (unliftedBindErr "Recursive" mbind) `thenTc_`
333 checkTc (null real_tyvars_to_gen)
334 (unliftedBindErr "Polymorphic" mbind)
339 pat_binders :: [Name]
340 pat_binders = collectMonoBinders (justPatBindings mbind EmptyMonoBinds)
342 justPatBindings bind@(PatMonoBind _ _ _) binds = bind `andMonoBinds` binds
343 justPatBindings (AndMonoBinds b1 b2) binds =
344 justPatBindings b1 (justPatBindings b2 binds)
345 justPatBindings other_bind binds = binds
349 Polymorphic recursion
350 ~~~~~~~~~~~~~~~~~~~~~
351 The game plan for polymorphic recursion in the code above is
353 * Bind any variable for which we have a type signature
354 to an Id with a polymorphic type. Then when type-checking
355 the RHSs we'll make a full polymorphic call.
357 This fine, but if you aren't a bit careful you end up with a horrendous
358 amount of partial application and (worse) a huge space leak. For example:
360 f :: Eq a => [a] -> [a]
363 If we don't take care, after typechecking we get
365 f = /\a -> \d::Eq a -> let f' = f a d
369 Notice the the stupid construction of (f a d), which is of course
370 identical to the function we're executing. In this case, the
371 polymorphic recursion isn't being used (but that's a very common case).
374 f = /\a -> \d::Eq a -> letrec
375 fm = \ys:[a] -> ...fm...
379 This can lead to a massive space leak, from the following top-level defn
385 Now (f dEqInt) evaluates to a lambda that has f' as a free variable; but
386 f' is another thunk which evaluates to the same thing... and you end
387 up with a chain of identical values all hung onto by the CAF ff.
391 = let f' = f Int dEqInt in \ys. ...f'...
393 = let f' = let f' = f Int dEqInt in \ys. ...f'...
397 Solution: when typechecking the RHSs we always have in hand the
398 *monomorphic* Ids for each binding. So we just need to make sure that
399 if (Method f a d) shows up in the constraints emerging from (...f...)
400 we just use the monomorphic Id. We achieve this by adding monomorphic Ids
401 to the "givens" when simplifying constraints. That's what the "lies_avail"
405 %************************************************************************
407 \subsection{getTyVarsToGen}
409 %************************************************************************
412 generalise binder_names mbind tau_tvs lie_req sigs
414 -----------------------
415 | is_unrestricted && null sigs
416 = -- INFERENCE CASE: Unrestricted group, no type signatures
417 tcSimplifyInfer (ptext SLIT("bindings for") <+> pprBinders binder_names)
420 -----------------------
422 = -- CHECKING CASE: Unrestricted group, there are type signatures
423 -- Check signature contexts are empty
424 checkSigsCtxts sigs `thenTc` \ (sig_avails, sig_dicts) ->
426 -- Check that the needed dicts can be
427 -- expressed in terms of the signature ones
428 tcSimplifyInferCheck check_doc tau_tvs sig_avails lie_req `thenTc` \ (forall_tvs, lie_free, dict_binds) ->
430 -- Check that signature type variables are OK
431 checkSigsTyVars sigs `thenTc_`
433 returnTc (forall_tvs, lie_free, dict_binds, sig_dicts)
435 -----------------------
436 | otherwise -- RESTRICTED CASE: Restricted group
437 = -- Check signature contexts are empty
441 checkSigsCtxts sigs `thenTc` \ (_, sig_dicts) ->
442 checkTc (null sig_dicts)
443 (restrictedBindCtxtErr binder_names)
446 -- Identify constrained tyvars
447 tcGetGlobalTyVars `thenNF_Tc` \ gbl_tvs ->
448 zonkTcTyVarsAndFV tau_tvs `thenNF_Tc` \ tau_tvs' ->
449 zonkTcTyVarsAndFV lie_tvs `thenNF_Tc` \ lie_tvs' ->
451 forall_tvs = tau_tvs' `minusVarSet` (lie_tvs' `unionVarSet` gbl_tvs)
452 -- Don't bother to oclose the gbl_tvs; this is a rare case
454 returnTc (varSetElems forall_tvs, lie_req, EmptyMonoBinds, [])
457 tysig_names = [name | (TySigInfo name _ _ _ _ _ _ _) <- sigs]
458 is_unrestricted | opt_NoMonomorphismRestriction = True
459 | otherwise = isUnRestrictedGroup tysig_names mbind
460 lie_tvs = varSetElems (tyVarsOfInsts (lieToList lie_req))
461 check_doc = case tysig_names of
462 [n] -> ptext SLIT("type signature for") <+> quotes (ppr n)
463 other -> ptext SLIT("type signature(s) for") <+> pprBinders tysig_names
466 -- CHECK THAT ALL THE SIGNATURE CONTEXTS ARE UNIFIABLE
467 -- The type signatures on a mutually-recursive group of definitions
468 -- must all have the same context (or none).
470 -- We unify them because, with polymorphic recursion, their types
471 -- might not otherwise be related. This is a rather subtle issue.
474 -- We return a representative
475 checkSigsCtxts sigs@(TySigInfo _ id1 sig_tvs theta1 _ _ _ _ : other_sigs)
476 = mapTc_ check_one other_sigs `thenTc_`
478 returnTc ([], []) -- Non-overloaded type signatures
480 newDicts SignatureOrigin theta1 `thenNF_Tc` \ sig_dicts ->
482 -- The "sig_avails" is the stuff available. We get that from
483 -- the context of the type signature, BUT ALSO the lie_avail
484 -- so that polymorphic recursion works right (see comments at end of fn)
485 sig_avails = sig_dicts ++ sig_meths
487 returnTc (sig_avails, map instToId sig_dicts)
489 sig1_dict_tys = map mkPredTy theta1
490 n_sig1_theta = length theta1
491 sig_meths = concat [insts | TySigInfo _ _ _ _ _ _ insts _ <- sigs]
493 check_one sig@(TySigInfo _ id _ theta _ _ _ src_loc)
494 = tcAddSrcLoc src_loc $
495 tcAddErrCtxt (sigContextsCtxt id1 id) $
496 checkTc (length theta == n_sig1_theta) sigContextsErr `thenTc_`
497 unifyTauTyLists sig1_dict_tys (map mkPredTy theta)
499 checkSigsTyVars sigs = mapTc_ check_one sigs
501 check_one (TySigInfo _ id sig_tyvars sig_theta sig_tau _ _ src_loc)
502 = tcAddSrcLoc src_loc $
503 tcAddErrCtxtM (sigCtxt (sig_msg id) sig_tyvars sig_theta sig_tau) $
504 checkSigTyVars sig_tyvars (idFreeTyVars id)
506 sig_msg id = ptext SLIT("When checking the type signature for") <+> quotes (ppr id)
509 @getTyVarsToGen@ decides what type variables to generalise over.
511 For a "restricted group" -- see the monomorphism restriction
512 for a definition -- we bind no dictionaries, and
513 remove from tyvars_to_gen any constrained type variables
515 *Don't* simplify dicts at this point, because we aren't going
516 to generalise over these dicts. By the time we do simplify them
517 we may well know more. For example (this actually came up)
519 f x = array ... xs where xs = [1,2,3,4,5]
520 We don't want to generate lots of (fromInt Int 1), (fromInt Int 2)
521 stuff. If we simplify only at the f-binding (not the xs-binding)
522 we'll know that the literals are all Ints, and we can just produce
525 Find all the type variables involved in overloading, the
526 "constrained_tyvars". These are the ones we *aren't* going to
527 generalise. We must be careful about doing this:
529 (a) If we fail to generalise a tyvar which is not actually
530 constrained, then it will never, ever get bound, and lands
531 up printed out in interface files! Notorious example:
532 instance Eq a => Eq (Foo a b) where ..
533 Here, b is not constrained, even though it looks as if it is.
534 Another, more common, example is when there's a Method inst in
535 the LIE, whose type might very well involve non-overloaded
537 [NOTE: Jan 2001: I don't understand the problem here so I'm doing
538 the simple thing instead]
540 (b) On the other hand, we mustn't generalise tyvars which are constrained,
541 because we are going to pass on out the unmodified LIE, with those
542 tyvars in it. They won't be in scope if we've generalised them.
544 So we are careful, and do a complete simplification just to find the
545 constrained tyvars. We don't use any of the results, except to
546 find which tyvars are constrained.
549 isUnRestrictedGroup :: [Name] -- Signatures given for these
553 is_elem v vs = isIn "isUnResMono" v vs
555 isUnRestrictedGroup sigs (PatMonoBind other _ _) = False
556 isUnRestrictedGroup sigs (VarMonoBind v _) = v `is_elem` sigs
557 isUnRestrictedGroup sigs (FunMonoBind v _ matches _) = any isUnRestrictedMatch matches ||
559 isUnRestrictedGroup sigs (AndMonoBinds mb1 mb2) = isUnRestrictedGroup sigs mb1 &&
560 isUnRestrictedGroup sigs mb2
561 isUnRestrictedGroup sigs EmptyMonoBinds = True
563 isUnRestrictedMatch (Match _ [] Nothing _) = False -- No args, no signature
564 isUnRestrictedMatch other = True -- Some args or a signature
568 %************************************************************************
570 \subsection{tcMonoBind}
572 %************************************************************************
574 @tcMonoBinds@ deals with a single @MonoBind@.
575 The signatures have been dealt with already.
578 tcMonoBinds :: RenamedMonoBinds
583 [Name], -- Bound names
584 [TcId]) -- Corresponding monomorphic bound things
586 tcMonoBinds mbinds tc_ty_sigs is_rec
587 = tc_mb_pats mbinds `thenTc` \ (complete_it, lie_req_pat, tvs, ids, lie_avail) ->
589 id_list = bagToList ids
590 (names, mono_ids) = unzip id_list
592 -- This last defn is the key one:
593 -- extend the val envt with bindings for the
594 -- things bound in this group, overriding the monomorphic
595 -- ids with the polymorphic ones from the pattern
596 extra_val_env = case is_rec of
597 Recursive -> map mk_bind id_list
600 -- Don't know how to deal with pattern-bound existentials yet
601 checkTc (isEmptyBag tvs && isEmptyBag lie_avail)
602 (existentialExplode mbinds) `thenTc_`
604 -- *Before* checking the RHSs, but *after* checking *all* the patterns,
605 -- extend the envt with bindings for all the bound ids;
606 -- and *then* override with the polymorphic Ids from the signatures
607 -- That is the whole point of the "complete_it" stuff.
609 -- There's a further wrinkle: we have to delay extending the environment
610 -- until after we've dealt with any pattern-bound signature type variables
611 -- Consider f (x::a) = ...f...
612 -- We're going to check that a isn't unified with anything in the envt,
613 -- so f itself had better not be! So we pass the envt binding f into
614 -- complete_it, which extends the actual envt in TcMatches.tcMatch, after
615 -- dealing with the signature tyvars
617 complete_it extra_val_env `thenTc` \ (mbinds', lie_req_rhss) ->
619 returnTc (mbinds', lie_req_pat `plusLIE` lie_req_rhss, names, mono_ids)
622 -- This function is used when dealing with a LHS binder;
623 -- we make a monomorphic version of the Id.
624 -- We check for a type signature; if there is one, we use the mono_id
625 -- from the signature. This is how we make sure the tau part of the
626 -- signature actually maatches the type of the LHS; then tc_mb_pats
627 -- ensures the LHS and RHS have the same type
629 tc_pat_bndr name pat_ty
630 = case maybeSig tc_ty_sigs name of
632 -> newLocalId (getOccName name) pat_ty (getSrcLoc name)
634 Just (TySigInfo _ _ _ _ _ mono_id _ _)
635 -> tcAddSrcLoc (getSrcLoc name) $
636 unifyTauTy (idType mono_id) pat_ty `thenTc_`
639 mk_bind (name, mono_id) = case maybeSig tc_ty_sigs name of
640 Nothing -> (name, mono_id)
641 Just (TySigInfo name poly_id _ _ _ _ _ _) -> (name, poly_id)
643 tc_mb_pats EmptyMonoBinds
644 = returnTc (\ xve -> returnTc (EmptyMonoBinds, emptyLIE), emptyLIE, emptyBag, emptyBag, emptyLIE)
646 tc_mb_pats (AndMonoBinds mb1 mb2)
647 = tc_mb_pats mb1 `thenTc` \ (complete_it1, lie_req1, tvs1, ids1, lie_avail1) ->
648 tc_mb_pats mb2 `thenTc` \ (complete_it2, lie_req2, tvs2, ids2, lie_avail2) ->
650 complete_it xve = complete_it1 xve `thenTc` \ (mb1', lie1) ->
651 complete_it2 xve `thenTc` \ (mb2', lie2) ->
652 returnTc (AndMonoBinds mb1' mb2', lie1 `plusLIE` lie2)
654 returnTc (complete_it,
655 lie_req1 `plusLIE` lie_req2,
656 tvs1 `unionBags` tvs2,
657 ids1 `unionBags` ids2,
658 lie_avail1 `plusLIE` lie_avail2)
660 tc_mb_pats (FunMonoBind name inf matches locn)
661 = newTyVarTy kind `thenNF_Tc` \ bndr_ty ->
662 tc_pat_bndr name bndr_ty `thenTc` \ bndr_id ->
664 complete_it xve = tcAddSrcLoc locn $
665 tcMatchesFun xve name bndr_ty matches `thenTc` \ (matches', lie) ->
666 returnTc (FunMonoBind bndr_id inf matches' locn, lie)
668 returnTc (complete_it, emptyLIE, emptyBag, unitBag (name, bndr_id), emptyLIE)
670 tc_mb_pats bind@(PatMonoBind pat grhss locn)
672 newTyVarTy kind `thenNF_Tc` \ pat_ty ->
674 -- Now typecheck the pattern
675 -- We don't support binding fresh type variables in the
676 -- pattern of a pattern binding. For example, this is illegal:
678 -- whereas this is ok
679 -- (x::Int, y::Bool) = e
681 -- We don't check explicitly for this problem. Instead, we simply
682 -- type check the pattern with tcPat. If the pattern mentions any
683 -- fresh tyvars we simply get an out-of-scope type variable error
684 tcPat tc_pat_bndr pat pat_ty `thenTc` \ (pat', lie_req, tvs, ids, lie_avail) ->
686 complete_it xve = tcAddSrcLoc locn $
687 tcAddErrCtxt (patMonoBindsCtxt bind) $
688 tcExtendLocalValEnv xve $
689 tcGRHSs grhss pat_ty PatBindRhs `thenTc` \ (grhss', lie) ->
690 returnTc (PatMonoBind pat' grhss' locn, lie)
692 returnTc (complete_it, lie_req, tvs, ids, lie_avail)
694 -- Figure out the appropriate kind for the pattern,
695 -- and generate a suitable type variable
696 kind = case is_rec of
697 Recursive -> liftedTypeKind -- Recursive, so no unlifted types
698 NonRecursive -> openTypeKind -- Non-recursive, so we permit unlifted types
702 %************************************************************************
704 \subsection{SPECIALIZE pragmas}
706 %************************************************************************
708 @tcSpecSigs@ munches up the specialisation "signatures" that arise through *user*
709 pragmas. It is convenient for them to appear in the @[RenamedSig]@
710 part of a binding because then the same machinery can be used for
711 moving them into place as is done for type signatures.
716 f :: Ord a => [a] -> b -> b
717 {-# SPECIALIZE f :: [Int] -> b -> b #-}
720 For this we generate:
722 f* = /\ b -> let d1 = ...
726 where f* is a SpecPragmaId. The **sole** purpose of SpecPragmaIds is to
727 retain a right-hand-side that the simplifier will otherwise discard as
728 dead code... the simplifier has a flag that tells it not to discard
729 SpecPragmaId bindings.
731 In this case the f* retains a call-instance of the overloaded
732 function, f, (including appropriate dictionaries) so that the
733 specialiser will subsequently discover that there's a call of @f@ at
734 Int, and will create a specialisation for @f@. After that, the
735 binding for @f*@ can be discarded.
737 We used to have a form
738 {-# SPECIALISE f :: <type> = g #-}
739 which promised that g implemented f at <type>, but we do that with
741 {-# SPECIALISE (f::<type) = g #-}
744 tcSpecSigs :: [RenamedSig] -> TcM (TcMonoBinds, LIE)
745 tcSpecSigs (SpecSig name poly_ty src_loc : sigs)
746 = -- SPECIALISE f :: forall b. theta => tau = g
747 tcAddSrcLoc src_loc $
748 tcAddErrCtxt (valSpecSigCtxt name poly_ty) $
750 -- Get and instantiate its alleged specialised type
751 tcHsSigType poly_ty `thenTc` \ sig_ty ->
753 -- Check that f has a more general type, and build a RHS for
754 -- the spec-pragma-id at the same time
755 tcExpr (HsVar name) sig_ty `thenTc` \ (spec_expr, spec_lie) ->
757 -- Squeeze out any Methods (see comments with tcSimplifyToDicts)
758 tcSimplifyToDicts spec_lie `thenTc` \ (spec_dicts, spec_binds) ->
760 -- Just specialise "f" by building a SpecPragmaId binding
761 -- It is the thing that makes sure we don't prematurely
762 -- dead-code-eliminate the binding we are really interested in.
763 newSpecPragmaId name sig_ty `thenNF_Tc` \ spec_id ->
765 -- Do the rest and combine
766 tcSpecSigs sigs `thenTc` \ (binds_rest, lie_rest) ->
767 returnTc (binds_rest `andMonoBinds` VarMonoBind spec_id (mkHsLet spec_binds spec_expr),
768 lie_rest `plusLIE` mkLIE spec_dicts)
770 tcSpecSigs (other_sig : sigs) = tcSpecSigs sigs
771 tcSpecSigs [] = returnTc (EmptyMonoBinds, emptyLIE)
775 %************************************************************************
777 \subsection[TcBinds-errors]{Error contexts and messages}
779 %************************************************************************
783 patMonoBindsCtxt bind
784 = hang (ptext SLIT("In a pattern binding:")) 4 (ppr bind)
786 -----------------------------------------------
788 = sep [ptext SLIT("In a SPECIALIZE pragma for a value:"),
789 nest 4 (ppr v <+> dcolon <+> ppr ty)]
791 -----------------------------------------------
792 sigContextsErr = ptext SLIT("Mismatched contexts")
794 sigContextsCtxt s1 s2
795 = hang (hsep [ptext SLIT("When matching the contexts of the signatures for"),
796 quotes (ppr s1), ptext SLIT("and"), quotes (ppr s2)])
797 4 (ptext SLIT("(the signature contexts in a mutually recursive group should all be identical)"))
799 -----------------------------------------------
800 unliftedBindErr flavour mbind
801 = hang (text flavour <+> ptext SLIT("bindings for unlifted types aren't allowed:"))
804 -----------------------------------------------
805 existentialExplode mbinds
806 = hang (vcat [text "My brain just exploded.",
807 text "I can't handle pattern bindings for existentially-quantified constructors.",
808 text "In the binding group"])
811 -----------------------------------------------
812 restrictedBindCtxtErr binder_names
813 = hang (ptext SLIT("Illegal overloaded type signature(s)"))
814 4 (vcat [ptext SLIT("in a binding group for") <+> pprBinders binder_names,
815 ptext SLIT("that falls under the monomorphism restriction")])
817 -- Used in error messages
818 pprBinders bndrs = braces (pprWithCommas ppr bndrs)