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 :: (TcHsBinds 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 EmptyBinds 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_binds = MonoBind poly_binds [] is_rec `ThenBinds`
150 MonoBind inst_mbinds [] nonRecursive `ThenBinds`
153 returnTc (prag_info_fn, (combiner final_binds thing, final_lie))
154 ) `thenTc` \ (_, result) ->
157 binder_names = map fst (bagToList (collectMonoBinders bind))
158 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 (TcIdBndr s) -- *Polymorphic* binder for this value...
499 [TcTyVar s] (TcThetaType s) (TcTauType s)
503 maybeSig :: [TcSigInfo s] -> Name -> Maybe (TcSigInfo s)
504 -- Search for a particular signature
505 maybeSig [] name = Nothing
506 maybeSig (sig@(TySigInfo sig_name _ _ _ _ _) : sigs) name
507 | name == sig_name = Just sig
508 | otherwise = maybeSig sigs name
513 tcTySig :: (Name -> PragmaInfo)
515 -> TcM s (TcSigInfo s)
517 tcTySig prag_info_fn (Sig v ty src_loc)
518 = tcAddSrcLoc src_loc $
519 tcHsType ty `thenTc` \ sigma_ty ->
520 tcInstSigType sigma_ty `thenNF_Tc` \ sigma_ty' ->
522 poly_id = mkUserId v sigma_ty' (prag_info_fn v)
523 (tyvars', theta', tau') = splitSigmaTy sigma_ty'
524 -- This splitSigmaTy tries hard to make sure that tau' is a type synonym
525 -- wherever possible, which can improve interface files.
527 returnTc (TySigInfo v poly_id tyvars' theta' tau' src_loc)
530 @checkSigMatch@ does the next step in checking signature matching.
531 The tau-type part has already been unified. What we do here is to
532 check that this unification has not over-constrained the (polymorphic)
533 type variables of the original signature type.
535 The error message here is somewhat unsatisfactory, but it'll do for
540 = returnTc (error "checkSigMatch")
542 checkSigMatch tc_ty_sigs@( sig1@(TySigInfo _ id1 _ theta1 _ _) : all_sigs_but_first )
543 = -- CHECK THAT THE SIGNATURE TYVARS AND TAU_TYPES ARE OK
544 -- Doesn't affect substitution
545 mapTc check_one_sig tc_ty_sigs `thenTc_`
547 -- CHECK THAT ALL THE SIGNATURE CONTEXTS ARE UNIFIABLE
548 -- The type signatures on a mutually-recursive group of definitions
549 -- must all have the same context (or none).
551 -- We unify them because, with polymorphic recursion, their types
552 -- might not otherwise be related. This is a rather subtle issue.
554 mapTc check_one_cxt all_sigs_but_first `thenTc_`
558 sig1_dict_tys = mk_dict_tys theta1
559 n_sig1_dict_tys = length sig1_dict_tys
561 check_one_cxt sig@(TySigInfo _ id _ theta _ src_loc)
562 = tcAddSrcLoc src_loc $
563 tcAddErrCtxt (sigContextsCtxt id1 id) $
564 checkTc (length this_sig_dict_tys == n_sig1_dict_tys)
565 sigContextsErr `thenTc_`
566 unifyTauTyLists sig1_dict_tys this_sig_dict_tys
568 this_sig_dict_tys = mk_dict_tys theta
570 check_one_sig (TySigInfo name id sig_tyvars _ sig_tau src_loc)
571 = tcAddSrcLoc src_loc $
572 tcAddErrCtxt (sigCtxt id) $
573 checkSigTyVars sig_tyvars sig_tau
575 mk_dict_tys theta = [mkDictTy c t | (c,t) <- theta]
579 @checkSigTyVars@ is used after the type in a type signature has been unified with
580 the actual type found. It then checks that the type variables of the type signature
582 (a) still all type variables
583 eg matching signature [a] against inferred type [(p,q)]
584 [then a will be unified to a non-type variable]
586 (b) still all distinct
587 eg matching signature [(a,b)] against inferred type [(p,p)]
588 [then a and b will be unified together]
590 BUT ACTUALLY THESE FIRST TWO ARE FORCED BY USING DontBind TYVARS
592 (c) not mentioned in the environment
593 eg the signature for f in this:
599 Here, f is forced to be monorphic by the free occurence of x.
601 Before doing this, the substitution is applied to the signature type variable.
604 checkSigTyVars :: [TcTyVar s] -- The original signature type variables
605 -> TcType s -- signature type (for err msg)
608 checkSigTyVars sig_tyvars sig_tau
609 = tcGetGlobalTyVars `thenNF_Tc` \ globals ->
611 mono_tyvars = filter (`elementOfTyVarSet` globals) sig_tyvars
614 -- Until the final Bind-handling stuff is in, several type signatures in the same
615 -- bindings group can cause the signature type variable from the different
616 -- signatures to be unified. So we still need to zonk and check point (b).
617 -- Remove when activating the new binding code
618 mapNF_Tc zonkTcTyVar sig_tyvars `thenNF_Tc` \ sig_tys ->
619 checkTcM (hasNoDups (map (getTyVar "checkSigTyVars") sig_tys))
620 (zonkTcType sig_tau `thenNF_Tc` \ sig_tau' ->
621 failTc (badMatchErr sig_tau sig_tau')
626 -- We want to report errors in terms of the original signature tyvars,
627 -- ie sig_tyvars, NOT sig_tyvars'. sig_tys and sig_tyvars' correspond
628 -- 1-1 with sig_tyvars, so we can just map back.
629 checkTc (null mono_tyvars)
630 (notAsPolyAsSigErr sig_tau mono_tyvars)
634 %************************************************************************
636 \subsection{SPECIALIZE pragmas}
638 %************************************************************************
641 @tcPragmaSigs@ munches up the "signatures" that arise through *user*
642 pragmas. It is convenient for them to appear in the @[RenamedSig]@
643 part of a binding because then the same machinery can be used for
644 moving them into place as is done for type signatures.
647 tcPragmaSigs :: [RenamedSig] -- The pragma signatures
648 -> TcM s (Name -> PragmaInfo, -- Maps name to the appropriate PragmaInfo
652 -- For now we just deal with INLINE pragmas
653 tcPragmaSigs sigs = returnTc (prag_fn, EmptyBinds, emptyLIE )
655 prag_fn name | any has_inline sigs = IWantToBeINLINEd
656 | otherwise = NoPragmaInfo
658 has_inline (InlineSig n _) = (n == name)
659 has_inline other = False
664 = mapAndUnzip3Tc tcPragmaSig sigs `thenTc` \ (names_w_id_infos, binds, lies) ->
666 name_to_info name = foldr ($) noIdInfo
667 [info_fn | (n,info_fn) <- names_w_id_infos, n==name]
669 returnTc (name_to_info,
670 foldr ThenBinds EmptyBinds binds,
671 foldr plusLIE emptyLIE lies)
674 Here are the easy cases for tcPragmaSigs
677 tcPragmaSig (DeforestSig name loc)
678 = returnTc ((name, addDeforestInfo DoDeforest),EmptyBinds,emptyLIE)
679 tcPragmaSig (InlineSig name loc)
680 = returnTc ((name, addUnfoldInfo (iWantToBeINLINEd UnfoldAlways)), EmptyBinds, emptyLIE)
681 tcPragmaSig (MagicUnfoldingSig name string loc)
682 = returnTc ((name, addUnfoldInfo (mkMagicUnfolding string)), EmptyBinds, emptyLIE)
685 The interesting case is for SPECIALISE pragmas. There are two forms.
686 Here's the first form:
688 f :: Ord a => [a] -> b -> b
689 {-# SPECIALIZE f :: [Int] -> b -> b #-}
692 For this we generate:
694 f* = /\ b -> let d1 = ...
698 where f* is a SpecPragmaId. The **sole** purpose of SpecPragmaIds is to
699 retain a right-hand-side that the simplifier will otherwise discard as
700 dead code... the simplifier has a flag that tells it not to discard
701 SpecPragmaId bindings.
703 In this case the f* retains a call-instance of the overloaded
704 function, f, (including appropriate dictionaries) so that the
705 specialiser will subsequently discover that there's a call of @f@ at
706 Int, and will create a specialisation for @f@. After that, the
707 binding for @f*@ can be discarded.
709 The second form is this:
711 f :: Ord a => [a] -> b -> b
712 {-# SPECIALIZE f :: [Int] -> b -> b = g #-}
715 Here @g@ is specified as a function that implements the specialised
716 version of @f@. Suppose that g has type (a->b->b); that is, g's type
717 is more general than that required. For this we generate
719 f@Int = /\b -> g Int b
723 Here @f@@Int@ is a SpecId, the specialised version of @f@. It inherits
724 f's export status etc. @f*@ is a SpecPragmaId, as before, which just serves
725 to prevent @f@@Int@ from being discarded prematurely. After specialisation,
726 if @f@@Int@ is going to be used at all it will be used explicitly, so the simplifier can
727 discard the f* binding.
729 Actually, there is really only point in giving a SPECIALISE pragma on exported things,
730 and the simplifer won't discard SpecIds for exporte things anyway, so maybe this is
734 tcPragmaSig (SpecSig name poly_ty maybe_spec_name src_loc)
735 = tcAddSrcLoc src_loc $
736 tcAddErrCtxt (valSpecSigCtxt name spec_ty) $
738 -- Get and instantiate its alleged specialised type
739 tcHsType poly_ty `thenTc` \ sig_sigma ->
740 tcInstSigType sig_sigma `thenNF_Tc` \ sig_ty ->
742 (sig_tyvars, sig_theta, sig_tau) = splitSigmaTy sig_ty
743 origin = ValSpecOrigin name
746 -- Check that the SPECIALIZE pragma had an empty context
747 checkTc (null sig_theta)
748 (panic "SPECIALIZE non-empty context (ToDo: msg)") `thenTc_`
750 -- Get and instantiate the type of the id mentioned
751 tcLookupLocalValueOK "tcPragmaSig" name `thenNF_Tc` \ main_id ->
752 tcInstSigType [] (idType main_id) `thenNF_Tc` \ main_ty ->
754 (main_tyvars, main_rho) = splitForAllTy main_ty
755 (main_theta,main_tau) = splitRhoTy main_rho
756 main_arg_tys = mkTyVarTys main_tyvars
759 -- Check that the specialised type is indeed an instance of
760 -- the type of the main function.
761 unifyTauTy sig_tau main_tau `thenTc_`
762 checkSigTyVars sig_tyvars sig_tau `thenTc_`
764 -- Check that the type variables of the polymorphic function are
765 -- either left polymorphic, or instantiate to ground type.
766 -- Also check that the overloaded type variables are instantiated to
767 -- ground type; or equivalently that all dictionaries have ground type
768 mapTc zonkTcType main_arg_tys `thenNF_Tc` \ main_arg_tys' ->
769 zonkTcThetaType main_theta `thenNF_Tc` \ main_theta' ->
770 tcAddErrCtxt (specGroundnessCtxt main_arg_tys')
771 (checkTc (all isGroundOrTyVarTy main_arg_tys')) `thenTc_`
772 tcAddErrCtxt (specContextGroundnessCtxt main_theta')
773 (checkTc (and [isGroundTy ty | (_,ty) <- theta'])) `thenTc_`
775 -- Build the SpecPragmaId; it is the thing that makes sure we
776 -- don't prematurely dead-code-eliminate the binding we are really interested in.
777 newSpecPragmaId name sig_ty `thenNF_Tc` \ spec_pragma_id ->
779 -- Build a suitable binding; depending on whether we were given
780 -- a value (Maybe Name) to be used as the specialisation.
782 Nothing -> -- No implementation function specified
784 -- Make a Method inst for the occurrence of the overloaded function
785 newMethodWithGivenTy (OccurrenceOf name)
786 (TcId main_id) main_arg_tys main_rho `thenNF_Tc` \ (lie, meth_id) ->
789 pseudo_bind = VarMonoBind spec_pragma_id pseudo_rhs
790 pseudo_rhs = mkHsTyLam sig_tyvars (HsVar (TcId meth_id))
792 returnTc (pseudo_bind, lie, \ info -> info)
794 Just spec_name -> -- Use spec_name as the specialisation value ...
796 -- Type check a simple occurrence of the specialised Id
797 tcId spec_name `thenTc` \ (spec_body, spec_lie, spec_tau) ->
799 -- Check that it has the correct type, and doesn't constrain the
800 -- signature variables at all
801 unifyTauTy sig_tau spec_tau `thenTc_`
802 checkSigTyVars sig_tyvars sig_tau `thenTc_`
804 -- Make a local SpecId to bind to applied spec_id
805 newSpecId main_id main_arg_tys sig_ty `thenNF_Tc` \ local_spec_id ->
808 spec_rhs = mkHsTyLam sig_tyvars spec_body
809 spec_binds = VarMonoBind local_spec_id spec_rhs
811 VarMonoBind spec_pragma_id (HsVar (TcId local_spec_id))
812 spec_info = SpecInfo spec_tys (length main_theta) local_spec_id
814 returnTc ((name, addSpecInfo spec_info), spec_binds, spec_lie)
819 %************************************************************************
821 \subsection[TcBinds-errors]{Error contexts and messages}
823 %************************************************************************
827 patMonoBindsCtxt bind sty
828 = hang (ptext SLIT("In a pattern binding:")) 4 (ppr sty bind)
830 -----------------------------------------------
831 valSpecSigCtxt v ty sty
832 = hang (ptext SLIT("In a SPECIALIZE pragma for a value:"))
833 4 (sep [(<>) (ppr sty v) (ptext SLIT(" ::")),
838 -----------------------------------------------
839 notAsPolyAsSigErr sig_tau mono_tyvars sty
840 = hang (ptext SLIT("A type signature is more polymorphic than the inferred type"))
841 4 (vcat [text "Some type variables in the inferred type can't be forall'd, namely:",
842 interpp'SP sty mono_tyvars,
843 ptext SLIT("Possible cause: the RHS mentions something subject to the monomorphism restriction")
846 -----------------------------------------------
847 badMatchErr sig_ty inferred_ty sty
848 = hang (ptext SLIT("Type signature doesn't match inferred type"))
849 4 (vcat [hang (ptext SLIT("Signature:")) 4 (ppr sty sig_ty),
850 hang (ptext SLIT("Inferred :")) 4 (ppr sty inferred_ty)
853 -----------------------------------------------
855 = sep [ptext SLIT("When checking signature for"), ppr sty id]
857 = sep [ptext SLIT("When checking signature(s) for:"), interpp'SP sty ids]
859 -----------------------------------------------
861 = ptext SLIT("Mismatched contexts")
862 sigContextsCtxt s1 s2 sty
863 = hang (hsep [ptext SLIT("When matching the contexts of the signatures for"),
864 ppr sty s1, ptext SLIT("and"), ppr sty s2])
865 4 (ptext SLIT("(the signature contexts in a mutually recursive group should all be identical)"))
867 -----------------------------------------------
869 = panic "specGroundnessCtxt"
871 --------------------------------------------
872 specContextGroundnessCtxt -- err_ctxt dicts sty
873 = panic "specContextGroundnessCtxt"
876 sep [hsep [ptext SLIT("In the SPECIALIZE pragma for"), ppr sty name],
877 hcat [ptext SLIT(" specialised to the type"), ppr sty spec_ty],
879 ptext SLIT("... not all overloaded type variables were instantiated"),
880 ptext SLIT("to ground types:")])
881 4 (vcat [hsep [ppr sty c, ppr sty t]
882 | (c,t) <- map getDictClassAndType dicts])
884 (name, spec_ty, locn, pp_spec_id)
886 ValSpecSigCtxt n ty loc -> (n, ty, loc, \ x -> empty)
887 ValSpecSpecIdCtxt n ty spec loc ->
889 \ sty -> hsep [ptext SLIT("... type of explicit id"), ppr sty spec])