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(..),
26 import TcEnv ( tcExtendLocalValEnv,
27 newSpecPragmaId, newLocalId
29 import TcSimplify ( tcSimplifyInfer, tcSimplifyInferCheck, tcSimplifyCheck, tcSimplifyToDicts )
30 import TcMonoType ( tcHsSigType, checkSigTyVars,
31 TcSigInfo(..), tcTySig, maybeSig, sigCtxt
33 import TcPat ( tcPat )
34 import TcSimplify ( bindInstsOfLocalFuns )
35 import TcType ( newTyVarTy, newTyVar,
38 import TcUnify ( unifyTauTy, unifyTauTyLists )
40 import CoreFVs ( idFreeTyVars )
41 import Id ( mkVanillaId, setInlinePragma )
42 import Var ( idType, idName )
43 import IdInfo ( InlinePragInfo(..) )
44 import Name ( Name, getOccName, getSrcLoc )
46 import Type ( mkTyVarTy, tyVarsOfTypes,
47 mkForAllTys, mkFunTys, tyVarsOfType,
48 mkPredTy, mkForAllTy, isUnLiftedType,
49 unliftedTypeKind, liftedTypeKind, openTypeKind
51 import Var ( tyVarKind )
55 import ListSetOps ( minusList )
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_help doc tau_tvs lie_req sigs
414 -----------------------
416 = -- INFERENCE CASE: Unrestricted group, no type signatures
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 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 generalise binder_names mbind tau_tvs lie_req sigs
436 | is_unrestricted -- UNRESTRICTED CASE
437 = generalise_help doc tau_tvs lie_req sigs
439 | otherwise -- RESTRICTED CASE
440 = -- Do a simplification to decide what type variables
441 -- are constrained. We can't just take the free vars
442 -- of lie_req because that'll have methods that may
443 -- incidentally mention entirely unconstrained variables
444 -- e.g. a call to f :: Eq a => a -> b -> b
445 -- Here, b is unconstrained. A good example would be
447 -- We want to infer the polymorphic type
448 -- foo :: forall b. b -> b
449 generalise_help doc tau_tvs lie_req sigs `thenTc` \ (forall_tvs, lie_free, dict_binds, dict_ids) ->
451 -- Check signature contexts are empty
452 checkTc (null sigs || null dict_ids)
453 (restrictedBindCtxtErr binder_names) `thenTc_`
455 -- Identify constrained tyvars
457 constrained_tvs = varSetElems (tyVarsOfTypes (map idType dict_ids))
458 -- The dict_ids are fully zonked
459 final_forall_tvs = forall_tvs `minusList` constrained_tvs
462 -- Now simplify with exactly that set of tyvars
463 -- We have to squash those Methods
464 tcSimplifyCheck doc final_forall_tvs [] lie_req `thenTc` \ (lie_free, binds) ->
466 returnTc (final_forall_tvs, lie_free, binds, [])
469 is_unrestricted | opt_NoMonomorphismRestriction = True
470 | otherwise = isUnRestrictedGroup tysig_names mbind
472 tysig_names = [name | (TySigInfo name _ _ _ _ _ _ _) <- sigs]
474 doc | null sigs = ptext SLIT("banding(s) for") <+> pprBinders binder_names
475 | otherwise = ptext SLIT("type signature(s) for") <+> pprBinders binder_names
477 -----------------------
478 -- CHECK THAT ALL THE SIGNATURE CONTEXTS ARE UNIFIABLE
479 -- The type signatures on a mutually-recursive group of definitions
480 -- must all have the same context (or none).
482 -- We unify them because, with polymorphic recursion, their types
483 -- might not otherwise be related. This is a rather subtle issue.
485 checkSigsCtxts sigs@(TySigInfo _ id1 sig_tvs theta1 _ _ _ _ : other_sigs)
486 = mapTc_ check_one other_sigs `thenTc_`
488 returnTc ([], []) -- Non-overloaded type signatures
490 newDicts SignatureOrigin theta1 `thenNF_Tc` \ sig_dicts ->
492 -- The "sig_avails" is the stuff available. We get that from
493 -- the context of the type signature, BUT ALSO the lie_avail
494 -- so that polymorphic recursion works right (see comments at end of fn)
495 sig_avails = sig_dicts ++ sig_meths
497 returnTc (sig_avails, map instToId sig_dicts)
499 sig1_dict_tys = map mkPredTy theta1
500 n_sig1_theta = length theta1
501 sig_meths = concat [insts | TySigInfo _ _ _ _ _ _ insts _ <- sigs]
503 check_one sig@(TySigInfo _ id _ theta _ _ _ src_loc)
504 = tcAddSrcLoc src_loc $
505 tcAddErrCtxt (sigContextsCtxt id1 id) $
506 checkTc (length theta == n_sig1_theta) sigContextsErr `thenTc_`
507 unifyTauTyLists sig1_dict_tys (map mkPredTy theta)
509 checkSigsTyVars sigs = mapTc_ check_one sigs
511 check_one (TySigInfo _ id sig_tyvars sig_theta sig_tau _ _ src_loc)
512 = tcAddSrcLoc src_loc $
513 tcAddErrCtxtM (sigCtxt (sig_msg id) sig_tyvars sig_theta sig_tau) $
514 checkSigTyVars sig_tyvars (idFreeTyVars id)
516 sig_msg id = ptext SLIT("When checking the type signature for") <+> quotes (ppr id)
519 @getTyVarsToGen@ decides what type variables to generalise over.
521 For a "restricted group" -- see the monomorphism restriction
522 for a definition -- we bind no dictionaries, and
523 remove from tyvars_to_gen any constrained type variables
525 *Don't* simplify dicts at this point, because we aren't going
526 to generalise over these dicts. By the time we do simplify them
527 we may well know more. For example (this actually came up)
529 f x = array ... xs where xs = [1,2,3,4,5]
530 We don't want to generate lots of (fromInt Int 1), (fromInt Int 2)
531 stuff. If we simplify only at the f-binding (not the xs-binding)
532 we'll know that the literals are all Ints, and we can just produce
535 Find all the type variables involved in overloading, the
536 "constrained_tyvars". These are the ones we *aren't* going to
537 generalise. We must be careful about doing this:
539 (a) If we fail to generalise a tyvar which is not actually
540 constrained, then it will never, ever get bound, and lands
541 up printed out in interface files! Notorious example:
542 instance Eq a => Eq (Foo a b) where ..
543 Here, b is not constrained, even though it looks as if it is.
544 Another, more common, example is when there's a Method inst in
545 the LIE, whose type might very well involve non-overloaded
547 [NOTE: Jan 2001: I don't understand the problem here so I'm doing
548 the simple thing instead]
550 (b) On the other hand, we mustn't generalise tyvars which are constrained,
551 because we are going to pass on out the unmodified LIE, with those
552 tyvars in it. They won't be in scope if we've generalised them.
554 So we are careful, and do a complete simplification just to find the
555 constrained tyvars. We don't use any of the results, except to
556 find which tyvars are constrained.
559 isUnRestrictedGroup :: [Name] -- Signatures given for these
563 is_elem v vs = isIn "isUnResMono" v vs
565 isUnRestrictedGroup sigs (PatMonoBind other _ _) = False
566 isUnRestrictedGroup sigs (VarMonoBind v _) = v `is_elem` sigs
567 isUnRestrictedGroup sigs (FunMonoBind v _ matches _) = any isUnRestrictedMatch matches ||
569 isUnRestrictedGroup sigs (AndMonoBinds mb1 mb2) = isUnRestrictedGroup sigs mb1 &&
570 isUnRestrictedGroup sigs mb2
571 isUnRestrictedGroup sigs EmptyMonoBinds = True
573 isUnRestrictedMatch (Match _ [] Nothing _) = False -- No args, no signature
574 isUnRestrictedMatch other = True -- Some args or a signature
578 %************************************************************************
580 \subsection{tcMonoBind}
582 %************************************************************************
584 @tcMonoBinds@ deals with a single @MonoBind@.
585 The signatures have been dealt with already.
588 tcMonoBinds :: RenamedMonoBinds
593 [Name], -- Bound names
594 [TcId]) -- Corresponding monomorphic bound things
596 tcMonoBinds mbinds tc_ty_sigs is_rec
597 = tc_mb_pats mbinds `thenTc` \ (complete_it, lie_req_pat, tvs, ids, lie_avail) ->
599 id_list = bagToList ids
600 (names, mono_ids) = unzip id_list
602 -- This last defn is the key one:
603 -- extend the val envt with bindings for the
604 -- things bound in this group, overriding the monomorphic
605 -- ids with the polymorphic ones from the pattern
606 extra_val_env = case is_rec of
607 Recursive -> map mk_bind id_list
610 -- Don't know how to deal with pattern-bound existentials yet
611 checkTc (isEmptyBag tvs && isEmptyBag lie_avail)
612 (existentialExplode mbinds) `thenTc_`
614 -- *Before* checking the RHSs, but *after* checking *all* the patterns,
615 -- extend the envt with bindings for all the bound ids;
616 -- and *then* override with the polymorphic Ids from the signatures
617 -- That is the whole point of the "complete_it" stuff.
619 -- There's a further wrinkle: we have to delay extending the environment
620 -- until after we've dealt with any pattern-bound signature type variables
621 -- Consider f (x::a) = ...f...
622 -- We're going to check that a isn't unified with anything in the envt,
623 -- so f itself had better not be! So we pass the envt binding f into
624 -- complete_it, which extends the actual envt in TcMatches.tcMatch, after
625 -- dealing with the signature tyvars
627 complete_it extra_val_env `thenTc` \ (mbinds', lie_req_rhss) ->
629 returnTc (mbinds', lie_req_pat `plusLIE` lie_req_rhss, names, mono_ids)
632 -- This function is used when dealing with a LHS binder;
633 -- we make a monomorphic version of the Id.
634 -- We check for a type signature; if there is one, we use the mono_id
635 -- from the signature. This is how we make sure the tau part of the
636 -- signature actually maatches the type of the LHS; then tc_mb_pats
637 -- ensures the LHS and RHS have the same type
639 tc_pat_bndr name pat_ty
640 = case maybeSig tc_ty_sigs name of
642 -> newLocalId (getOccName name) pat_ty (getSrcLoc name)
644 Just (TySigInfo _ _ _ _ _ mono_id _ _)
645 -> tcAddSrcLoc (getSrcLoc name) $
646 unifyTauTy (idType mono_id) pat_ty `thenTc_`
649 mk_bind (name, mono_id) = case maybeSig tc_ty_sigs name of
650 Nothing -> (name, mono_id)
651 Just (TySigInfo name poly_id _ _ _ _ _ _) -> (name, poly_id)
653 tc_mb_pats EmptyMonoBinds
654 = returnTc (\ xve -> returnTc (EmptyMonoBinds, emptyLIE), emptyLIE, emptyBag, emptyBag, emptyLIE)
656 tc_mb_pats (AndMonoBinds mb1 mb2)
657 = tc_mb_pats mb1 `thenTc` \ (complete_it1, lie_req1, tvs1, ids1, lie_avail1) ->
658 tc_mb_pats mb2 `thenTc` \ (complete_it2, lie_req2, tvs2, ids2, lie_avail2) ->
660 complete_it xve = complete_it1 xve `thenTc` \ (mb1', lie1) ->
661 complete_it2 xve `thenTc` \ (mb2', lie2) ->
662 returnTc (AndMonoBinds mb1' mb2', lie1 `plusLIE` lie2)
664 returnTc (complete_it,
665 lie_req1 `plusLIE` lie_req2,
666 tvs1 `unionBags` tvs2,
667 ids1 `unionBags` ids2,
668 lie_avail1 `plusLIE` lie_avail2)
670 tc_mb_pats (FunMonoBind name inf matches locn)
671 = newTyVarTy kind `thenNF_Tc` \ bndr_ty ->
672 tc_pat_bndr name bndr_ty `thenTc` \ bndr_id ->
674 complete_it xve = tcAddSrcLoc locn $
675 tcMatchesFun xve name bndr_ty matches `thenTc` \ (matches', lie) ->
676 returnTc (FunMonoBind bndr_id inf matches' locn, lie)
678 returnTc (complete_it, emptyLIE, emptyBag, unitBag (name, bndr_id), emptyLIE)
680 tc_mb_pats bind@(PatMonoBind pat grhss locn)
682 newTyVarTy kind `thenNF_Tc` \ pat_ty ->
684 -- Now typecheck the pattern
685 -- We don't support binding fresh type variables in the
686 -- pattern of a pattern binding. For example, this is illegal:
688 -- whereas this is ok
689 -- (x::Int, y::Bool) = e
691 -- We don't check explicitly for this problem. Instead, we simply
692 -- type check the pattern with tcPat. If the pattern mentions any
693 -- fresh tyvars we simply get an out-of-scope type variable error
694 tcPat tc_pat_bndr pat pat_ty `thenTc` \ (pat', lie_req, tvs, ids, lie_avail) ->
696 complete_it xve = tcAddSrcLoc locn $
697 tcAddErrCtxt (patMonoBindsCtxt bind) $
698 tcExtendLocalValEnv xve $
699 tcGRHSs grhss pat_ty PatBindRhs `thenTc` \ (grhss', lie) ->
700 returnTc (PatMonoBind pat' grhss' locn, lie)
702 returnTc (complete_it, lie_req, tvs, ids, lie_avail)
704 -- Figure out the appropriate kind for the pattern,
705 -- and generate a suitable type variable
706 kind = case is_rec of
707 Recursive -> liftedTypeKind -- Recursive, so no unlifted types
708 NonRecursive -> openTypeKind -- Non-recursive, so we permit unlifted types
712 %************************************************************************
714 \subsection{SPECIALIZE pragmas}
716 %************************************************************************
718 @tcSpecSigs@ munches up the specialisation "signatures" that arise through *user*
719 pragmas. It is convenient for them to appear in the @[RenamedSig]@
720 part of a binding because then the same machinery can be used for
721 moving them into place as is done for type signatures.
726 f :: Ord a => [a] -> b -> b
727 {-# SPECIALIZE f :: [Int] -> b -> b #-}
730 For this we generate:
732 f* = /\ b -> let d1 = ...
736 where f* is a SpecPragmaId. The **sole** purpose of SpecPragmaIds is to
737 retain a right-hand-side that the simplifier will otherwise discard as
738 dead code... the simplifier has a flag that tells it not to discard
739 SpecPragmaId bindings.
741 In this case the f* retains a call-instance of the overloaded
742 function, f, (including appropriate dictionaries) so that the
743 specialiser will subsequently discover that there's a call of @f@ at
744 Int, and will create a specialisation for @f@. After that, the
745 binding for @f*@ can be discarded.
747 We used to have a form
748 {-# SPECIALISE f :: <type> = g #-}
749 which promised that g implemented f at <type>, but we do that with
751 {-# SPECIALISE (f::<type) = g #-}
754 tcSpecSigs :: [RenamedSig] -> TcM (TcMonoBinds, LIE)
755 tcSpecSigs (SpecSig name poly_ty src_loc : sigs)
756 = -- SPECIALISE f :: forall b. theta => tau = g
757 tcAddSrcLoc src_loc $
758 tcAddErrCtxt (valSpecSigCtxt name poly_ty) $
760 -- Get and instantiate its alleged specialised type
761 tcHsSigType poly_ty `thenTc` \ sig_ty ->
763 -- Check that f has a more general type, and build a RHS for
764 -- the spec-pragma-id at the same time
765 tcExpr (HsVar name) sig_ty `thenTc` \ (spec_expr, spec_lie) ->
767 -- Squeeze out any Methods (see comments with tcSimplifyToDicts)
768 tcSimplifyToDicts spec_lie `thenTc` \ (spec_dicts, spec_binds) ->
770 -- Just specialise "f" by building a SpecPragmaId binding
771 -- It is the thing that makes sure we don't prematurely
772 -- dead-code-eliminate the binding we are really interested in.
773 newSpecPragmaId name sig_ty `thenNF_Tc` \ spec_id ->
775 -- Do the rest and combine
776 tcSpecSigs sigs `thenTc` \ (binds_rest, lie_rest) ->
777 returnTc (binds_rest `andMonoBinds` VarMonoBind spec_id (mkHsLet spec_binds spec_expr),
778 lie_rest `plusLIE` mkLIE spec_dicts)
780 tcSpecSigs (other_sig : sigs) = tcSpecSigs sigs
781 tcSpecSigs [] = returnTc (EmptyMonoBinds, emptyLIE)
785 %************************************************************************
787 \subsection[TcBinds-errors]{Error contexts and messages}
789 %************************************************************************
793 patMonoBindsCtxt bind
794 = hang (ptext SLIT("In a pattern binding:")) 4 (ppr bind)
796 -----------------------------------------------
798 = sep [ptext SLIT("In a SPECIALIZE pragma for a value:"),
799 nest 4 (ppr v <+> dcolon <+> ppr ty)]
801 -----------------------------------------------
802 sigContextsErr = ptext SLIT("Mismatched contexts")
804 sigContextsCtxt s1 s2
805 = hang (hsep [ptext SLIT("When matching the contexts of the signatures for"),
806 quotes (ppr s1), ptext SLIT("and"), quotes (ppr s2)])
807 4 (ptext SLIT("(the signature contexts in a mutually recursive group should all be identical)"))
809 -----------------------------------------------
810 unliftedBindErr flavour mbind
811 = hang (text flavour <+> ptext SLIT("bindings for unlifted types aren't allowed:"))
814 -----------------------------------------------
815 existentialExplode mbinds
816 = hang (vcat [text "My brain just exploded.",
817 text "I can't handle pattern bindings for existentially-quantified constructors.",
818 text "In the binding group"])
821 -----------------------------------------------
822 restrictedBindCtxtErr binder_names
823 = hang (ptext SLIT("Illegal overloaded type signature(s)"))
824 4 (vcat [ptext SLIT("in a binding group for") <+> pprBinders binder_names,
825 ptext SLIT("that falls under the monomorphism restriction")])
827 -- Used in error messages
828 pprBinders bndrs = braces (pprWithCommas ppr bndrs)