2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
4 \section[TcBinds]{TcBinds}
7 #include "HsVersions.h"
9 module TcBinds ( tcBindsAndThen, tcPragmaSigs, checkSigTyVars, tcBindWithSigs, TcSigInfo(..) ) where
13 import HsSyn ( HsBinds(..), Sig(..), MonoBinds(..),
14 Match, HsType, InPat(..), OutPat(..), HsExpr(..),
15 SYN_IE(RecFlag), nonRecursive,
16 GRHSsAndBinds, ArithSeqInfo, HsLit, Fake, Stmt, DoOrListComp, Fixity,
18 import RnHsSyn ( SYN_IE(RenamedHsBinds), RenamedSig(..),
19 SYN_IE(RenamedMonoBinds)
21 import TcHsSyn ( SYN_IE(TcHsBinds), SYN_IE(TcMonoBinds),
22 TcIdOcc(..), SYN_IE(TcIdBndr), SYN_IE(TcExpr),
27 import Inst ( Inst, SYN_IE(LIE), emptyLIE, plusLIE, InstOrigin(..),
28 newDicts, tyVarsOfInst, instToId
30 import TcEnv ( tcExtendLocalValEnv, tcLookupLocalValueOK, newMonoIds,
31 tcGetGlobalTyVars, tcExtendGlobalTyVars
33 import SpecEnv ( SpecEnv )
34 IMPORT_DELOOPER(TcLoop) ( tcGRHSsAndBinds )
35 import TcMatches ( tcMatchesFun )
36 import TcSimplify ( tcSimplify, tcSimplifyAndCheck )
37 import TcMonoType ( tcHsType )
38 import TcPat ( tcPat )
39 import TcSimplify ( bindInstsOfLocalFuns )
40 import TcType ( SYN_IE(TcType), SYN_IE(TcThetaType), SYN_IE(TcTauType),
41 SYN_IE(TcTyVarSet), SYN_IE(TcTyVar),
42 newTyVarTy, zonkTcType, zonkTcTyVar, zonkTcTyVars,
43 newTcTyVar, tcInstSigType, newTyVarTys
45 import Unify ( unifyTauTy, unifyTauTyLists )
47 import Kind ( isUnboxedTypeKind, mkTypeKind, isTypeKind, mkBoxedTypeKind )
48 import Id ( GenId, idType, mkUserLocal, mkUserId )
49 import IdInfo ( noIdInfo )
50 import Maybes ( maybeToBool, assocMaybe, catMaybes )
51 import Name ( getOccName, getSrcLoc, Name )
52 import PragmaInfo ( PragmaInfo(..) )
54 import Type ( mkTyVarTy, mkTyVarTys, isTyVarTy, tyVarsOfTypes, eqSimpleTheta,
55 mkSigmaTy, splitSigmaTy, mkForAllTys, mkFunTys, getTyVar, mkDictTy,
56 splitRhoTy, mkForAllTy, splitForAllTy )
57 import TyVar ( GenTyVar, SYN_IE(TyVar), tyVarKind, minusTyVarSet, emptyTyVarSet,
58 elementOfTyVarSet, unionTyVarSets, tyVarSetToList )
59 import Bag ( bagToList, foldrBag, isEmptyBag )
60 import Util ( isIn, zipEqual, zipWithEqual, zipWith3Equal, hasNoDups, assoc,
61 assertPanic, panic, pprTrace )
62 import PprType ( GenClass, GenType, GenTyVar )
63 import Unique ( Unique )
64 import SrcLoc ( SrcLoc )
66 import Outputable --( interppSP, interpp'SP )
70 %************************************************************************
72 \subsection{Type-checking bindings}
74 %************************************************************************
76 @tcBindsAndThen@ typechecks a @HsBinds@. The "and then" part is because
77 it needs to know something about the {\em usage} of the things bound,
78 so that it can create specialisations of them. So @tcBindsAndThen@
79 takes a function which, given an extended environment, E, typechecks
80 the scope of the bindings returning a typechecked thing and (most
81 important) an LIE. It is this LIE which is then used as the basis for
82 specialising the things bound.
84 @tcBindsAndThen@ also takes a "combiner" which glues together the
85 bindings and the "thing" to make a new "thing".
87 The real work is done by @tcBindWithSigsAndThen@.
89 Recursive and non-recursive binds are handled in essentially the same
90 way: because of uniques there are no scoping issues left. The only
91 difference is that non-recursive bindings can bind primitive values.
93 Even for non-recursive binding groups we add typings for each binder
94 to the LVE for the following reason. When each individual binding is
95 checked the type of its LHS is unified with that of its RHS; and
96 type-checking the LHS of course requires that the binder is in scope.
98 At the top-level the LIE is sure to contain nothing but constant
99 dictionaries, which we resolve at the module level.
103 :: (TcHsBinds s -> thing -> thing) -- Combinator
105 -> TcM s (thing, LIE s)
106 -> TcM s (thing, LIE s)
108 tcBindsAndThen combiner EmptyBinds do_next
109 = do_next `thenTc` \ (thing, lie) ->
110 returnTc (combiner EmptyBinds thing, lie)
112 tcBindsAndThen combiner (ThenBinds binds1 binds2) do_next
113 = tcBindsAndThen combiner binds1 (tcBindsAndThen combiner binds2 do_next)
115 tcBindsAndThen combiner (MonoBind bind sigs is_rec) do_next
116 = fixTc (\ ~(prag_info_fn, _) ->
117 -- This is the usual prag_info fix; the PragmaInfo field of an Id
118 -- is not inspected till ages later in the compiler, so there
119 -- should be no black-hole problems here.
121 -- TYPECHECK THE SIGNATURES
122 mapTc (tcTySig prag_info_fn) ty_sigs `thenTc` \ tc_ty_sigs ->
124 tcBindWithSigs binder_names bind
125 tc_ty_sigs is_rec prag_info_fn `thenTc` \ (poly_binds, poly_lie, poly_ids) ->
127 -- Extend the environment to bind the new polymorphic Ids
128 tcExtendLocalValEnv binder_names poly_ids $
130 -- Build bindings and IdInfos corresponding to user pragmas
131 tcPragmaSigs sigs `thenTc` \ (prag_info_fn, prag_binds, prag_lie) ->
133 -- Now do whatever happens next, in the augmented envt
134 do_next `thenTc` \ (thing, thing_lie) ->
136 -- Create specialisations of functions bound here
137 bindInstsOfLocalFuns (prag_lie `plusLIE` thing_lie)
138 poly_ids `thenTc` \ (lie2, inst_mbinds) ->
142 final_lie = lie2 `plusLIE` poly_lie
143 final_binds = MonoBind poly_binds [] is_rec `ThenBinds`
144 MonoBind inst_mbinds [] nonRecursive `ThenBinds`
147 returnTc (prag_info_fn, (combiner final_binds thing, final_lie))
148 ) `thenTc` \ (_, result) ->
151 binder_names = map fst (bagToList (collectMonoBinders bind))
152 ty_sigs = [sig | sig@(Sig name _ _) <- sigs]
156 An aside. The original version of @tcBindsAndThen@ which lacks a
157 combiner function, appears below. Though it is perfectly well
158 behaved, it cannot be typed by Haskell, because the recursive call is
159 at a different type to the definition itself. There aren't too many
160 examples of this, which is why I thought it worth preserving! [SLPJ]
165 -> TcM s (thing, LIE s, thing_ty))
166 -> TcM s ((TcHsBinds s, thing), LIE s, thing_ty)
168 tcBindsAndThen EmptyBinds do_next
169 = do_next `thenTc` \ (thing, lie, thing_ty) ->
170 returnTc ((EmptyBinds, thing), lie, thing_ty)
172 tcBindsAndThen (ThenBinds binds1 binds2) do_next
173 = tcBindsAndThen binds1 (tcBindsAndThen binds2 do_next)
174 `thenTc` \ ((binds1', (binds2', thing')), lie1, thing_ty) ->
176 returnTc ((binds1' `ThenBinds` binds2', thing'), lie1, thing_ty)
178 tcBindsAndThen (MonoBind bind sigs is_rec) do_next
179 = tcBindAndThen bind sigs do_next
183 %************************************************************************
185 \subsection{tcBindWithSigs}
187 %************************************************************************
189 @tcBindWithSigs@ deals with a single binding group. It does generalisation,
190 so all the clever stuff is in here.
192 * binder_names and mbind must define the same set of Names
194 * The Names in tc_ty_sigs must be a subset of binder_names
196 * The Ids in tc_ty_sigs don't necessarily have to have the same name
197 as the Name in the tc_ty_sig
205 -> (Name -> PragmaInfo)
206 -> TcM s (TcMonoBinds s, LIE s, [TcIdBndr s])
208 tcBindWithSigs binder_names mbind tc_ty_sigs is_rec prag_info_fn
210 -- If typechecking the binds fails, then return with each
211 -- signature-less binder given type (forall a.a), to minimise subsequent
213 newTcTyVar mkBoxedTypeKind `thenNF_Tc` \ alpha_tv ->
215 forall_a_a = mkForAllTy alpha_tv (mkTyVarTy alpha_tv)
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 -> mkUserId name forall_a_a NoPragmaInfo -- No signature
221 returnTc (EmptyMonoBinds, emptyLIE, poly_ids)
224 -- Create a new identifier for each binder, with each being given
225 -- a fresh unique, and a type-variable type.
226 tcGetUniques no_of_binders `thenNF_Tc` \ uniqs ->
227 mapNF_Tc mk_mono_id_ty binder_names `thenNF_Tc` \ mono_id_tys ->
229 mono_id_tyvars = tyVarsOfTypes mono_id_tys
230 mono_ids = zipWith3Equal "tcBindAndSigs" mk_id binder_names uniqs mono_id_tys
231 mk_id name uniq ty = mkUserLocal (getOccName name) uniq ty (getSrcLoc name)
234 -- TYPECHECK THE BINDINGS
235 tcMonoBinds mbind binder_names mono_ids tc_ty_sigs `thenTc` \ (mbind', lie) ->
237 -- CHECK THAT THE SIGNATURES MATCH
238 -- (must do this before getTyVarsToGen)
239 checkSigMatch tc_ty_sigs `thenTc` \ sig_theta ->
241 -- COMPUTE VARIABLES OVER WHICH TO QUANTIFY, namely tyvars_to_gen
242 -- The tyvars_not_to_gen are free in the environment, and hence
243 -- candidates for generalisation, but sometimes the monomorphism
244 -- restriction means we can't generalise them nevertheless
245 getTyVarsToGen is_unrestricted mono_id_tyvars lie `thenTc` \ (tyvars_not_to_gen, tyvars_to_gen) ->
247 -- DEAL WITH TYPE VARIABLE KINDS
248 mapTc defaultUncommittedTyVar (tyVarSetToList tyvars_to_gen) `thenTc` \ tyvars_to_gen_list ->
249 -- It's important that the final list (tyvars_to_gen_list) is fully
250 -- zonked, *including boxity*, because they'll be included in the forall types of
251 -- the polymorphic Ids, and instances of these Ids will be generated from them.
253 -- This step can do unification => keep other zonking after this
256 tcExtendGlobalTyVars tyvars_not_to_gen (
257 if null tc_ty_sigs then
258 -- No signatures, so just simplify the lie
259 tcSimplify tyvars_to_gen lie `thenTc` \ (lie_free, dict_binds, lie_bound) ->
260 returnTc (lie_free, dict_binds, map instToId (bagToList lie_bound))
263 zonk_theta sig_theta `thenNF_Tc` \ sig_theta' ->
264 newDicts SignatureOrigin sig_theta' `thenNF_Tc` \ (dicts_sig, dict_ids) ->
265 -- It's important that sig_theta is zonked, because
266 -- dict_id is later used to form the type of the polymorphic thing,
267 -- and forall-types must be zonked so far as their bound variables
270 -- Check that the needed dicts can be expressed in
271 -- terms of the signature ones
272 tcAddErrCtxt (sigsCtxt tysig_names) $
273 tcSimplifyAndCheck tyvars_to_gen dicts_sig lie `thenTc` \ (lie_free, dict_binds) ->
274 returnTc (lie_free, dict_binds, dict_ids)
276 ) `thenTc` \ (lie_free, dict_binds, dicts_bound) ->
278 ASSERT( not (any (isUnboxedTypeKind . tyVarKind) tyvars_to_gen_list) )
279 -- The instCantBeGeneralised stuff in tcSimplify should have
280 -- already raised an error if we're trying to generalise an unboxed tyvar
281 -- (NB: unboxed tyvars are always introduced along with a class constraint)
282 -- and it's better done there because we have more precise origin information.
283 -- That's why we just use an ASSERT here.
285 -- BUILD THE POLYMORPHIC RESULT IDs
286 mapNF_Tc zonkTcType mono_id_tys `thenNF_Tc` \ zonked_mono_id_types ->
288 exports = zipWith3 mk_export binder_names mono_ids zonked_mono_id_types
289 dict_tys = map tcIdType dicts_bound
291 mk_export binder_name mono_id zonked_mono_id_ty
292 | maybeToBool maybe_sig = (sig_tyvars, TcId sig_poly_id, TcId mono_id)
293 | otherwise = (tyvars_to_gen_list, TcId poly_id, TcId mono_id)
295 maybe_sig = maybeSig tc_ty_sigs binder_name
296 Just (TySigInfo _ sig_poly_id sig_tyvars _ _ _) = maybe_sig
297 poly_id = mkUserId binder_name poly_ty (prag_info_fn binder_name)
298 poly_ty = mkForAllTys tyvars_to_gen_list $ mkFunTys dict_tys $ zonked_mono_id_ty
299 -- It's important to build a fully-zonked poly_ty, because
300 -- we'll slurp out its free type variables when extending the
301 -- local environment (tcExtendLocalValEnv); if it's not zonked
302 -- it appears to have free tyvars that aren't actually free at all.
307 AbsBinds tyvars_to_gen_list
310 (dict_binds `AndMonoBinds` mbind'),
312 [poly_id | (_, TcId poly_id, _) <- exports]
315 no_of_binders = length binder_names
317 mk_mono_id_ty binder_name = case maybeSig tc_ty_sigs binder_name of
318 Just (TySigInfo name _ _ _ tau_ty _) -> returnNF_Tc tau_ty -- There's a signature
319 otherwise -> newTyVarTy kind -- No signature
321 tysig_names = [name | (TySigInfo name _ _ _ _ _) <- tc_ty_sigs]
322 is_unrestricted = isUnRestrictedGroup tysig_names mbind
324 kind | is_rec = mkBoxedTypeKind -- Recursive, so no unboxed types
325 | otherwise = mkTypeKind -- Non-recursive, so we permit unboxed types
327 zonk_theta theta = mapNF_Tc zonk theta
329 zonk (c,t) = zonkTcType t `thenNF_Tc` \ t' ->
333 @getImplicitStuffToGen@ decides what type variables generalise over.
335 For a "restricted group" -- see the monomorphism restriction
336 for a definition -- we bind no dictionaries, and
337 remove from tyvars_to_gen any constrained type variables
339 *Don't* simplify dicts at this point, because we aren't going
340 to generalise over these dicts. By the time we do simplify them
341 we may well know more. For example (this actually came up)
343 f x = array ... xs where xs = [1,2,3,4,5]
344 We don't want to generate lots of (fromInt Int 1), (fromInt Int 2)
345 stuff. If we simplify only at the f-binding (not the xs-binding)
346 we'll know that the literals are all Ints, and we can just produce
349 Find all the type variables involved in overloading, the
350 "constrained_tyvars". These are the ones we *aren't* going to
351 generalise. We must be careful about doing this:
353 (a) If we fail to generalise a tyvar which is not actually
354 constrained, then it will never, ever get bound, and lands
355 up printed out in interface files! Notorious example:
356 instance Eq a => Eq (Foo a b) where ..
357 Here, b is not constrained, even though it looks as if it is.
358 Another, more common, example is when there's a Method inst in
359 the LIE, whose type might very well involve non-overloaded
362 (b) On the other hand, we mustn't generalise tyvars which are constrained,
363 because we are going to pass on out the unmodified LIE, with those
364 tyvars in it. They won't be in scope if we've generalised them.
366 So we are careful, and do a complete simplification just to find the
367 constrained tyvars. We don't use any of the results, except to
368 find which tyvars are constrained.
371 getTyVarsToGen is_unrestricted mono_tyvars lie
372 = tcGetGlobalTyVars `thenNF_Tc` \ free_tyvars ->
373 zonkTcTyVars mono_tyvars `thenNF_Tc` \ mentioned_tyvars ->
375 tyvars_to_gen = mentioned_tyvars `minusTyVarSet` free_tyvars
379 returnTc (emptyTyVarSet, tyvars_to_gen)
381 tcSimplify tyvars_to_gen lie `thenTc` \ (_, _, constrained_dicts) ->
383 -- ASSERT: dicts_sig is already zonked!
384 constrained_tyvars = foldrBag (unionTyVarSets . tyVarsOfInst) emptyTyVarSet constrained_dicts
385 reduced_tyvars_to_gen = tyvars_to_gen `minusTyVarSet` constrained_tyvars
387 returnTc (constrained_tyvars, reduced_tyvars_to_gen)
392 isUnRestrictedGroup :: [Name] -- Signatures given for these
396 is_elem v vs = isIn "isUnResMono" v vs
398 isUnRestrictedGroup sigs (PatMonoBind (VarPatIn v) _ _) = v `is_elem` sigs
399 isUnRestrictedGroup sigs (PatMonoBind other _ _) = False
400 isUnRestrictedGroup sigs (VarMonoBind v _) = v `is_elem` sigs
401 isUnRestrictedGroup sigs (FunMonoBind _ _ _ _) = True
402 isUnRestrictedGroup sigs (AndMonoBinds mb1 mb2) = isUnRestrictedGroup sigs mb1 &&
403 isUnRestrictedGroup sigs mb2
404 isUnRestrictedGroup sigs EmptyMonoBinds = True
407 @defaultUncommittedTyVar@ checks for generalisation over unboxed
408 types, and defaults any TypeKind TyVars to BoxedTypeKind.
411 defaultUncommittedTyVar tyvar
412 | isTypeKind (tyVarKind tyvar)
413 = newTcTyVar mkBoxedTypeKind `thenNF_Tc` \ boxed_tyvar ->
414 unifyTauTy (mkTyVarTy boxed_tyvar) (mkTyVarTy tyvar) `thenTc_`
422 %************************************************************************
424 \subsection{tcMonoBind}
426 %************************************************************************
428 @tcMonoBinds@ deals with a single @MonoBind@.
429 The signatures have been dealt with already.
432 tcMonoBinds :: RenamedMonoBinds
433 -> [Name] -> [TcIdBndr s]
435 -> TcM s (TcMonoBinds s, LIE s)
437 tcMonoBinds mbind binder_names mono_ids tc_ty_sigs
438 = tcExtendLocalValEnv binder_names mono_ids (
442 sig_names = [name | (TySigInfo name _ _ _ _ _) <- tc_ty_sigs]
443 sig_ids = [id | (TySigInfo _ id _ _ _ _) <- tc_ty_sigs]
445 tc_mono_binds EmptyMonoBinds = returnTc (EmptyMonoBinds, emptyLIE)
447 tc_mono_binds (AndMonoBinds mb1 mb2)
448 = tc_mono_binds mb1 `thenTc` \ (mb1a, lie1) ->
449 tc_mono_binds mb2 `thenTc` \ (mb2a, lie2) ->
450 returnTc (AndMonoBinds mb1a mb2a, lie1 `plusLIE` lie2)
452 tc_mono_binds (FunMonoBind name inf matches locn)
454 tcLookupLocalValueOK "tc_mono_binds" name `thenNF_Tc` \ id ->
456 -- Before checking the RHS, extend the envt with
457 -- bindings for the *polymorphic* Ids from any type signatures
458 tcExtendLocalValEnv sig_names sig_ids $
459 tcMatchesFun name (idType id) matches `thenTc` \ (matches', lie) ->
461 returnTc (FunMonoBind (TcId id) inf matches' locn, lie)
463 tc_mono_binds bind@(PatMonoBind pat grhss_and_binds locn)
465 tcPat pat `thenTc` \ (pat2, lie_pat, pat_ty) ->
466 tcExtendLocalValEnv sig_names sig_ids $
467 tcGRHSsAndBinds grhss_and_binds `thenTc` \ (grhss_and_binds2, lie, grhss_ty) ->
468 tcAddErrCtxt (patMonoBindsCtxt bind) $
469 unifyTauTy pat_ty grhss_ty `thenTc_`
470 returnTc (PatMonoBind pat2 grhss_and_binds2 locn,
474 %************************************************************************
476 \subsection{Signatures}
478 %************************************************************************
480 @tcSigs@ checks the signatures for validity, and returns a list of
481 {\em freshly-instantiated} signatures. That is, the types are already
482 split up, and have fresh type variables installed. All non-type-signature
483 "RenamedSigs" are ignored.
485 The @TcSigInfo@ contains @TcTypes@ because they are unified with
486 the variable's type, and after that checked to see whether they've
492 (TcIdBndr s) -- *Polymorphic* binder for this value...
493 [TcTyVar s] (TcThetaType s) (TcTauType s)
497 maybeSig :: [TcSigInfo s] -> Name -> Maybe (TcSigInfo s)
498 -- Search for a particular signature
499 maybeSig [] name = Nothing
500 maybeSig (sig@(TySigInfo sig_name _ _ _ _ _) : sigs) name
501 | name == sig_name = Just sig
502 | otherwise = maybeSig sigs name
507 tcTySig :: (Name -> PragmaInfo)
509 -> TcM s (TcSigInfo s)
511 tcTySig prag_info_fn (Sig v ty src_loc)
512 = tcAddSrcLoc src_loc $
513 tcHsType ty `thenTc` \ sigma_ty ->
514 tcInstSigType sigma_ty `thenNF_Tc` \ sigma_ty' ->
516 poly_id = mkUserId v sigma_ty' (prag_info_fn v)
517 (tyvars', theta', tau') = splitSigmaTy sigma_ty'
518 -- This splitSigmaTy tries hard to make sure that tau' is a type synonym
519 -- wherever possible, which can improve interface files.
521 returnTc (TySigInfo v poly_id tyvars' theta' tau' src_loc)
524 @checkSigMatch@ does the next step in checking signature matching.
525 The tau-type part has already been unified. What we do here is to
526 check that this unification has not over-constrained the (polymorphic)
527 type variables of the original signature type.
529 The error message here is somewhat unsatisfactory, but it'll do for
534 = returnTc (error "checkSigMatch")
536 checkSigMatch tc_ty_sigs
537 = -- CHECK THAT ALL THE SIGNATURE CONTEXTS ARE UNIFIABLE
538 -- The type signatures on a mutually-recursive group of definitions
539 -- must all have the same context (or none).
541 -- We unify them because, with polymorphic recursion, their types
542 -- might not otherwise be related. This is a rather subtle issue.
544 tcAddErrCtxt (sigContextsCtxt tc_ty_sigs) (
545 mapTc (unifyTauTyLists dict_tys1) dict_tys_s
548 -- CHECK THAT THE SIGNATURE TYVARS AND TAU_TYPES ARE OK
549 -- Doesn't affect substitution
550 mapTc check_one_sig tc_ty_sigs `thenTc_`
554 (theta1:thetas) = [theta | TySigInfo _ _ _ theta _ _ <- tc_ty_sigs]
555 (dict_tys1 : dict_tys_s) = map mk_dict_tys (theta1 : thetas)
556 mk_dict_tys theta = [mkDictTy c t | (c,t) <- theta]
558 check_one_sig (TySigInfo name id sig_tyvars _ sig_tau src_loc)
559 = tcAddSrcLoc src_loc $
560 tcAddErrCtxt (sigCtxt id) $
561 checkSigTyVars sig_tyvars sig_tau
565 @checkSigTyVars@ is used after the type in a type signature has been unified with
566 the actual type found. It then checks that the type variables of the type signature
568 (a) still all type variables
569 eg matching signature [a] against inferred type [(p,q)]
570 [then a will be unified to a non-type variable]
572 (b) still all distinct
573 eg matching signature [(a,b)] against inferred type [(p,p)]
574 [then a and b will be unified together]
576 BUT ACTUALLY THESE FIRST TWO ARE FORCED BY USING DontBind TYVARS
578 (c) not mentioned in the environment
579 eg the signature for f in this:
585 Here, f is forced to be monorphic by the free occurence of x.
587 Before doing this, the substitution is applied to the signature type variable.
590 checkSigTyVars :: [TcTyVar s] -- The original signature type variables
591 -> TcType s -- signature type (for err msg)
594 checkSigTyVars sig_tyvars sig_tau
595 = tcGetGlobalTyVars `thenNF_Tc` \ globals ->
597 mono_tyvars = filter (`elementOfTyVarSet` globals) sig_tyvars
600 -- Until the final Bind-handling stuff is in, several type signatures in the same
601 -- bindings group can cause the signature type variable from the different
602 -- signatures to be unified. So we still need to zonk and check point (b).
603 -- Remove when activating the new binding code
604 mapNF_Tc zonkTcTyVar sig_tyvars `thenNF_Tc` \ sig_tys ->
605 checkTcM (hasNoDups (map (getTyVar "checkSigTyVars") sig_tys))
606 (zonkTcType sig_tau `thenNF_Tc` \ sig_tau' ->
607 failTc (badMatchErr sig_tau sig_tau')
612 -- We want to report errors in terms of the original signature tyvars,
613 -- ie sig_tyvars, NOT sig_tyvars'. sig_tys and sig_tyvars' correspond
614 -- 1-1 with sig_tyvars, so we can just map back.
615 checkTc (null mono_tyvars)
616 (notAsPolyAsSigErr sig_tau mono_tyvars)
620 %************************************************************************
622 \subsection{SPECIALIZE pragmas}
624 %************************************************************************
627 @tcPragmaSigs@ munches up the "signatures" that arise through *user*
628 pragmas. It is convenient for them to appear in the @[RenamedSig]@
629 part of a binding because then the same machinery can be used for
630 moving them into place as is done for type signatures.
633 tcPragmaSigs :: [RenamedSig] -- The pragma signatures
634 -> TcM s (Name -> PragmaInfo, -- Maps name to the appropriate PragmaInfo
638 tcPragmaSigs sigs = returnTc ( \name -> NoPragmaInfo, EmptyBinds, emptyLIE )
642 = mapAndUnzip3Tc tcPragmaSig sigs `thenTc` \ (names_w_id_infos, binds, lies) ->
644 name_to_info name = foldr ($) noIdInfo
645 [info_fn | (n,info_fn) <- names_w_id_infos, n==name]
647 returnTc (name_to_info,
648 foldr ThenBinds EmptyBinds binds,
649 foldr plusLIE emptyLIE lies)
652 Here are the easy cases for tcPragmaSigs
655 tcPragmaSig (DeforestSig name loc)
656 = returnTc ((name, addDeforestInfo DoDeforest),EmptyBinds,emptyLIE)
657 tcPragmaSig (InlineSig name loc)
658 = returnTc ((name, addUnfoldInfo (iWantToBeINLINEd UnfoldAlways)), EmptyBinds, emptyLIE)
659 tcPragmaSig (MagicUnfoldingSig name string loc)
660 = returnTc ((name, addUnfoldInfo (mkMagicUnfolding string)), EmptyBinds, emptyLIE)
663 The interesting case is for SPECIALISE pragmas. There are two forms.
664 Here's the first form:
666 f :: Ord a => [a] -> b -> b
667 {-# SPECIALIZE f :: [Int] -> b -> b #-}
670 For this we generate:
672 f* = /\ b -> let d1 = ...
676 where f* is a SpecPragmaId. The **sole** purpose of SpecPragmaIds is to
677 retain a right-hand-side that the simplifier will otherwise discard as
678 dead code... the simplifier has a flag that tells it not to discard
679 SpecPragmaId bindings.
681 In this case the f* retains a call-instance of the overloaded
682 function, f, (including appropriate dictionaries) so that the
683 specialiser will subsequently discover that there's a call of @f@ at
684 Int, and will create a specialisation for @f@. After that, the
685 binding for @f*@ can be discarded.
687 The second form is this:
689 f :: Ord a => [a] -> b -> b
690 {-# SPECIALIZE f :: [Int] -> b -> b = g #-}
693 Here @g@ is specified as a function that implements the specialised
694 version of @f@. Suppose that g has type (a->b->b); that is, g's type
695 is more general than that required. For this we generate
697 f@Int = /\b -> g Int b
701 Here @f@@Int@ is a SpecId, the specialised version of @f@. It inherits
702 f's export status etc. @f*@ is a SpecPragmaId, as before, which just serves
703 to prevent @f@@Int@ from being discarded prematurely. After specialisation,
704 if @f@@Int@ is going to be used at all it will be used explicitly, so the simplifier can
705 discard the f* binding.
707 Actually, there is really only point in giving a SPECIALISE pragma on exported things,
708 and the simplifer won't discard SpecIds for exporte things anyway, so maybe this is
712 tcPragmaSig (SpecSig name poly_ty maybe_spec_name src_loc)
713 = tcAddSrcLoc src_loc $
714 tcAddErrCtxt (valSpecSigCtxt name spec_ty) $
716 -- Get and instantiate its alleged specialised type
717 tcHsType poly_ty `thenTc` \ sig_sigma ->
718 tcInstSigType sig_sigma `thenNF_Tc` \ sig_ty ->
720 (sig_tyvars, sig_theta, sig_tau) = splitSigmaTy sig_ty
721 origin = ValSpecOrigin name
724 -- Check that the SPECIALIZE pragma had an empty context
725 checkTc (null sig_theta)
726 (panic "SPECIALIZE non-empty context (ToDo: msg)") `thenTc_`
728 -- Get and instantiate the type of the id mentioned
729 tcLookupLocalValueOK "tcPragmaSig" name `thenNF_Tc` \ main_id ->
730 tcInstSigType [] (idType main_id) `thenNF_Tc` \ main_ty ->
732 (main_tyvars, main_rho) = splitForAllTy main_ty
733 (main_theta,main_tau) = splitRhoTy main_rho
734 main_arg_tys = mkTyVarTys main_tyvars
737 -- Check that the specialised type is indeed an instance of
738 -- the type of the main function.
739 unifyTauTy sig_tau main_tau `thenTc_`
740 checkSigTyVars sig_tyvars sig_tau `thenTc_`
742 -- Check that the type variables of the polymorphic function are
743 -- either left polymorphic, or instantiate to ground type.
744 -- Also check that the overloaded type variables are instantiated to
745 -- ground type; or equivalently that all dictionaries have ground type
746 mapTc zonkTcType main_arg_tys `thenNF_Tc` \ main_arg_tys' ->
747 zonkTcThetaType main_theta `thenNF_Tc` \ main_theta' ->
748 tcAddErrCtxt (specGroundnessCtxt main_arg_tys')
749 (checkTc (all isGroundOrTyVarTy main_arg_tys')) `thenTc_`
750 tcAddErrCtxt (specContextGroundnessCtxt main_theta')
751 (checkTc (and [isGroundTy ty | (_,ty) <- theta'])) `thenTc_`
753 -- Build the SpecPragmaId; it is the thing that makes sure we
754 -- don't prematurely dead-code-eliminate the binding we are really interested in.
755 newSpecPragmaId name sig_ty `thenNF_Tc` \ spec_pragma_id ->
757 -- Build a suitable binding; depending on whether we were given
758 -- a value (Maybe Name) to be used as the specialisation.
760 Nothing -> -- No implementation function specified
762 -- Make a Method inst for the occurrence of the overloaded function
763 newMethodWithGivenTy (OccurrenceOf name)
764 (TcId main_id) main_arg_tys main_rho `thenNF_Tc` \ (lie, meth_id) ->
767 pseudo_bind = VarMonoBind spec_pragma_id pseudo_rhs
768 pseudo_rhs = mkHsTyLam sig_tyvars (HsVar (TcId meth_id))
770 returnTc (pseudo_bind, lie, \ info -> info)
772 Just spec_name -> -- Use spec_name as the specialisation value ...
774 -- Type check a simple occurrence of the specialised Id
775 tcId spec_name `thenTc` \ (spec_body, spec_lie, spec_tau) ->
777 -- Check that it has the correct type, and doesn't constrain the
778 -- signature variables at all
779 unifyTauTy sig_tau spec_tau `thenTc_`
780 checkSigTyVars sig_tyvars sig_tau `thenTc_`
782 -- Make a local SpecId to bind to applied spec_id
783 newSpecId main_id main_arg_tys sig_ty `thenNF_Tc` \ local_spec_id ->
786 spec_rhs = mkHsTyLam sig_tyvars spec_body
787 spec_binds = VarMonoBind local_spec_id spec_rhs
789 VarMonoBind spec_pragma_id (HsVar (TcId local_spec_id))
790 spec_info = SpecInfo spec_tys (length main_theta) local_spec_id
792 returnTc ((name, addSpecInfo spec_info), spec_binds, spec_lie)
797 %************************************************************************
799 \subsection[TcBinds-errors]{Error contexts and messages}
801 %************************************************************************
805 patMonoBindsCtxt bind sty
806 = hang (ptext SLIT("In a pattern binding:")) 4 (ppr sty bind)
808 -----------------------------------------------
809 valSpecSigCtxt v ty sty
810 = hang (ptext SLIT("In a SPECIALIZE pragma for a value:"))
811 4 (sep [(<>) (ppr sty v) (ptext SLIT(" ::")),
816 -----------------------------------------------
817 notAsPolyAsSigErr sig_tau mono_tyvars sty
818 = hang (ptext SLIT("A type signature is more polymorphic than the inferred type"))
819 4 (vcat [text "Some type variables in the inferred type can't be forall'd, namely:",
820 interpp'SP sty mono_tyvars,
821 ptext SLIT("Possible cause: the RHS mentions something subject to the monomorphism restriction")
824 -----------------------------------------------
825 badMatchErr sig_ty inferred_ty sty
826 = hang (ptext SLIT("Type signature doesn't match inferred type"))
827 4 (vcat [hang (ptext SLIT("Signature:")) 4 (ppr sty sig_ty),
828 hang (ptext SLIT("Inferred :")) 4 (ppr sty inferred_ty)
831 -----------------------------------------------
833 = sep [ptext SLIT("When checking signature for"), ppr sty id]
835 = sep [ptext SLIT("When checking signature(s) for:"), interpp'SP sty ids]
837 -----------------------------------------------
838 sigContextsCtxt ty_sigs sty
839 = hang (ptext SLIT("When matching the contexts of the signatures of a recursive group"))
840 4 (vcat (map ppr_tc_ty_sig ty_sigs))
842 ppr_tc_ty_sig (TySigInfo val _ tyvars theta tau_ty _)
843 = hang ((<>) (ppr sty val) (ptext SLIT(" :: ")))
846 else hcat [parens (hsep (punctuate comma (map (ppr_inst sty) theta))),
848 ppr_inst sty (clas, ty) = hsep [ppr sty clas, ppr sty ty]
850 -----------------------------------------------
852 = panic "specGroundnessCtxt"
854 --------------------------------------------
855 specContextGroundnessCtxt -- err_ctxt dicts sty
856 = panic "specContextGroundnessCtxt"
859 sep [hsep [ptext SLIT("In the SPECIALIZE pragma for"), ppr sty name],
860 hcat [ptext SLIT(" specialised to the type"), ppr sty spec_ty],
862 ptext SLIT("... not all overloaded type variables were instantiated"),
863 ptext SLIT("to ground types:")])
864 4 (vcat [hsep [ppr sty c, ppr sty t]
865 | (c,t) <- map getDictClassAndType dicts])
867 (name, spec_ty, locn, pp_spec_id)
869 ValSpecSigCtxt n ty loc -> (n, ty, loc, \ x -> empty)
870 ValSpecSpecIdCtxt n ty spec loc ->
872 \ sty -> hsep [ptext SLIT("... type of explicit id"), ppr sty spec])