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 )
72 %************************************************************************
74 \subsection{Type-checking bindings}
76 %************************************************************************
78 @tcBindsAndThen@ typechecks a @HsBinds@. The "and then" part is because
79 it needs to know something about the {\em usage} of the things bound,
80 so that it can create specialisations of them. So @tcBindsAndThen@
81 takes a function which, given an extended environment, E, typechecks
82 the scope of the bindings returning a typechecked thing and (most
83 important) an LIE. It is this LIE which is then used as the basis for
84 specialising the things bound.
86 @tcBindsAndThen@ also takes a "combiner" which glues together the
87 bindings and the "thing" to make a new "thing".
89 The real work is done by @tcBindWithSigsAndThen@.
91 Recursive and non-recursive binds are handled in essentially the same
92 way: because of uniques there are no scoping issues left. The only
93 difference is that non-recursive bindings can bind primitive values.
95 Even for non-recursive binding groups we add typings for each binder
96 to the LVE for the following reason. When each individual binding is
97 checked the type of its LHS is unified with that of its RHS; and
98 type-checking the LHS of course requires that the binder is in scope.
100 At the top-level the LIE is sure to contain nothing but constant
101 dictionaries, which we resolve at the module level.
105 :: (TcHsBinds s -> thing -> thing) -- Combinator
107 -> TcM s (thing, LIE s)
108 -> TcM s (thing, LIE s)
110 tcBindsAndThen combiner EmptyBinds do_next
111 = do_next `thenTc` \ (thing, lie) ->
112 returnTc (combiner EmptyBinds thing, lie)
114 tcBindsAndThen combiner (ThenBinds binds1 binds2) do_next
115 = tcBindsAndThen combiner binds1 (tcBindsAndThen combiner binds2 do_next)
117 tcBindsAndThen combiner (MonoBind bind sigs is_rec) do_next
118 = fixTc (\ ~(prag_info_fn, _) ->
119 -- This is the usual prag_info fix; the PragmaInfo field of an Id
120 -- is not inspected till ages later in the compiler, so there
121 -- should be no black-hole problems here.
123 -- TYPECHECK THE SIGNATURES
124 mapTc (tcTySig prag_info_fn) ty_sigs `thenTc` \ tc_ty_sigs ->
126 tcBindWithSigs binder_names bind
127 tc_ty_sigs is_rec prag_info_fn `thenTc` \ (poly_binds, poly_lie, poly_ids) ->
129 -- Extend the environment to bind the new polymorphic Ids
130 tcExtendLocalValEnv binder_names poly_ids $
132 -- Build bindings and IdInfos corresponding to user pragmas
133 tcPragmaSigs sigs `thenTc` \ (prag_info_fn, prag_binds, prag_lie) ->
135 -- Now do whatever happens next, in the augmented envt
136 do_next `thenTc` \ (thing, thing_lie) ->
138 -- Create specialisations of functions bound here
139 bindInstsOfLocalFuns (prag_lie `plusLIE` thing_lie)
140 poly_ids `thenTc` \ (lie2, inst_mbinds) ->
144 final_lie = lie2 `plusLIE` poly_lie
145 final_binds = MonoBind poly_binds [] is_rec `ThenBinds`
146 MonoBind inst_mbinds [] nonRecursive `ThenBinds`
149 returnTc (prag_info_fn, (combiner final_binds thing, final_lie))
150 ) `thenTc` \ (_, result) ->
153 binder_names = map fst (bagToList (collectMonoBinders bind))
154 ty_sigs = [sig | sig@(Sig name _ _) <- sigs]
158 An aside. The original version of @tcBindsAndThen@ which lacks a
159 combiner function, appears below. Though it is perfectly well
160 behaved, it cannot be typed by Haskell, because the recursive call is
161 at a different type to the definition itself. There aren't too many
162 examples of this, which is why I thought it worth preserving! [SLPJ]
167 -> TcM s (thing, LIE s, thing_ty))
168 -> TcM s ((TcHsBinds s, thing), LIE s, thing_ty)
170 tcBindsAndThen EmptyBinds do_next
171 = do_next `thenTc` \ (thing, lie, thing_ty) ->
172 returnTc ((EmptyBinds, thing), lie, thing_ty)
174 tcBindsAndThen (ThenBinds binds1 binds2) do_next
175 = tcBindsAndThen binds1 (tcBindsAndThen binds2 do_next)
176 `thenTc` \ ((binds1', (binds2', thing')), lie1, thing_ty) ->
178 returnTc ((binds1' `ThenBinds` binds2', thing'), lie1, thing_ty)
180 tcBindsAndThen (MonoBind bind sigs is_rec) do_next
181 = tcBindAndThen bind sigs do_next
185 %************************************************************************
187 \subsection{tcBindWithSigs}
189 %************************************************************************
191 @tcBindWithSigs@ deals with a single binding group. It does generalisation,
192 so all the clever stuff is in here.
194 * binder_names and mbind must define the same set of Names
196 * The Names in tc_ty_sigs must be a subset of binder_names
198 * The Ids in tc_ty_sigs don't necessarily have to have the same name
199 as the Name in the tc_ty_sig
207 -> (Name -> PragmaInfo)
208 -> TcM s (TcMonoBinds s, LIE s, [TcIdBndr s])
210 tcBindWithSigs binder_names mbind tc_ty_sigs is_rec prag_info_fn
212 -- If typechecking the binds fails, then return with each
213 -- signature-less binder given type (forall a.a), to minimise subsequent
215 newTcTyVar mkBoxedTypeKind `thenNF_Tc` \ alpha_tv ->
217 forall_a_a = mkForAllTy alpha_tv (mkTyVarTy alpha_tv)
218 poly_ids = map mk_dummy binder_names
219 mk_dummy name = case maybeSig tc_ty_sigs name of
220 Just (TySigInfo _ poly_id _ _ _ _) -> poly_id -- Signature
221 Nothing -> mkUserId name forall_a_a NoPragmaInfo -- No signature
223 returnTc (EmptyMonoBinds, emptyLIE, poly_ids)
226 -- Create a new identifier for each binder, with each being given
227 -- a fresh unique, and a type-variable type.
228 tcGetUniques no_of_binders `thenNF_Tc` \ uniqs ->
229 mapNF_Tc mk_mono_id_ty binder_names `thenNF_Tc` \ mono_id_tys ->
231 mono_id_tyvars = tyVarsOfTypes mono_id_tys
232 mono_ids = zipWith3Equal "tcBindAndSigs" mk_id binder_names uniqs mono_id_tys
233 mk_id name uniq ty = mkUserLocal (getOccName name) uniq ty (getSrcLoc name)
236 -- TYPECHECK THE BINDINGS
237 tcMonoBinds mbind binder_names mono_ids tc_ty_sigs `thenTc` \ (mbind', lie) ->
239 -- CHECK THAT THE SIGNATURES MATCH
240 -- (must do this before getTyVarsToGen)
241 checkSigMatch tc_ty_sigs `thenTc` \ sig_theta ->
243 -- COMPUTE VARIABLES OVER WHICH TO QUANTIFY, namely tyvars_to_gen
244 -- The tyvars_not_to_gen are free in the environment, and hence
245 -- candidates for generalisation, but sometimes the monomorphism
246 -- restriction means we can't generalise them nevertheless
247 getTyVarsToGen is_unrestricted mono_id_tyvars lie `thenTc` \ (tyvars_not_to_gen, tyvars_to_gen) ->
249 -- DEAL WITH TYPE VARIABLE KINDS
250 mapTc defaultUncommittedTyVar (tyVarSetToList tyvars_to_gen) `thenTc` \ tyvars_to_gen_list ->
251 -- It's important that the final list (tyvars_to_gen_list) is fully
252 -- zonked, *including boxity*, because they'll be included in the forall types of
253 -- the polymorphic Ids, and instances of these Ids will be generated from them.
255 -- This step can do unification => keep other zonking after this
258 tcExtendGlobalTyVars tyvars_not_to_gen (
259 if null tc_ty_sigs then
260 -- No signatures, so just simplify the lie
261 tcSimplify tyvars_to_gen lie `thenTc` \ (lie_free, dict_binds, lie_bound) ->
262 returnTc (lie_free, dict_binds, map instToId (bagToList lie_bound))
265 zonk_theta sig_theta `thenNF_Tc` \ sig_theta' ->
266 newDicts SignatureOrigin sig_theta' `thenNF_Tc` \ (dicts_sig, dict_ids) ->
267 -- It's important that sig_theta is zonked, because
268 -- dict_id is later used to form the type of the polymorphic thing,
269 -- and forall-types must be zonked so far as their bound variables
272 -- Check that the needed dicts can be expressed in
273 -- terms of the signature ones
274 tcAddErrCtxt (sigsCtxt tysig_names) $
275 tcSimplifyAndCheck tyvars_to_gen dicts_sig lie `thenTc` \ (lie_free, dict_binds) ->
276 returnTc (lie_free, dict_binds, dict_ids)
278 ) `thenTc` \ (lie_free, dict_binds, dicts_bound) ->
280 ASSERT( not (any (isUnboxedTypeKind . tyVarKind) tyvars_to_gen_list) )
281 -- The instCantBeGeneralised stuff in tcSimplify should have
282 -- already raised an error if we're trying to generalise an unboxed tyvar
283 -- (NB: unboxed tyvars are always introduced along with a class constraint)
284 -- and it's better done there because we have more precise origin information.
285 -- That's why we just use an ASSERT here.
287 -- BUILD THE POLYMORPHIC RESULT IDs
288 mapNF_Tc zonkTcType mono_id_tys `thenNF_Tc` \ zonked_mono_id_types ->
290 exports = zipWith3 mk_export binder_names mono_ids zonked_mono_id_types
291 dict_tys = map tcIdType dicts_bound
293 mk_export binder_name mono_id zonked_mono_id_ty
294 | maybeToBool maybe_sig = (sig_tyvars, TcId sig_poly_id, TcId mono_id)
295 | otherwise = (tyvars_to_gen_list, TcId poly_id, TcId mono_id)
297 maybe_sig = maybeSig tc_ty_sigs binder_name
298 Just (TySigInfo _ sig_poly_id sig_tyvars _ _ _) = maybe_sig
299 poly_id = mkUserId binder_name poly_ty (prag_info_fn binder_name)
300 poly_ty = mkForAllTys tyvars_to_gen_list $ mkFunTys dict_tys $ zonked_mono_id_ty
301 -- It's important to build a fully-zonked poly_ty, because
302 -- we'll slurp out its free type variables when extending the
303 -- local environment (tcExtendLocalValEnv); if it's not zonked
304 -- it appears to have free tyvars that aren't actually free at all.
309 AbsBinds tyvars_to_gen_list
312 (dict_binds `AndMonoBinds` mbind'),
314 [poly_id | (_, TcId poly_id, _) <- exports]
317 no_of_binders = length binder_names
319 mk_mono_id_ty binder_name = case maybeSig tc_ty_sigs binder_name of
320 Just (TySigInfo name _ _ _ tau_ty _) -> returnNF_Tc tau_ty -- There's a signature
321 otherwise -> newTyVarTy kind -- No signature
323 tysig_names = [name | (TySigInfo name _ _ _ _ _) <- tc_ty_sigs]
324 is_unrestricted = isUnRestrictedGroup tysig_names mbind
326 kind | is_rec = mkBoxedTypeKind -- Recursive, so no unboxed types
327 | otherwise = mkTypeKind -- Non-recursive, so we permit unboxed types
329 zonk_theta theta = mapNF_Tc zonk theta
331 zonk (c,t) = zonkTcType t `thenNF_Tc` \ t' ->
335 @getImplicitStuffToGen@ decides what type variables generalise over.
337 For a "restricted group" -- see the monomorphism restriction
338 for a definition -- we bind no dictionaries, and
339 remove from tyvars_to_gen any constrained type variables
341 *Don't* simplify dicts at this point, because we aren't going
342 to generalise over these dicts. By the time we do simplify them
343 we may well know more. For example (this actually came up)
345 f x = array ... xs where xs = [1,2,3,4,5]
346 We don't want to generate lots of (fromInt Int 1), (fromInt Int 2)
347 stuff. If we simplify only at the f-binding (not the xs-binding)
348 we'll know that the literals are all Ints, and we can just produce
351 Find all the type variables involved in overloading, the
352 "constrained_tyvars". These are the ones we *aren't* going to
353 generalise. We must be careful about doing this:
355 (a) If we fail to generalise a tyvar which is not actually
356 constrained, then it will never, ever get bound, and lands
357 up printed out in interface files! Notorious example:
358 instance Eq a => Eq (Foo a b) where ..
359 Here, b is not constrained, even though it looks as if it is.
360 Another, more common, example is when there's a Method inst in
361 the LIE, whose type might very well involve non-overloaded
364 (b) On the other hand, we mustn't generalise tyvars which are constrained,
365 because we are going to pass on out the unmodified LIE, with those
366 tyvars in it. They won't be in scope if we've generalised them.
368 So we are careful, and do a complete simplification just to find the
369 constrained tyvars. We don't use any of the results, except to
370 find which tyvars are constrained.
373 getTyVarsToGen is_unrestricted mono_tyvars lie
374 = tcGetGlobalTyVars `thenNF_Tc` \ free_tyvars ->
375 zonkTcTyVars mono_tyvars `thenNF_Tc` \ mentioned_tyvars ->
377 tyvars_to_gen = mentioned_tyvars `minusTyVarSet` free_tyvars
381 returnTc (emptyTyVarSet, tyvars_to_gen)
383 tcSimplify tyvars_to_gen lie `thenTc` \ (_, _, constrained_dicts) ->
385 -- ASSERT: dicts_sig is already zonked!
386 constrained_tyvars = foldrBag (unionTyVarSets . tyVarsOfInst) emptyTyVarSet constrained_dicts
387 reduced_tyvars_to_gen = tyvars_to_gen `minusTyVarSet` constrained_tyvars
389 returnTc (constrained_tyvars, reduced_tyvars_to_gen)
394 isUnRestrictedGroup :: [Name] -- Signatures given for these
398 is_elem v vs = isIn "isUnResMono" v vs
400 isUnRestrictedGroup sigs (PatMonoBind (VarPatIn v) _ _) = v `is_elem` sigs
401 isUnRestrictedGroup sigs (PatMonoBind other _ _) = False
402 isUnRestrictedGroup sigs (VarMonoBind v _) = v `is_elem` sigs
403 isUnRestrictedGroup sigs (FunMonoBind _ _ _ _) = True
404 isUnRestrictedGroup sigs (AndMonoBinds mb1 mb2) = isUnRestrictedGroup sigs mb1 &&
405 isUnRestrictedGroup sigs mb2
406 isUnRestrictedGroup sigs EmptyMonoBinds = True
409 @defaultUncommittedTyVar@ checks for generalisation over unboxed
410 types, and defaults any TypeKind TyVars to BoxedTypeKind.
413 defaultUncommittedTyVar tyvar
414 | isTypeKind (tyVarKind tyvar)
415 = newTcTyVar mkBoxedTypeKind `thenNF_Tc` \ boxed_tyvar ->
416 unifyTauTy (mkTyVarTy boxed_tyvar) (mkTyVarTy tyvar) `thenTc_`
424 %************************************************************************
426 \subsection{tcMonoBind}
428 %************************************************************************
430 @tcMonoBinds@ deals with a single @MonoBind@.
431 The signatures have been dealt with already.
434 tcMonoBinds :: RenamedMonoBinds
435 -> [Name] -> [TcIdBndr s]
437 -> TcM s (TcMonoBinds s, LIE s)
439 tcMonoBinds mbind binder_names mono_ids tc_ty_sigs
440 = tcExtendLocalValEnv binder_names mono_ids (
444 sig_names = [name | (TySigInfo name _ _ _ _ _) <- tc_ty_sigs]
445 sig_ids = [id | (TySigInfo _ id _ _ _ _) <- tc_ty_sigs]
447 tc_mono_binds EmptyMonoBinds = returnTc (EmptyMonoBinds, emptyLIE)
449 tc_mono_binds (AndMonoBinds mb1 mb2)
450 = tc_mono_binds mb1 `thenTc` \ (mb1a, lie1) ->
451 tc_mono_binds mb2 `thenTc` \ (mb2a, lie2) ->
452 returnTc (AndMonoBinds mb1a mb2a, lie1 `plusLIE` lie2)
454 tc_mono_binds (FunMonoBind name inf matches locn)
456 tcLookupLocalValueOK "tc_mono_binds" name `thenNF_Tc` \ id ->
458 -- Before checking the RHS, extend the envt with
459 -- bindings for the *polymorphic* Ids from any type signatures
460 tcExtendLocalValEnv sig_names sig_ids $
461 tcMatchesFun name (idType id) matches `thenTc` \ (matches', lie) ->
463 returnTc (FunMonoBind (TcId id) inf matches' locn, lie)
465 tc_mono_binds bind@(PatMonoBind pat grhss_and_binds locn)
467 tcPat pat `thenTc` \ (pat2, lie_pat, pat_ty) ->
468 tcExtendLocalValEnv sig_names sig_ids $
469 tcGRHSsAndBinds grhss_and_binds `thenTc` \ (grhss_and_binds2, lie, grhss_ty) ->
470 tcAddErrCtxt (patMonoBindsCtxt bind) $
471 unifyTauTy pat_ty grhss_ty `thenTc_`
472 returnTc (PatMonoBind pat2 grhss_and_binds2 locn,
476 %************************************************************************
478 \subsection{Signatures}
480 %************************************************************************
482 @tcSigs@ checks the signatures for validity, and returns a list of
483 {\em freshly-instantiated} signatures. That is, the types are already
484 split up, and have fresh type variables installed. All non-type-signature
485 "RenamedSigs" are ignored.
487 The @TcSigInfo@ contains @TcTypes@ because they are unified with
488 the variable's type, and after that checked to see whether they've
494 (TcIdBndr s) -- *Polymorphic* binder for this value...
495 [TcTyVar s] (TcThetaType s) (TcTauType s)
499 maybeSig :: [TcSigInfo s] -> Name -> Maybe (TcSigInfo s)
500 -- Search for a particular signature
501 maybeSig [] name = Nothing
502 maybeSig (sig@(TySigInfo sig_name _ _ _ _ _) : sigs) name
503 | name == sig_name = Just sig
504 | otherwise = maybeSig sigs name
509 tcTySig :: (Name -> PragmaInfo)
511 -> TcM s (TcSigInfo s)
513 tcTySig prag_info_fn (Sig v ty src_loc)
514 = tcAddSrcLoc src_loc $
515 tcHsType ty `thenTc` \ sigma_ty ->
516 tcInstSigType sigma_ty `thenNF_Tc` \ sigma_ty' ->
518 poly_id = mkUserId v sigma_ty' (prag_info_fn v)
519 (tyvars', theta', tau') = splitSigmaTy sigma_ty'
520 -- This splitSigmaTy tries hard to make sure that tau' is a type synonym
521 -- wherever possible, which can improve interface files.
523 returnTc (TySigInfo v poly_id tyvars' theta' tau' src_loc)
526 @checkSigMatch@ does the next step in checking signature matching.
527 The tau-type part has already been unified. What we do here is to
528 check that this unification has not over-constrained the (polymorphic)
529 type variables of the original signature type.
531 The error message here is somewhat unsatisfactory, but it'll do for
536 = returnTc (error "checkSigMatch")
538 checkSigMatch tc_ty_sigs
539 = -- CHECK THAT ALL THE SIGNATURE CONTEXTS ARE UNIFIABLE
540 -- The type signatures on a mutually-recursive group of definitions
541 -- must all have the same context (or none).
543 -- We unify them because, with polymorphic recursion, their types
544 -- might not otherwise be related. This is a rather subtle issue.
546 tcAddErrCtxt (sigContextsCtxt tc_ty_sigs) (
547 mapTc (unifyTauTyLists dict_tys1) dict_tys_s
550 -- CHECK THAT THE SIGNATURE TYVARS AND TAU_TYPES ARE OK
551 -- Doesn't affect substitution
552 mapTc check_one_sig tc_ty_sigs `thenTc_`
556 (theta1:thetas) = [theta | TySigInfo _ _ _ theta _ _ <- tc_ty_sigs]
557 (dict_tys1 : dict_tys_s) = map mk_dict_tys (theta1 : thetas)
558 mk_dict_tys theta = [mkDictTy c t | (c,t) <- theta]
560 check_one_sig (TySigInfo name id sig_tyvars _ sig_tau src_loc)
561 = tcAddSrcLoc src_loc $
562 tcAddErrCtxt (sigCtxt id) $
563 checkSigTyVars sig_tyvars sig_tau
567 @checkSigTyVars@ is used after the type in a type signature has been unified with
568 the actual type found. It then checks that the type variables of the type signature
570 (a) still all type variables
571 eg matching signature [a] against inferred type [(p,q)]
572 [then a will be unified to a non-type variable]
574 (b) still all distinct
575 eg matching signature [(a,b)] against inferred type [(p,p)]
576 [then a and b will be unified together]
578 BUT ACTUALLY THESE FIRST TWO ARE FORCED BY USING DontBind TYVARS
580 (c) not mentioned in the environment
581 eg the signature for f in this:
587 Here, f is forced to be monorphic by the free occurence of x.
589 Before doing this, the substitution is applied to the signature type variable.
592 checkSigTyVars :: [TcTyVar s] -- The original signature type variables
593 -> TcType s -- signature type (for err msg)
596 checkSigTyVars sig_tyvars sig_tau
597 = tcGetGlobalTyVars `thenNF_Tc` \ globals ->
599 mono_tyvars = filter (`elementOfTyVarSet` globals) sig_tyvars
602 -- Until the final Bind-handling stuff is in, several type signatures in the same
603 -- bindings group can cause the signature type variable from the different
604 -- signatures to be unified. So we still need to zonk and check point (b).
605 -- Remove when activating the new binding code
606 mapNF_Tc zonkTcTyVar sig_tyvars `thenNF_Tc` \ sig_tys ->
607 checkTcM (hasNoDups (map (getTyVar "checkSigTyVars") sig_tys))
608 (zonkTcType sig_tau `thenNF_Tc` \ sig_tau' ->
609 failTc (badMatchErr sig_tau sig_tau')
614 -- We want to report errors in terms of the original signature tyvars,
615 -- ie sig_tyvars, NOT sig_tyvars'. sig_tys and sig_tyvars' correspond
616 -- 1-1 with sig_tyvars, so we can just map back.
617 checkTc (null mono_tyvars)
618 (notAsPolyAsSigErr sig_tau mono_tyvars)
622 %************************************************************************
624 \subsection{SPECIALIZE pragmas}
626 %************************************************************************
629 @tcPragmaSigs@ munches up the "signatures" that arise through *user*
630 pragmas. It is convenient for them to appear in the @[RenamedSig]@
631 part of a binding because then the same machinery can be used for
632 moving them into place as is done for type signatures.
635 tcPragmaSigs :: [RenamedSig] -- The pragma signatures
636 -> TcM s (Name -> PragmaInfo, -- Maps name to the appropriate PragmaInfo
640 -- For now we just deal with INLINE pragmas
641 tcPragmaSigs sigs = returnTc (prag_fn, EmptyBinds, emptyLIE )
643 prag_fn name | any has_inline sigs = IWantToBeINLINEd
644 | otherwise = NoPragmaInfo
646 has_inline (InlineSig n _) = (n == name)
647 has_inline other = False
652 = mapAndUnzip3Tc tcPragmaSig sigs `thenTc` \ (names_w_id_infos, binds, lies) ->
654 name_to_info name = foldr ($) noIdInfo
655 [info_fn | (n,info_fn) <- names_w_id_infos, n==name]
657 returnTc (name_to_info,
658 foldr ThenBinds EmptyBinds binds,
659 foldr plusLIE emptyLIE lies)
662 Here are the easy cases for tcPragmaSigs
665 tcPragmaSig (DeforestSig name loc)
666 = returnTc ((name, addDeforestInfo DoDeforest),EmptyBinds,emptyLIE)
667 tcPragmaSig (InlineSig name loc)
668 = returnTc ((name, addUnfoldInfo (iWantToBeINLINEd UnfoldAlways)), EmptyBinds, emptyLIE)
669 tcPragmaSig (MagicUnfoldingSig name string loc)
670 = returnTc ((name, addUnfoldInfo (mkMagicUnfolding string)), EmptyBinds, emptyLIE)
673 The interesting case is for SPECIALISE pragmas. There are two forms.
674 Here's the first form:
676 f :: Ord a => [a] -> b -> b
677 {-# SPECIALIZE f :: [Int] -> b -> b #-}
680 For this we generate:
682 f* = /\ b -> let d1 = ...
686 where f* is a SpecPragmaId. The **sole** purpose of SpecPragmaIds is to
687 retain a right-hand-side that the simplifier will otherwise discard as
688 dead code... the simplifier has a flag that tells it not to discard
689 SpecPragmaId bindings.
691 In this case the f* retains a call-instance of the overloaded
692 function, f, (including appropriate dictionaries) so that the
693 specialiser will subsequently discover that there's a call of @f@ at
694 Int, and will create a specialisation for @f@. After that, the
695 binding for @f*@ can be discarded.
697 The second form is this:
699 f :: Ord a => [a] -> b -> b
700 {-# SPECIALIZE f :: [Int] -> b -> b = g #-}
703 Here @g@ is specified as a function that implements the specialised
704 version of @f@. Suppose that g has type (a->b->b); that is, g's type
705 is more general than that required. For this we generate
707 f@Int = /\b -> g Int b
711 Here @f@@Int@ is a SpecId, the specialised version of @f@. It inherits
712 f's export status etc. @f*@ is a SpecPragmaId, as before, which just serves
713 to prevent @f@@Int@ from being discarded prematurely. After specialisation,
714 if @f@@Int@ is going to be used at all it will be used explicitly, so the simplifier can
715 discard the f* binding.
717 Actually, there is really only point in giving a SPECIALISE pragma on exported things,
718 and the simplifer won't discard SpecIds for exporte things anyway, so maybe this is
722 tcPragmaSig (SpecSig name poly_ty maybe_spec_name src_loc)
723 = tcAddSrcLoc src_loc $
724 tcAddErrCtxt (valSpecSigCtxt name spec_ty) $
726 -- Get and instantiate its alleged specialised type
727 tcHsType poly_ty `thenTc` \ sig_sigma ->
728 tcInstSigType sig_sigma `thenNF_Tc` \ sig_ty ->
730 (sig_tyvars, sig_theta, sig_tau) = splitSigmaTy sig_ty
731 origin = ValSpecOrigin name
734 -- Check that the SPECIALIZE pragma had an empty context
735 checkTc (null sig_theta)
736 (panic "SPECIALIZE non-empty context (ToDo: msg)") `thenTc_`
738 -- Get and instantiate the type of the id mentioned
739 tcLookupLocalValueOK "tcPragmaSig" name `thenNF_Tc` \ main_id ->
740 tcInstSigType [] (idType main_id) `thenNF_Tc` \ main_ty ->
742 (main_tyvars, main_rho) = splitForAllTy main_ty
743 (main_theta,main_tau) = splitRhoTy main_rho
744 main_arg_tys = mkTyVarTys main_tyvars
747 -- Check that the specialised type is indeed an instance of
748 -- the type of the main function.
749 unifyTauTy sig_tau main_tau `thenTc_`
750 checkSigTyVars sig_tyvars sig_tau `thenTc_`
752 -- Check that the type variables of the polymorphic function are
753 -- either left polymorphic, or instantiate to ground type.
754 -- Also check that the overloaded type variables are instantiated to
755 -- ground type; or equivalently that all dictionaries have ground type
756 mapTc zonkTcType main_arg_tys `thenNF_Tc` \ main_arg_tys' ->
757 zonkTcThetaType main_theta `thenNF_Tc` \ main_theta' ->
758 tcAddErrCtxt (specGroundnessCtxt main_arg_tys')
759 (checkTc (all isGroundOrTyVarTy main_arg_tys')) `thenTc_`
760 tcAddErrCtxt (specContextGroundnessCtxt main_theta')
761 (checkTc (and [isGroundTy ty | (_,ty) <- theta'])) `thenTc_`
763 -- Build the SpecPragmaId; it is the thing that makes sure we
764 -- don't prematurely dead-code-eliminate the binding we are really interested in.
765 newSpecPragmaId name sig_ty `thenNF_Tc` \ spec_pragma_id ->
767 -- Build a suitable binding; depending on whether we were given
768 -- a value (Maybe Name) to be used as the specialisation.
770 Nothing -> -- No implementation function specified
772 -- Make a Method inst for the occurrence of the overloaded function
773 newMethodWithGivenTy (OccurrenceOf name)
774 (TcId main_id) main_arg_tys main_rho `thenNF_Tc` \ (lie, meth_id) ->
777 pseudo_bind = VarMonoBind spec_pragma_id pseudo_rhs
778 pseudo_rhs = mkHsTyLam sig_tyvars (HsVar (TcId meth_id))
780 returnTc (pseudo_bind, lie, \ info -> info)
782 Just spec_name -> -- Use spec_name as the specialisation value ...
784 -- Type check a simple occurrence of the specialised Id
785 tcId spec_name `thenTc` \ (spec_body, spec_lie, spec_tau) ->
787 -- Check that it has the correct type, and doesn't constrain the
788 -- signature variables at all
789 unifyTauTy sig_tau spec_tau `thenTc_`
790 checkSigTyVars sig_tyvars sig_tau `thenTc_`
792 -- Make a local SpecId to bind to applied spec_id
793 newSpecId main_id main_arg_tys sig_ty `thenNF_Tc` \ local_spec_id ->
796 spec_rhs = mkHsTyLam sig_tyvars spec_body
797 spec_binds = VarMonoBind local_spec_id spec_rhs
799 VarMonoBind spec_pragma_id (HsVar (TcId local_spec_id))
800 spec_info = SpecInfo spec_tys (length main_theta) local_spec_id
802 returnTc ((name, addSpecInfo spec_info), spec_binds, spec_lie)
807 %************************************************************************
809 \subsection[TcBinds-errors]{Error contexts and messages}
811 %************************************************************************
815 patMonoBindsCtxt bind sty
816 = hang (ptext SLIT("In a pattern binding:")) 4 (ppr sty bind)
818 -----------------------------------------------
819 valSpecSigCtxt v ty sty
820 = hang (ptext SLIT("In a SPECIALIZE pragma for a value:"))
821 4 (sep [(<>) (ppr sty v) (ptext SLIT(" ::")),
826 -----------------------------------------------
827 notAsPolyAsSigErr sig_tau mono_tyvars sty
828 = hang (ptext SLIT("A type signature is more polymorphic than the inferred type"))
829 4 (vcat [text "Some type variables in the inferred type can't be forall'd, namely:",
830 interpp'SP sty mono_tyvars,
831 ptext SLIT("Possible cause: the RHS mentions something subject to the monomorphism restriction")
834 -----------------------------------------------
835 badMatchErr sig_ty inferred_ty sty
836 = hang (ptext SLIT("Type signature doesn't match inferred type"))
837 4 (vcat [hang (ptext SLIT("Signature:")) 4 (ppr sty sig_ty),
838 hang (ptext SLIT("Inferred :")) 4 (ppr sty inferred_ty)
841 -----------------------------------------------
843 = sep [ptext SLIT("When checking signature for"), ppr sty id]
845 = sep [ptext SLIT("When checking signature(s) for:"), interpp'SP sty ids]
847 -----------------------------------------------
848 sigContextsCtxt ty_sigs sty
849 = hang (ptext SLIT("When matching the contexts of the signatures of a recursive group"))
850 4 (vcat (map ppr_tc_ty_sig ty_sigs))
852 ppr_tc_ty_sig (TySigInfo val _ tyvars theta tau_ty _)
853 = hang ((<>) (ppr sty val) (ptext SLIT(" :: ")))
856 else hcat [parens (hsep (punctuate comma (map (ppr_inst sty) theta))),
858 ppr_inst sty (clas, ty) = hsep [ppr sty clas, ppr sty ty]
860 -----------------------------------------------
862 = panic "specGroundnessCtxt"
864 --------------------------------------------
865 specContextGroundnessCtxt -- err_ctxt dicts sty
866 = panic "specContextGroundnessCtxt"
869 sep [hsep [ptext SLIT("In the SPECIALIZE pragma for"), ppr sty name],
870 hcat [ptext SLIT(" specialised to the type"), ppr sty spec_ty],
872 ptext SLIT("... not all overloaded type variables were instantiated"),
873 ptext SLIT("to ground types:")])
874 4 (vcat [hsep [ppr sty c, ppr sty t]
875 | (c,t) <- map getDictClassAndType dicts])
877 (name, spec_ty, locn, pp_spec_id)
879 ValSpecSigCtxt n ty loc -> (n, ty, loc, \ x -> empty)
880 ValSpecSpecIdCtxt n ty spec loc ->
882 \ sty -> hsep [ptext SLIT("... type of explicit id"), ppr sty spec])