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
12 #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 201
13 IMPORT_DELOOPER(TcLoop) ( tcGRHSsAndBinds )
15 import {-# SOURCE #-} TcGRHSs ( tcGRHSsAndBinds )
18 import HsSyn ( HsBinds(..), Sig(..), MonoBinds(..),
19 Match, HsType, InPat(..), OutPat(..), HsExpr(..),
20 SYN_IE(RecFlag), nonRecursive,
21 GRHSsAndBinds, ArithSeqInfo, HsLit, Fake, Stmt, DoOrListComp, Fixity,
23 import RnHsSyn ( SYN_IE(RenamedHsBinds), RenamedSig(..),
24 SYN_IE(RenamedMonoBinds)
26 import TcHsSyn ( SYN_IE(TcHsBinds), SYN_IE(TcMonoBinds),
27 TcIdOcc(..), SYN_IE(TcIdBndr), SYN_IE(TcExpr),
32 import Inst ( Inst, SYN_IE(LIE), emptyLIE, plusLIE, InstOrigin(..),
33 newDicts, tyVarsOfInst, instToId
35 import TcEnv ( tcExtendLocalValEnv, tcLookupLocalValueOK, newMonoIds,
36 tcGetGlobalTyVars, tcExtendGlobalTyVars
38 import SpecEnv ( SpecEnv )
39 import TcMatches ( tcMatchesFun )
40 import TcSimplify ( tcSimplify, tcSimplifyAndCheck )
41 import TcMonoType ( tcHsType )
42 import TcPat ( tcPat )
43 import TcSimplify ( bindInstsOfLocalFuns )
44 import TcType ( SYN_IE(TcType), SYN_IE(TcThetaType), SYN_IE(TcTauType),
45 SYN_IE(TcTyVarSet), SYN_IE(TcTyVar),
46 newTyVarTy, zonkTcType, zonkTcTyVar, zonkTcTyVars,
47 newTcTyVar, tcInstSigType, newTyVarTys
49 import Unify ( unifyTauTy, unifyTauTyLists )
51 import Kind ( isUnboxedTypeKind, mkTypeKind, isTypeKind, mkBoxedTypeKind )
52 import Id ( GenId, idType, mkUserLocal, mkUserId )
53 import IdInfo ( noIdInfo )
54 import Maybes ( maybeToBool, assocMaybe, catMaybes )
55 import Name ( getOccName, getSrcLoc, Name )
56 import PragmaInfo ( PragmaInfo(..) )
58 import Type ( mkTyVarTy, mkTyVarTys, isTyVarTy, tyVarsOfTypes, eqSimpleTheta,
59 mkSigmaTy, splitSigmaTy, mkForAllTys, mkFunTys, getTyVar, mkDictTy,
60 splitRhoTy, mkForAllTy, splitForAllTy )
61 import TyVar ( GenTyVar, SYN_IE(TyVar), tyVarKind, minusTyVarSet, emptyTyVarSet,
62 elementOfTyVarSet, unionTyVarSets, tyVarSetToList )
63 import Bag ( bagToList, foldrBag, isEmptyBag )
64 import Util ( isIn, zipEqual, zipWithEqual, zipWith3Equal, hasNoDups, assoc,
65 assertPanic, panic, pprTrace )
66 import PprType ( GenClass, GenType, GenTyVar )
67 import Unique ( Unique )
68 import SrcLoc ( SrcLoc )
70 import Outputable --( interppSP, interpp'SP )
76 %************************************************************************
78 \subsection{Type-checking bindings}
80 %************************************************************************
82 @tcBindsAndThen@ typechecks a @HsBinds@. The "and then" part is because
83 it needs to know something about the {\em usage} of the things bound,
84 so that it can create specialisations of them. So @tcBindsAndThen@
85 takes a function which, given an extended environment, E, typechecks
86 the scope of the bindings returning a typechecked thing and (most
87 important) an LIE. It is this LIE which is then used as the basis for
88 specialising the things bound.
90 @tcBindsAndThen@ also takes a "combiner" which glues together the
91 bindings and the "thing" to make a new "thing".
93 The real work is done by @tcBindWithSigsAndThen@.
95 Recursive and non-recursive binds are handled in essentially the same
96 way: because of uniques there are no scoping issues left. The only
97 difference is that non-recursive bindings can bind primitive values.
99 Even for non-recursive binding groups we add typings for each binder
100 to the LVE for the following reason. When each individual binding is
101 checked the type of its LHS is unified with that of its RHS; and
102 type-checking the LHS of course requires that the binder is in scope.
104 At the top-level the LIE is sure to contain nothing but constant
105 dictionaries, which we resolve at the module level.
109 :: (RecFlag -> TcMonoBinds s -> thing -> thing) -- Combinator
111 -> TcM s (thing, LIE s)
112 -> TcM s (thing, LIE s)
114 tcBindsAndThen combiner EmptyBinds do_next
115 = do_next `thenTc` \ (thing, lie) ->
116 returnTc (combiner nonRecursive EmptyMonoBinds thing, lie)
118 tcBindsAndThen combiner (ThenBinds binds1 binds2) do_next
119 = tcBindsAndThen combiner binds1 (tcBindsAndThen combiner binds2 do_next)
121 tcBindsAndThen combiner (MonoBind bind sigs is_rec) do_next
122 = fixTc (\ ~(prag_info_fn, _) ->
123 -- This is the usual prag_info fix; the PragmaInfo field of an Id
124 -- is not inspected till ages later in the compiler, so there
125 -- should be no black-hole problems here.
127 -- TYPECHECK THE SIGNATURES
128 mapTc (tcTySig prag_info_fn) ty_sigs `thenTc` \ tc_ty_sigs ->
130 tcBindWithSigs binder_names bind
131 tc_ty_sigs is_rec prag_info_fn `thenTc` \ (poly_binds, poly_lie, poly_ids) ->
133 -- Extend the environment to bind the new polymorphic Ids
134 tcExtendLocalValEnv binder_names poly_ids $
136 -- Build bindings and IdInfos corresponding to user pragmas
137 tcPragmaSigs sigs `thenTc` \ (prag_info_fn, prag_binds, prag_lie) ->
139 -- Now do whatever happens next, in the augmented envt
140 do_next `thenTc` \ (thing, thing_lie) ->
142 -- Create specialisations of functions bound here
143 bindInstsOfLocalFuns (prag_lie `plusLIE` thing_lie)
144 poly_ids `thenTc` \ (lie2, inst_mbinds) ->
148 final_lie = lie2 `plusLIE` poly_lie
149 final_thing = combiner is_rec poly_binds $
150 combiner nonRecursive inst_mbinds $
151 combiner nonRecursive prag_binds
154 returnTc (prag_info_fn, (final_thing, final_lie))
155 ) `thenTc` \ (_, result) ->
158 binder_names = map fst (bagToList (collectMonoBinders bind))
159 ty_sigs = [sig | sig@(Sig name _ _) <- sigs]
162 An aside. The original version of @tcBindsAndThen@ which lacks a
163 combiner function, appears below. Though it is perfectly well
164 behaved, it cannot be typed by Haskell, because the recursive call is
165 at a different type to the definition itself. There aren't too many
166 examples of this, which is why I thought it worth preserving! [SLPJ]
171 -> TcM s (thing, LIE s, thing_ty))
172 -> TcM s ((TcHsBinds s, thing), LIE s, thing_ty)
174 tcBindsAndThen EmptyBinds do_next
175 = do_next `thenTc` \ (thing, lie, thing_ty) ->
176 returnTc ((EmptyBinds, thing), lie, thing_ty)
178 tcBindsAndThen (ThenBinds binds1 binds2) do_next
179 = tcBindsAndThen binds1 (tcBindsAndThen binds2 do_next)
180 `thenTc` \ ((binds1', (binds2', thing')), lie1, thing_ty) ->
182 returnTc ((binds1' `ThenBinds` binds2', thing'), lie1, thing_ty)
184 tcBindsAndThen (MonoBind bind sigs is_rec) do_next
185 = tcBindAndThen bind sigs do_next
189 %************************************************************************
191 \subsection{tcBindWithSigs}
193 %************************************************************************
195 @tcBindWithSigs@ deals with a single binding group. It does generalisation,
196 so all the clever stuff is in here.
198 * binder_names and mbind must define the same set of Names
200 * The Names in tc_ty_sigs must be a subset of binder_names
202 * The Ids in tc_ty_sigs don't necessarily have to have the same name
203 as the Name in the tc_ty_sig
211 -> (Name -> PragmaInfo)
212 -> TcM s (TcMonoBinds s, LIE s, [TcIdBndr s])
214 tcBindWithSigs binder_names mbind tc_ty_sigs is_rec prag_info_fn
216 -- If typechecking the binds fails, then return with each
217 -- signature-less binder given type (forall a.a), to minimise subsequent
219 newTcTyVar mkBoxedTypeKind `thenNF_Tc` \ alpha_tv ->
221 forall_a_a = mkForAllTy alpha_tv (mkTyVarTy alpha_tv)
222 poly_ids = map mk_dummy binder_names
223 mk_dummy name = case maybeSig tc_ty_sigs name of
224 Just (TySigInfo _ poly_id _ _ _ _) -> poly_id -- Signature
225 Nothing -> mkUserId name forall_a_a NoPragmaInfo -- No signature
227 returnTc (EmptyMonoBinds, emptyLIE, poly_ids)
230 -- Create a new identifier for each binder, with each being given
231 -- a fresh unique, and a type-variable type.
232 tcGetUniques no_of_binders `thenNF_Tc` \ uniqs ->
233 mapNF_Tc mk_mono_id_ty binder_names `thenNF_Tc` \ mono_id_tys ->
235 mono_id_tyvars = tyVarsOfTypes mono_id_tys
236 mono_ids = zipWith3Equal "tcBindAndSigs" mk_id binder_names uniqs mono_id_tys
237 mk_id name uniq ty = mkUserLocal (getOccName name) uniq ty (getSrcLoc name)
240 -- TYPECHECK THE BINDINGS
241 tcMonoBinds mbind binder_names mono_ids tc_ty_sigs `thenTc` \ (mbind', lie) ->
243 -- CHECK THAT THE SIGNATURES MATCH
244 -- (must do this before getTyVarsToGen)
245 checkSigMatch tc_ty_sigs `thenTc` \ sig_theta ->
247 -- COMPUTE VARIABLES OVER WHICH TO QUANTIFY, namely tyvars_to_gen
248 -- The tyvars_not_to_gen are free in the environment, and hence
249 -- candidates for generalisation, but sometimes the monomorphism
250 -- restriction means we can't generalise them nevertheless
251 getTyVarsToGen is_unrestricted mono_id_tyvars lie `thenTc` \ (tyvars_not_to_gen, tyvars_to_gen) ->
253 -- DEAL WITH TYPE VARIABLE KINDS
254 mapTc defaultUncommittedTyVar (tyVarSetToList tyvars_to_gen) `thenTc` \ tyvars_to_gen_list ->
255 -- It's important that the final list (tyvars_to_gen_list) is fully
256 -- zonked, *including boxity*, because they'll be included in the forall types of
257 -- the polymorphic Ids, and instances of these Ids will be generated from them.
259 -- This step can do unification => keep other zonking after this
262 tcExtendGlobalTyVars tyvars_not_to_gen (
263 if null tc_ty_sigs then
264 -- No signatures, so just simplify the lie
265 tcSimplify tyvars_to_gen lie `thenTc` \ (lie_free, dict_binds, lie_bound) ->
266 returnTc (lie_free, dict_binds, map instToId (bagToList lie_bound))
269 zonk_theta sig_theta `thenNF_Tc` \ sig_theta' ->
270 newDicts SignatureOrigin sig_theta' `thenNF_Tc` \ (dicts_sig, dict_ids) ->
271 -- It's important that sig_theta is zonked, because
272 -- dict_id is later used to form the type of the polymorphic thing,
273 -- and forall-types must be zonked so far as their bound variables
276 -- Check that the needed dicts can be expressed in
277 -- terms of the signature ones
278 tcAddErrCtxt (sigsCtxt tysig_names) $
279 tcSimplifyAndCheck tyvars_to_gen dicts_sig lie `thenTc` \ (lie_free, dict_binds) ->
280 returnTc (lie_free, dict_binds, dict_ids)
282 ) `thenTc` \ (lie_free, dict_binds, dicts_bound) ->
284 ASSERT( not (any (isUnboxedTypeKind . tyVarKind) tyvars_to_gen_list) )
285 -- The instCantBeGeneralised stuff in tcSimplify should have
286 -- already raised an error if we're trying to generalise an unboxed tyvar
287 -- (NB: unboxed tyvars are always introduced along with a class constraint)
288 -- and it's better done there because we have more precise origin information.
289 -- That's why we just use an ASSERT here.
291 -- BUILD THE POLYMORPHIC RESULT IDs
292 mapNF_Tc zonkTcType mono_id_tys `thenNF_Tc` \ zonked_mono_id_types ->
294 exports = zipWith3 mk_export binder_names mono_ids zonked_mono_id_types
295 dict_tys = map tcIdType dicts_bound
297 mk_export binder_name mono_id zonked_mono_id_ty
298 | maybeToBool maybe_sig = (sig_tyvars, TcId sig_poly_id, TcId mono_id)
299 | otherwise = (tyvars_to_gen_list, TcId poly_id, TcId mono_id)
301 maybe_sig = maybeSig tc_ty_sigs binder_name
302 Just (TySigInfo _ sig_poly_id sig_tyvars _ _ _) = maybe_sig
303 poly_id = mkUserId binder_name poly_ty (prag_info_fn binder_name)
304 poly_ty = mkForAllTys tyvars_to_gen_list $ mkFunTys dict_tys $ zonked_mono_id_ty
305 -- It's important to build a fully-zonked poly_ty, because
306 -- we'll slurp out its free type variables when extending the
307 -- local environment (tcExtendLocalValEnv); if it's not zonked
308 -- it appears to have free tyvars that aren't actually free at all.
313 AbsBinds tyvars_to_gen_list
316 (dict_binds `AndMonoBinds` mbind'),
318 [poly_id | (_, TcId poly_id, _) <- exports]
321 no_of_binders = length binder_names
323 mk_mono_id_ty binder_name = case maybeSig tc_ty_sigs binder_name of
324 Just (TySigInfo name _ _ _ tau_ty _) -> returnNF_Tc tau_ty -- There's a signature
325 otherwise -> newTyVarTy kind -- No signature
327 tysig_names = [name | (TySigInfo name _ _ _ _ _) <- tc_ty_sigs]
328 is_unrestricted = isUnRestrictedGroup tysig_names mbind
330 kind | is_rec = mkBoxedTypeKind -- Recursive, so no unboxed types
331 | otherwise = mkTypeKind -- Non-recursive, so we permit unboxed types
333 zonk_theta theta = mapNF_Tc zonk theta
335 zonk (c,t) = zonkTcType t `thenNF_Tc` \ t' ->
339 @getImplicitStuffToGen@ decides what type variables generalise over.
341 For a "restricted group" -- see the monomorphism restriction
342 for a definition -- we bind no dictionaries, and
343 remove from tyvars_to_gen any constrained type variables
345 *Don't* simplify dicts at this point, because we aren't going
346 to generalise over these dicts. By the time we do simplify them
347 we may well know more. For example (this actually came up)
349 f x = array ... xs where xs = [1,2,3,4,5]
350 We don't want to generate lots of (fromInt Int 1), (fromInt Int 2)
351 stuff. If we simplify only at the f-binding (not the xs-binding)
352 we'll know that the literals are all Ints, and we can just produce
355 Find all the type variables involved in overloading, the
356 "constrained_tyvars". These are the ones we *aren't* going to
357 generalise. We must be careful about doing this:
359 (a) If we fail to generalise a tyvar which is not actually
360 constrained, then it will never, ever get bound, and lands
361 up printed out in interface files! Notorious example:
362 instance Eq a => Eq (Foo a b) where ..
363 Here, b is not constrained, even though it looks as if it is.
364 Another, more common, example is when there's a Method inst in
365 the LIE, whose type might very well involve non-overloaded
368 (b) On the other hand, we mustn't generalise tyvars which are constrained,
369 because we are going to pass on out the unmodified LIE, with those
370 tyvars in it. They won't be in scope if we've generalised them.
372 So we are careful, and do a complete simplification just to find the
373 constrained tyvars. We don't use any of the results, except to
374 find which tyvars are constrained.
377 getTyVarsToGen is_unrestricted mono_tyvars lie
378 = tcGetGlobalTyVars `thenNF_Tc` \ free_tyvars ->
379 zonkTcTyVars mono_tyvars `thenNF_Tc` \ mentioned_tyvars ->
381 tyvars_to_gen = mentioned_tyvars `minusTyVarSet` free_tyvars
385 returnTc (emptyTyVarSet, tyvars_to_gen)
387 tcSimplify tyvars_to_gen lie `thenTc` \ (_, _, constrained_dicts) ->
389 -- ASSERT: dicts_sig is already zonked!
390 constrained_tyvars = foldrBag (unionTyVarSets . tyVarsOfInst) emptyTyVarSet constrained_dicts
391 reduced_tyvars_to_gen = tyvars_to_gen `minusTyVarSet` constrained_tyvars
393 returnTc (constrained_tyvars, reduced_tyvars_to_gen)
398 isUnRestrictedGroup :: [Name] -- Signatures given for these
402 is_elem v vs = isIn "isUnResMono" v vs
404 isUnRestrictedGroup sigs (PatMonoBind (VarPatIn v) _ _) = v `is_elem` sigs
405 isUnRestrictedGroup sigs (PatMonoBind other _ _) = False
406 isUnRestrictedGroup sigs (VarMonoBind v _) = v `is_elem` sigs
407 isUnRestrictedGroup sigs (FunMonoBind _ _ _ _) = True
408 isUnRestrictedGroup sigs (AndMonoBinds mb1 mb2) = isUnRestrictedGroup sigs mb1 &&
409 isUnRestrictedGroup sigs mb2
410 isUnRestrictedGroup sigs EmptyMonoBinds = True
413 @defaultUncommittedTyVar@ checks for generalisation over unboxed
414 types, and defaults any TypeKind TyVars to BoxedTypeKind.
417 defaultUncommittedTyVar tyvar
418 | isTypeKind (tyVarKind tyvar)
419 = newTcTyVar mkBoxedTypeKind `thenNF_Tc` \ boxed_tyvar ->
420 unifyTauTy (mkTyVarTy boxed_tyvar) (mkTyVarTy tyvar) `thenTc_`
428 %************************************************************************
430 \subsection{tcMonoBind}
432 %************************************************************************
434 @tcMonoBinds@ deals with a single @MonoBind@.
435 The signatures have been dealt with already.
438 tcMonoBinds :: RenamedMonoBinds
439 -> [Name] -> [TcIdBndr s]
441 -> TcM s (TcMonoBinds s, LIE s)
443 tcMonoBinds mbind binder_names mono_ids tc_ty_sigs
444 = tcExtendLocalValEnv binder_names mono_ids (
448 sig_names = [name | (TySigInfo name _ _ _ _ _) <- tc_ty_sigs]
449 sig_ids = [id | (TySigInfo _ id _ _ _ _) <- tc_ty_sigs]
451 tc_mono_binds EmptyMonoBinds = returnTc (EmptyMonoBinds, emptyLIE)
453 tc_mono_binds (AndMonoBinds mb1 mb2)
454 = tc_mono_binds mb1 `thenTc` \ (mb1a, lie1) ->
455 tc_mono_binds mb2 `thenTc` \ (mb2a, lie2) ->
456 returnTc (AndMonoBinds mb1a mb2a, lie1 `plusLIE` lie2)
458 tc_mono_binds (FunMonoBind name inf matches locn)
460 tcLookupLocalValueOK "tc_mono_binds" name `thenNF_Tc` \ id ->
462 -- Before checking the RHS, extend the envt with
463 -- bindings for the *polymorphic* Ids from any type signatures
464 tcExtendLocalValEnv sig_names sig_ids $
465 tcMatchesFun name (idType id) matches `thenTc` \ (matches', lie) ->
467 returnTc (FunMonoBind (TcId id) inf matches' locn, lie)
469 tc_mono_binds bind@(PatMonoBind pat grhss_and_binds locn)
471 tcPat pat `thenTc` \ (pat2, lie_pat, pat_ty) ->
472 tcExtendLocalValEnv sig_names sig_ids $
473 tcGRHSsAndBinds grhss_and_binds `thenTc` \ (grhss_and_binds2, lie, grhss_ty) ->
474 tcAddErrCtxt (patMonoBindsCtxt bind) $
475 unifyTauTy pat_ty grhss_ty `thenTc_`
476 returnTc (PatMonoBind pat2 grhss_and_binds2 locn,
480 %************************************************************************
482 \subsection{Signatures}
484 %************************************************************************
486 @tcSigs@ checks the signatures for validity, and returns a list of
487 {\em freshly-instantiated} signatures. That is, the types are already
488 split up, and have fresh type variables installed. All non-type-signature
489 "RenamedSigs" are ignored.
491 The @TcSigInfo@ contains @TcTypes@ because they are unified with
492 the variable's type, and after that checked to see whether they've
498 Name -- N, the Name in corresponding binding
499 (TcIdBndr s) -- *Polymorphic* binder for this value...
500 -- Usually has name = N, but doesn't have to.
507 maybeSig :: [TcSigInfo s] -> Name -> Maybe (TcSigInfo s)
508 -- Search for a particular signature
509 maybeSig [] name = Nothing
510 maybeSig (sig@(TySigInfo sig_name _ _ _ _ _) : sigs) name
511 | name == sig_name = Just sig
512 | otherwise = maybeSig sigs name
517 tcTySig :: (Name -> PragmaInfo)
519 -> TcM s (TcSigInfo s)
521 tcTySig prag_info_fn (Sig v ty src_loc)
522 = tcAddSrcLoc src_loc $
523 tcHsType ty `thenTc` \ sigma_ty ->
524 tcInstSigType sigma_ty `thenNF_Tc` \ sigma_ty' ->
526 poly_id = mkUserId v sigma_ty' (prag_info_fn v)
527 (tyvars', theta', tau') = splitSigmaTy sigma_ty'
528 -- This splitSigmaTy tries hard to make sure that tau' is a type synonym
529 -- wherever possible, which can improve interface files.
531 returnTc (TySigInfo v poly_id tyvars' theta' tau' src_loc)
534 @checkSigMatch@ does the next step in checking signature matching.
535 The tau-type part has already been unified. What we do here is to
536 check that this unification has not over-constrained the (polymorphic)
537 type variables of the original signature type.
539 The error message here is somewhat unsatisfactory, but it'll do for
544 = returnTc (error "checkSigMatch")
546 checkSigMatch tc_ty_sigs@( sig1@(TySigInfo _ id1 _ theta1 _ _) : all_sigs_but_first )
547 = -- CHECK THAT THE SIGNATURE TYVARS AND TAU_TYPES ARE OK
548 -- Doesn't affect substitution
549 mapTc check_one_sig tc_ty_sigs `thenTc_`
551 -- CHECK THAT ALL THE SIGNATURE CONTEXTS ARE UNIFIABLE
552 -- The type signatures on a mutually-recursive group of definitions
553 -- must all have the same context (or none).
555 -- We unify them because, with polymorphic recursion, their types
556 -- might not otherwise be related. This is a rather subtle issue.
558 mapTc check_one_cxt all_sigs_but_first `thenTc_`
562 sig1_dict_tys = mk_dict_tys theta1
563 n_sig1_dict_tys = length sig1_dict_tys
565 check_one_cxt sig@(TySigInfo _ id _ theta _ src_loc)
566 = tcAddSrcLoc src_loc $
567 tcAddErrCtxt (sigContextsCtxt id1 id) $
568 checkTc (length this_sig_dict_tys == n_sig1_dict_tys)
569 sigContextsErr `thenTc_`
570 unifyTauTyLists sig1_dict_tys this_sig_dict_tys
572 this_sig_dict_tys = mk_dict_tys theta
574 check_one_sig (TySigInfo name id sig_tyvars _ sig_tau src_loc)
575 = tcAddSrcLoc src_loc $
576 tcAddErrCtxt (sigCtxt id) $
577 checkSigTyVars sig_tyvars sig_tau
579 mk_dict_tys theta = [mkDictTy c t | (c,t) <- theta]
583 @checkSigTyVars@ is used after the type in a type signature has been unified with
584 the actual type found. It then checks that the type variables of the type signature
586 (a) still all type variables
587 eg matching signature [a] against inferred type [(p,q)]
588 [then a will be unified to a non-type variable]
590 (b) still all distinct
591 eg matching signature [(a,b)] against inferred type [(p,p)]
592 [then a and b will be unified together]
594 BUT ACTUALLY THESE FIRST TWO ARE FORCED BY USING DontBind TYVARS
596 (c) not mentioned in the environment
597 eg the signature for f in this:
603 Here, f is forced to be monorphic by the free occurence of x.
605 Before doing this, the substitution is applied to the signature type variable.
608 checkSigTyVars :: [TcTyVar s] -- The original signature type variables
609 -> TcType s -- signature type (for err msg)
612 checkSigTyVars sig_tyvars sig_tau
613 = tcGetGlobalTyVars `thenNF_Tc` \ globals ->
615 mono_tyvars = filter (`elementOfTyVarSet` globals) sig_tyvars
618 -- Until the final Bind-handling stuff is in, several type signatures in the same
619 -- bindings group can cause the signature type variable from the different
620 -- signatures to be unified. So we still need to zonk and check point (b).
621 -- Remove when activating the new binding code
622 mapNF_Tc zonkTcTyVar sig_tyvars `thenNF_Tc` \ sig_tys ->
623 checkTcM (hasNoDups (map (getTyVar "checkSigTyVars") sig_tys))
624 (zonkTcType sig_tau `thenNF_Tc` \ sig_tau' ->
625 failTc (badMatchErr sig_tau sig_tau')
630 -- We want to report errors in terms of the original signature tyvars,
631 -- ie sig_tyvars, NOT sig_tyvars'. sig_tys and sig_tyvars' correspond
632 -- 1-1 with sig_tyvars, so we can just map back.
633 checkTc (null mono_tyvars)
634 (notAsPolyAsSigErr sig_tau mono_tyvars)
638 %************************************************************************
640 \subsection{SPECIALIZE pragmas}
642 %************************************************************************
645 @tcPragmaSigs@ munches up the "signatures" that arise through *user*
646 pragmas. It is convenient for them to appear in the @[RenamedSig]@
647 part of a binding because then the same machinery can be used for
648 moving them into place as is done for type signatures.
651 tcPragmaSigs :: [RenamedSig] -- The pragma signatures
652 -> TcM s (Name -> PragmaInfo, -- Maps name to the appropriate PragmaInfo
656 -- For now we just deal with INLINE pragmas
657 tcPragmaSigs sigs = returnTc (prag_fn, EmptyMonoBinds, emptyLIE )
659 prag_fn name | any has_inline sigs = IWantToBeINLINEd
660 | otherwise = NoPragmaInfo
662 has_inline (InlineSig n _) = (n == name)
663 has_inline other = False
668 = mapAndUnzip3Tc tcPragmaSig sigs `thenTc` \ (names_w_id_infos, binds, lies) ->
670 name_to_info name = foldr ($) noIdInfo
671 [info_fn | (n,info_fn) <- names_w_id_infos, n==name]
673 returnTc (name_to_info,
674 foldr ThenBinds EmptyBinds binds,
675 foldr plusLIE emptyLIE lies)
678 Here are the easy cases for tcPragmaSigs
681 tcPragmaSig (DeforestSig name loc)
682 = returnTc ((name, addDeforestInfo DoDeforest),EmptyBinds,emptyLIE)
683 tcPragmaSig (InlineSig name loc)
684 = returnTc ((name, addUnfoldInfo (iWantToBeINLINEd UnfoldAlways)), EmptyBinds, emptyLIE)
685 tcPragmaSig (MagicUnfoldingSig name string loc)
686 = returnTc ((name, addUnfoldInfo (mkMagicUnfolding string)), EmptyBinds, emptyLIE)
689 The interesting case is for SPECIALISE pragmas. There are two forms.
690 Here's the first form:
692 f :: Ord a => [a] -> b -> b
693 {-# SPECIALIZE f :: [Int] -> b -> b #-}
696 For this we generate:
698 f* = /\ b -> let d1 = ...
702 where f* is a SpecPragmaId. The **sole** purpose of SpecPragmaIds is to
703 retain a right-hand-side that the simplifier will otherwise discard as
704 dead code... the simplifier has a flag that tells it not to discard
705 SpecPragmaId bindings.
707 In this case the f* retains a call-instance of the overloaded
708 function, f, (including appropriate dictionaries) so that the
709 specialiser will subsequently discover that there's a call of @f@ at
710 Int, and will create a specialisation for @f@. After that, the
711 binding for @f*@ can be discarded.
713 The second form is this:
715 f :: Ord a => [a] -> b -> b
716 {-# SPECIALIZE f :: [Int] -> b -> b = g #-}
719 Here @g@ is specified as a function that implements the specialised
720 version of @f@. Suppose that g has type (a->b->b); that is, g's type
721 is more general than that required. For this we generate
723 f@Int = /\b -> g Int b
727 Here @f@@Int@ is a SpecId, the specialised version of @f@. It inherits
728 f's export status etc. @f*@ is a SpecPragmaId, as before, which just serves
729 to prevent @f@@Int@ from being discarded prematurely. After specialisation,
730 if @f@@Int@ is going to be used at all it will be used explicitly, so the simplifier can
731 discard the f* binding.
733 Actually, there is really only point in giving a SPECIALISE pragma on exported things,
734 and the simplifer won't discard SpecIds for exporte things anyway, so maybe this is
738 tcPragmaSig (SpecSig name poly_ty maybe_spec_name src_loc)
739 = tcAddSrcLoc src_loc $
740 tcAddErrCtxt (valSpecSigCtxt name spec_ty) $
742 -- Get and instantiate its alleged specialised type
743 tcHsType poly_ty `thenTc` \ sig_sigma ->
744 tcInstSigType sig_sigma `thenNF_Tc` \ sig_ty ->
746 (sig_tyvars, sig_theta, sig_tau) = splitSigmaTy sig_ty
747 origin = ValSpecOrigin name
750 -- Check that the SPECIALIZE pragma had an empty context
751 checkTc (null sig_theta)
752 (panic "SPECIALIZE non-empty context (ToDo: msg)") `thenTc_`
754 -- Get and instantiate the type of the id mentioned
755 tcLookupLocalValueOK "tcPragmaSig" name `thenNF_Tc` \ main_id ->
756 tcInstSigType [] (idType main_id) `thenNF_Tc` \ main_ty ->
758 (main_tyvars, main_rho) = splitForAllTy main_ty
759 (main_theta,main_tau) = splitRhoTy main_rho
760 main_arg_tys = mkTyVarTys main_tyvars
763 -- Check that the specialised type is indeed an instance of
764 -- the type of the main function.
765 unifyTauTy sig_tau main_tau `thenTc_`
766 checkSigTyVars sig_tyvars sig_tau `thenTc_`
768 -- Check that the type variables of the polymorphic function are
769 -- either left polymorphic, or instantiate to ground type.
770 -- Also check that the overloaded type variables are instantiated to
771 -- ground type; or equivalently that all dictionaries have ground type
772 mapTc zonkTcType main_arg_tys `thenNF_Tc` \ main_arg_tys' ->
773 zonkTcThetaType main_theta `thenNF_Tc` \ main_theta' ->
774 tcAddErrCtxt (specGroundnessCtxt main_arg_tys')
775 (checkTc (all isGroundOrTyVarTy main_arg_tys')) `thenTc_`
776 tcAddErrCtxt (specContextGroundnessCtxt main_theta')
777 (checkTc (and [isGroundTy ty | (_,ty) <- theta'])) `thenTc_`
779 -- Build the SpecPragmaId; it is the thing that makes sure we
780 -- don't prematurely dead-code-eliminate the binding we are really interested in.
781 newSpecPragmaId name sig_ty `thenNF_Tc` \ spec_pragma_id ->
783 -- Build a suitable binding; depending on whether we were given
784 -- a value (Maybe Name) to be used as the specialisation.
786 Nothing -> -- No implementation function specified
788 -- Make a Method inst for the occurrence of the overloaded function
789 newMethodWithGivenTy (OccurrenceOf name)
790 (TcId main_id) main_arg_tys main_rho `thenNF_Tc` \ (lie, meth_id) ->
793 pseudo_bind = VarMonoBind spec_pragma_id pseudo_rhs
794 pseudo_rhs = mkHsTyLam sig_tyvars (HsVar (TcId meth_id))
796 returnTc (pseudo_bind, lie, \ info -> info)
798 Just spec_name -> -- Use spec_name as the specialisation value ...
800 -- Type check a simple occurrence of the specialised Id
801 tcId spec_name `thenTc` \ (spec_body, spec_lie, spec_tau) ->
803 -- Check that it has the correct type, and doesn't constrain the
804 -- signature variables at all
805 unifyTauTy sig_tau spec_tau `thenTc_`
806 checkSigTyVars sig_tyvars sig_tau `thenTc_`
808 -- Make a local SpecId to bind to applied spec_id
809 newSpecId main_id main_arg_tys sig_ty `thenNF_Tc` \ local_spec_id ->
812 spec_rhs = mkHsTyLam sig_tyvars spec_body
813 spec_binds = VarMonoBind local_spec_id spec_rhs
815 VarMonoBind spec_pragma_id (HsVar (TcId local_spec_id))
816 spec_info = SpecInfo spec_tys (length main_theta) local_spec_id
818 returnTc ((name, addSpecInfo spec_info), spec_binds, spec_lie)
823 %************************************************************************
825 \subsection[TcBinds-errors]{Error contexts and messages}
827 %************************************************************************
831 patMonoBindsCtxt bind sty
832 = hang (ptext SLIT("In a pattern binding:")) 4 (ppr sty bind)
834 -----------------------------------------------
835 valSpecSigCtxt v ty sty
836 = hang (ptext SLIT("In a SPECIALIZE pragma for a value:"))
837 4 (sep [(<>) (ppr sty v) (ptext SLIT(" ::")),
842 -----------------------------------------------
843 notAsPolyAsSigErr sig_tau mono_tyvars sty
844 = hang (ptext SLIT("A type signature is more polymorphic than the inferred type"))
845 4 (vcat [text "Some type variables in the inferred type can't be forall'd, namely:",
846 interpp'SP sty mono_tyvars,
847 ptext SLIT("Possible cause: the RHS mentions something subject to the monomorphism restriction")
850 -----------------------------------------------
851 badMatchErr sig_ty inferred_ty sty
852 = hang (ptext SLIT("Type signature doesn't match inferred type"))
853 4 (vcat [hang (ptext SLIT("Signature:")) 4 (ppr sty sig_ty),
854 hang (ptext SLIT("Inferred :")) 4 (ppr sty inferred_ty)
857 -----------------------------------------------
859 = sep [ptext SLIT("When checking signature for"), ppr sty id]
861 = sep [ptext SLIT("When checking signature(s) for:"), interpp'SP sty ids]
863 -----------------------------------------------
865 = ptext SLIT("Mismatched contexts")
866 sigContextsCtxt s1 s2 sty
867 = hang (hsep [ptext SLIT("When matching the contexts of the signatures for"),
868 ppr sty s1, ptext SLIT("and"), ppr sty s2])
869 4 (ptext SLIT("(the signature contexts in a mutually recursive group should all be identical)"))
871 -----------------------------------------------
873 = panic "specGroundnessCtxt"
875 --------------------------------------------
876 specContextGroundnessCtxt -- err_ctxt dicts sty
877 = panic "specContextGroundnessCtxt"
880 sep [hsep [ptext SLIT("In the SPECIALIZE pragma for"), ppr sty name],
881 hcat [ptext SLIT(" specialised to the type"), ppr sty spec_ty],
883 ptext SLIT("... not all overloaded type variables were instantiated"),
884 ptext SLIT("to ground types:")])
885 4 (vcat [hsep [ppr sty c, ppr sty t]
886 | (c,t) <- map getDictClassAndType dicts])
888 (name, spec_ty, locn, pp_spec_id)
890 ValSpecSigCtxt n ty loc -> (n, ty, loc, \ x -> empty)
891 ValSpecSpecIdCtxt n ty spec loc ->
893 \ sty -> hsep [ptext SLIT("... type of explicit id"), ppr sty spec])