2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 \section[TcBinds]{TcBinds}
7 module TcBinds ( tcBindsAndThen, tcTopBindsAndThen,
8 tcPragmaSigs, tcBindWithSigs ) where
10 #include "HsVersions.h"
12 import {-# SOURCE #-} TcMatches ( tcGRHSs, tcMatchesFun )
13 import {-# SOURCE #-} TcExpr ( tcExpr )
15 import HsSyn ( HsExpr(..), HsBinds(..), MonoBinds(..), Sig(..), InPat(..), StmtCtxt(..),
16 collectMonoBinders, andMonoBindList, andMonoBinds
18 import RnHsSyn ( RenamedHsBinds, RenamedSig, RenamedMonoBinds )
19 import TcHsSyn ( TcHsBinds, TcMonoBinds, TcId, zonkId )
22 import Inst ( Inst, LIE, emptyLIE, mkLIE, plusLIE, plusLIEs, InstOrigin(..),
23 newDicts, tyVarsOfInst, instToId,
25 import TcEnv ( tcExtendLocalValEnv,
28 tcGetGlobalTyVars, tcExtendGlobalTyVars
30 import TcSimplify ( tcSimplify, tcSimplifyAndCheck )
31 import TcMonoType ( tcHsType, checkSigTyVars,
32 TcSigInfo(..), tcTySig, maybeSig, sigCtxt
34 import TcPat ( tcVarPat, tcPat )
35 import TcSimplify ( bindInstsOfLocalFuns )
36 import TcType ( TcType, TcThetaType,
38 newTyVarTy, newTyVar, newTyVarTy_OpenKind, tcInstTcType,
39 zonkTcType, zonkTcTypes, zonkTcThetaType, zonkTcTyVarToTyVar
41 import TcUnify ( unifyTauTy, unifyTauTyLists )
43 import PrelInfo ( main_NAME, ioTyCon_NAME )
45 import Id ( mkUserId )
46 import Var ( idType, idName, setIdInfo )
47 import IdInfo ( IdInfo, noIdInfo, setInlinePragInfo, InlinePragInfo(..) )
48 import Name ( Name, getName )
49 import Type ( mkTyVarTy, tyVarsOfTypes, mkTyConApp,
50 splitSigmaTy, mkForAllTys, mkFunTys, getTyVar,
51 mkDictTy, splitRhoTy, mkForAllTy, isUnLiftedType,
52 isUnboxedType, unboxedTypeKind, boxedTypeKind
54 import Var ( TyVar, tyVarKind )
58 import Maybes ( maybeToBool )
59 import BasicTypes ( TopLevelFlag(..), RecFlag(..) )
60 import SrcLoc ( SrcLoc )
65 %************************************************************************
67 \subsection{Type-checking bindings}
69 %************************************************************************
71 @tcBindsAndThen@ typechecks a @HsBinds@. The "and then" part is because
72 it needs to know something about the {\em usage} of the things bound,
73 so that it can create specialisations of them. So @tcBindsAndThen@
74 takes a function which, given an extended environment, E, typechecks
75 the scope of the bindings returning a typechecked thing and (most
76 important) an LIE. It is this LIE which is then used as the basis for
77 specialising the things bound.
79 @tcBindsAndThen@ also takes a "combiner" which glues together the
80 bindings and the "thing" to make a new "thing".
82 The real work is done by @tcBindWithSigsAndThen@.
84 Recursive and non-recursive binds are handled in essentially the same
85 way: because of uniques there are no scoping issues left. The only
86 difference is that non-recursive bindings can bind primitive values.
88 Even for non-recursive binding groups we add typings for each binder
89 to the LVE for the following reason. When each individual binding is
90 checked the type of its LHS is unified with that of its RHS; and
91 type-checking the LHS of course requires that the binder is in scope.
93 At the top-level the LIE is sure to contain nothing but constant
94 dictionaries, which we resolve at the module level.
97 tcTopBindsAndThen, tcBindsAndThen
98 :: (RecFlag -> TcMonoBinds -> thing -> thing) -- Combinator
100 -> TcM s (thing, LIE)
101 -> TcM s (thing, LIE)
103 tcTopBindsAndThen = tc_binds_and_then TopLevel
104 tcBindsAndThen = tc_binds_and_then NotTopLevel
106 tc_binds_and_then top_lvl combiner EmptyBinds do_next
108 tc_binds_and_then top_lvl combiner (MonoBind EmptyMonoBinds sigs is_rec) do_next
111 tc_binds_and_then top_lvl combiner (ThenBinds b1 b2) do_next
112 = tc_binds_and_then top_lvl combiner b1 $
113 tc_binds_and_then top_lvl combiner b2 $
116 tc_binds_and_then top_lvl combiner (MonoBind bind sigs is_rec) do_next
117 = fixTc (\ ~(prag_info_fn, _, _) ->
118 -- This is the usual prag_info fix; the PragmaInfo field of an Id
119 -- is not inspected till ages later in the compiler, so there
120 -- should be no black-hole problems here.
122 -- TYPECHECK THE SIGNATURES
123 mapTc tcTySig [sig | sig@(Sig name _ _) <- sigs] `thenTc` \ tc_ty_sigs ->
125 tcBindWithSigs top_lvl bind
126 tc_ty_sigs is_rec prag_info_fn `thenTc` \ (poly_binds, poly_lie, poly_ids) ->
128 -- Extend the environment to bind the new polymorphic Ids
129 tcExtendLocalValEnv [(idName poly_id, poly_id) | poly_id <- poly_ids] $
131 -- Build bindings and IdInfos corresponding to user pragmas
132 tcPragmaSigs sigs `thenTc` \ (prag_info_fn, prag_binds, prag_lie) ->
134 -- Now do whatever happens next, in the augmented envt
135 do_next `thenTc` \ (thing, thing_lie) ->
137 -- Create specialisations of functions bound here
138 -- We want to keep non-recursive things non-recursive
139 -- so that we desugar unboxed bindings correctly
140 case (top_lvl, is_rec) of
142 -- For the top level don't bother will all this bindInstsOfLocalFuns stuff
143 -- All the top level things are rec'd together anyway, so it's fine to
144 -- leave them to the tcSimplifyTop, and quite a bit faster too
146 -> returnTc (prag_info_fn,
147 combiner Recursive (poly_binds `andMonoBinds` prag_binds) thing,
148 thing_lie `plusLIE` prag_lie `plusLIE` poly_lie)
150 (NotTopLevel, NonRecursive)
151 -> bindInstsOfLocalFuns
152 (thing_lie `plusLIE` prag_lie)
153 poly_ids `thenTc` \ (thing_lie', lie_binds) ->
157 combiner NonRecursive poly_binds $
158 combiner NonRecursive prag_binds $
159 combiner Recursive lie_binds $
160 -- NB: the binds returned by tcSimplify and bindInstsOfLocalFuns
161 -- aren't guaranteed in dependency order (though we could change
162 -- that); hence the Recursive marker.
165 thing_lie' `plusLIE` poly_lie
168 (NotTopLevel, Recursive)
169 -> bindInstsOfLocalFuns
170 (thing_lie `plusLIE` poly_lie `plusLIE` prag_lie)
171 poly_ids `thenTc` \ (final_lie, lie_binds) ->
176 poly_binds `andMonoBinds`
177 lie_binds `andMonoBinds`
181 ) `thenTc` \ (_, thing, lie) ->
182 returnTc (thing, lie)
185 An aside. The original version of @tcBindsAndThen@ which lacks a
186 combiner function, appears below. Though it is perfectly well
187 behaved, it cannot be typed by Haskell, because the recursive call is
188 at a different type to the definition itself. There aren't too many
189 examples of this, which is why I thought it worth preserving! [SLPJ]
194 % -> TcM s (thing, LIE, thing_ty))
195 % -> TcM s ((TcHsBinds, thing), LIE, thing_ty)
197 % tcBindsAndThen EmptyBinds do_next
198 % = do_next `thenTc` \ (thing, lie, thing_ty) ->
199 % returnTc ((EmptyBinds, thing), lie, thing_ty)
201 % tcBindsAndThen (ThenBinds binds1 binds2) do_next
202 % = tcBindsAndThen binds1 (tcBindsAndThen binds2 do_next)
203 % `thenTc` \ ((binds1', (binds2', thing')), lie1, thing_ty) ->
205 % returnTc ((binds1' `ThenBinds` binds2', thing'), lie1, thing_ty)
207 % tcBindsAndThen (MonoBind bind sigs is_rec) do_next
208 % = tcBindAndThen bind sigs do_next
212 %************************************************************************
214 \subsection{tcBindWithSigs}
216 %************************************************************************
218 @tcBindWithSigs@ deals with a single binding group. It does generalisation,
219 so all the clever stuff is in here.
221 * binder_names and mbind must define the same set of Names
223 * The Names in tc_ty_sigs must be a subset of binder_names
225 * The Ids in tc_ty_sigs don't necessarily have to have the same name
226 as the Name in the tc_ty_sig
235 -> TcM s (TcMonoBinds, LIE, [TcId])
237 tcBindWithSigs top_lvl mbind tc_ty_sigs is_rec prag_info_fn
239 -- If typechecking the binds fails, then return with each
240 -- signature-less binder given type (forall a.a), to minimise subsequent
242 newTyVar boxedTypeKind `thenNF_Tc` \ alpha_tv ->
244 forall_a_a = mkForAllTy alpha_tv (mkTyVarTy alpha_tv)
245 binder_names = map fst (bagToList (collectMonoBinders mbind))
246 poly_ids = map mk_dummy binder_names
247 mk_dummy name = case maybeSig tc_ty_sigs name of
248 Just (TySigInfo _ poly_id _ _ _ _ _ _) -> poly_id -- Signature
249 Nothing -> mkUserId name forall_a_a -- No signature
251 returnTc (EmptyMonoBinds, emptyLIE, poly_ids)
254 -- TYPECHECK THE BINDINGS
255 tcMonoBinds mbind tc_ty_sigs is_rec `thenTc` \ (mbind', lie_req, binder_names, mono_ids) ->
257 -- CHECK THAT THE SIGNATURES MATCH
258 -- (must do this before getTyVarsToGen)
259 checkSigMatch top_lvl binder_names mono_ids tc_ty_sigs `thenTc` \ maybe_sig_theta ->
261 -- COMPUTE VARIABLES OVER WHICH TO QUANTIFY, namely tyvars_to_gen
262 -- The tyvars_not_to_gen are free in the environment, and hence
263 -- candidates for generalisation, but sometimes the monomorphism
264 -- restriction means we can't generalise them nevertheless
266 mono_id_tys = map idType mono_ids
268 getTyVarsToGen is_unrestricted mono_id_tys lie_req `thenNF_Tc` \ (tyvars_not_to_gen, tyvars_to_gen) ->
270 -- Finally, zonk the generalised type variables to real TyVars
271 -- This commits any unbound kind variables to boxed kind
272 -- I'm a little worried that such a kind variable might be
273 -- free in the environment, but I don't think it's possible for
274 -- this to happen when the type variable is not free in the envt
275 -- (which it isn't). SLPJ Nov 98
276 mapTc zonkTcTyVarToTyVar (varSetElems tyvars_to_gen) `thenTc` \ real_tyvars_to_gen_list ->
278 real_tyvars_to_gen = mkVarSet real_tyvars_to_gen_list
279 -- It's important that the final list
280 -- (real_tyvars_to_gen and real_tyvars_to_gen_list) is fully
281 -- zonked, *including boxity*, because they'll be included in the forall types of
282 -- the polymorphic Ids, and instances of these Ids will be generated from them.
284 -- Also NB that tcSimplify takes zonked tyvars as its arg, hence we pass
285 -- real_tyvars_to_gen
289 tcExtendGlobalTyVars tyvars_not_to_gen (
290 if null real_tyvars_to_gen_list then
291 -- No polymorphism, so no need to simplify context
292 returnTc (lie_req, EmptyMonoBinds, [])
294 case maybe_sig_theta of
296 -- No signatures, so just simplify the lie
297 -- NB: no signatures => no polymorphic recursion, so no
298 -- need to use lie_avail (which will be empty anyway)
299 tcSimplify (text "tcBinds1" <+> ppr binder_names)
300 top_lvl real_tyvars_to_gen lie_req `thenTc` \ (lie_free, dict_binds, lie_bound) ->
301 returnTc (lie_free, dict_binds, map instToId (bagToList lie_bound))
303 Just (sig_theta, lie_avail) ->
304 -- There are signatures, and their context is sig_theta
305 -- Furthermore, lie_avail is an LIE containing the 'method insts'
306 -- for the things bound here
308 zonkTcThetaType sig_theta `thenNF_Tc` \ sig_theta' ->
309 newDicts SignatureOrigin sig_theta' `thenNF_Tc` \ (dicts_sig, dict_ids) ->
310 -- It's important that sig_theta is zonked, because
311 -- dict_id is later used to form the type of the polymorphic thing,
312 -- and forall-types must be zonked so far as their bound variables
316 -- The "givens" is the stuff available. We get that from
317 -- the context of the type signature, BUT ALSO the lie_avail
318 -- so that polymorphic recursion works right (see comments at end of fn)
319 givens = dicts_sig `plusLIE` lie_avail
322 -- Check that the needed dicts can be expressed in
323 -- terms of the signature ones
324 tcAddErrCtxt (bindSigsCtxt tysig_names) $
326 (ptext SLIT("type signature for") <+> pprQuotedList binder_names)
327 real_tyvars_to_gen givens lie_req `thenTc` \ (lie_free, dict_binds) ->
329 returnTc (lie_free, dict_binds, dict_ids)
331 ) `thenTc` \ (lie_free, dict_binds, dicts_bound) ->
333 -- GET THE FINAL MONO_ID_TYS
334 zonkTcTypes mono_id_tys `thenNF_Tc` \ zonked_mono_id_types ->
337 -- CHECK FOR BOGUS UNPOINTED BINDINGS
338 (if any isUnLiftedType zonked_mono_id_types then
339 -- Unlifted bindings must be non-recursive,
340 -- not top level, and non-polymorphic
341 checkTc (case top_lvl of {TopLevel -> False; NotTopLevel -> True})
342 (unliftedBindErr "Top-level" mbind) `thenTc_`
343 checkTc (case is_rec of {Recursive -> False; NonRecursive -> True})
344 (unliftedBindErr "Recursive" mbind) `thenTc_`
345 checkTc (null real_tyvars_to_gen_list)
346 (unliftedBindErr "Polymorphic" mbind)
351 ASSERT( not (any ((== unboxedTypeKind) . tyVarKind) real_tyvars_to_gen_list) )
352 -- The instCantBeGeneralised stuff in tcSimplify should have
353 -- already raised an error if we're trying to generalise an
354 -- unboxed tyvar (NB: unboxed tyvars are always introduced
355 -- along with a class constraint) and it's better done there
356 -- because we have more precise origin information.
357 -- That's why we just use an ASSERT here.
360 -- BUILD THE POLYMORPHIC RESULT IDs
361 mapNF_Tc zonkId mono_ids `thenNF_Tc` \ zonked_mono_ids ->
363 exports = zipWith mk_export binder_names zonked_mono_ids
364 dict_tys = map idType dicts_bound
366 mk_export binder_name zonked_mono_id
368 setIdInfo poly_id (prag_info_fn binder_name),
372 case maybeSig tc_ty_sigs binder_name of
373 Just (TySigInfo _ sig_poly_id sig_tyvars _ _ _ _ _) ->
374 (sig_tyvars, sig_poly_id)
375 Nothing -> (real_tyvars_to_gen_list, new_poly_id)
377 new_poly_id = mkUserId binder_name poly_ty
378 poly_ty = mkForAllTys real_tyvars_to_gen_list
380 $ idType (zonked_mono_id)
381 -- It's important to build a fully-zonked poly_ty, because
382 -- we'll slurp out its free type variables when extending the
383 -- local environment (tcExtendLocalValEnv); if it's not zonked
384 -- it appears to have free tyvars that aren't actually free
387 pat_binders :: [Name]
388 pat_binders = map fst $ bagToList $ collectMonoBinders $
389 (justPatBindings mbind EmptyMonoBinds)
391 -- CHECK FOR UNBOXED BINDERS IN PATTERN BINDINGS
392 mapTc (\id -> checkTc (not (idName id `elem` pat_binders
393 && isUnboxedType (idType id)))
394 (unboxedPatBindErr id)) zonked_mono_ids
399 AbsBinds real_tyvars_to_gen_list
402 (dict_binds `andMonoBinds` mbind'),
404 [poly_id | (_, poly_id, _) <- exports]
407 tysig_names = [name | (TySigInfo name _ _ _ _ _ _ _) <- tc_ty_sigs]
408 is_unrestricted = isUnRestrictedGroup tysig_names mbind
410 justPatBindings bind@(PatMonoBind _ _ _) binds = bind `andMonoBinds` binds
411 justPatBindings (AndMonoBinds b1 b2) binds =
412 justPatBindings b1 (justPatBindings b2 binds)
413 justPatBindings other_bind binds = binds
416 Polymorphic recursion
417 ~~~~~~~~~~~~~~~~~~~~~
418 The game plan for polymorphic recursion in the code above is
420 * Bind any variable for which we have a type signature
421 to an Id with a polymorphic type. Then when type-checking
422 the RHSs we'll make a full polymorphic call.
424 This fine, but if you aren't a bit careful you end up with a horrendous
425 amount of partial application and (worse) a huge space leak. For example:
427 f :: Eq a => [a] -> [a]
430 If we don't take care, after typechecking we get
432 f = /\a -> \d::Eq a -> let f' = f a d
436 Notice the the stupid construction of (f a d), which is of course
437 identical to the function we're executing. In this case, the
438 polymorphic recursion isn't being used (but that's a very common case).
441 f = /\a -> \d::Eq a -> letrec
442 fm = \ys:[a] -> ...fm...
446 This can lead to a massive space leak, from the following top-level defn
452 Now (f dEqInt) evaluates to a lambda that has f' as a free variable; but
453 f' is another thunk which evaluates to the same thing... and you end
454 up with a chain of identical values all hung onto by the CAF ff.
458 = let f' = f Int dEqInt in \ys. ...f'...
460 = let f' = let f' = f Int dEqInt in \ys. ...f'...
464 Solution: when typechecking the RHSs we always have in hand the
465 *monomorphic* Ids for each binding. So we just need to make sure that
466 if (Method f a d) shows up in the constraints emerging from (...f...)
467 we just use the monomorphic Id. We achieve this by adding monomorphic Ids
468 to the "givens" when simplifying constraints. That's what the "lies_avail"
472 %************************************************************************
474 \subsection{getTyVarsToGen}
476 %************************************************************************
478 @getTyVarsToGen@ decides what type variables generalise over.
480 For a "restricted group" -- see the monomorphism restriction
481 for a definition -- we bind no dictionaries, and
482 remove from tyvars_to_gen any constrained type variables
484 *Don't* simplify dicts at this point, because we aren't going
485 to generalise over these dicts. By the time we do simplify them
486 we may well know more. For example (this actually came up)
488 f x = array ... xs where xs = [1,2,3,4,5]
489 We don't want to generate lots of (fromInt Int 1), (fromInt Int 2)
490 stuff. If we simplify only at the f-binding (not the xs-binding)
491 we'll know that the literals are all Ints, and we can just produce
494 Find all the type variables involved in overloading, the
495 "constrained_tyvars". These are the ones we *aren't* going to
496 generalise. We must be careful about doing this:
498 (a) If we fail to generalise a tyvar which is not actually
499 constrained, then it will never, ever get bound, and lands
500 up printed out in interface files! Notorious example:
501 instance Eq a => Eq (Foo a b) where ..
502 Here, b is not constrained, even though it looks as if it is.
503 Another, more common, example is when there's a Method inst in
504 the LIE, whose type might very well involve non-overloaded
507 (b) On the other hand, we mustn't generalise tyvars which are constrained,
508 because we are going to pass on out the unmodified LIE, with those
509 tyvars in it. They won't be in scope if we've generalised them.
511 So we are careful, and do a complete simplification just to find the
512 constrained tyvars. We don't use any of the results, except to
513 find which tyvars are constrained.
516 getTyVarsToGen is_unrestricted mono_id_tys lie
517 = tcGetGlobalTyVars `thenNF_Tc` \ free_tyvars ->
518 zonkTcTypes mono_id_tys `thenNF_Tc` \ zonked_mono_id_tys ->
520 tyvars_to_gen = tyVarsOfTypes zonked_mono_id_tys `minusVarSet` free_tyvars
524 returnNF_Tc (emptyVarSet, tyvars_to_gen)
526 -- This recover and discard-errs is to avoid duplicate error
527 -- messages; this, after all, is an "extra" call to tcSimplify
528 recoverNF_Tc (returnNF_Tc (emptyVarSet, tyvars_to_gen)) $
531 tcSimplify (text "getTVG") NotTopLevel tyvars_to_gen lie `thenTc` \ (_, _, constrained_dicts) ->
533 -- ASSERT: dicts_sig is already zonked!
534 constrained_tyvars = foldrBag (unionVarSet . tyVarsOfInst) emptyVarSet constrained_dicts
535 reduced_tyvars_to_gen = tyvars_to_gen `minusVarSet` constrained_tyvars
537 returnTc (constrained_tyvars, reduced_tyvars_to_gen)
542 isUnRestrictedGroup :: [Name] -- Signatures given for these
546 is_elem v vs = isIn "isUnResMono" v vs
548 isUnRestrictedGroup sigs (PatMonoBind (VarPatIn v) _ _) = v `is_elem` sigs
549 isUnRestrictedGroup sigs (PatMonoBind other _ _) = False
550 isUnRestrictedGroup sigs (VarMonoBind v _) = v `is_elem` sigs
551 isUnRestrictedGroup sigs (FunMonoBind _ _ _ _) = True
552 isUnRestrictedGroup sigs (AndMonoBinds mb1 mb2) = isUnRestrictedGroup sigs mb1 &&
553 isUnRestrictedGroup sigs mb2
554 isUnRestrictedGroup sigs EmptyMonoBinds = True
558 %************************************************************************
560 \subsection{tcMonoBind}
562 %************************************************************************
564 @tcMonoBinds@ deals with a single @MonoBind@.
565 The signatures have been dealt with already.
568 tcMonoBinds :: RenamedMonoBinds
571 -> TcM s (TcMonoBinds,
573 [Name], -- Bound names
574 [TcId]) -- Corresponding monomorphic bound things
576 tcMonoBinds mbinds tc_ty_sigs is_rec
577 = tc_mb_pats mbinds `thenTc` \ (complete_it, lie_req_pat, tvs, ids, lie_avail) ->
579 tv_list = bagToList tvs
580 id_list = bagToList ids
581 (names, mono_ids) = unzip id_list
583 -- This last defn is the key one:
584 -- extend the val envt with bindings for the
585 -- things bound in this group, overriding the monomorphic
586 -- ids with the polymorphic ones from the pattern
587 extra_val_env = case is_rec of
588 Recursive -> map mk_bind id_list
591 -- Don't know how to deal with pattern-bound existentials yet
592 checkTc (isEmptyBag tvs && isEmptyBag lie_avail)
593 (existentialExplode mbinds) `thenTc_`
595 -- *Before* checking the RHSs, but *after* checking *all* the patterns,
596 -- extend the envt with bindings for all the bound ids;
597 -- and *then* override with the polymorphic Ids from the signatures
598 -- That is the whole point of the "complete_it" stuff.
600 -- There's a further wrinkle: we have to delay extending the environment
601 -- until after we've dealt with any pattern-bound signature type variables
602 -- Consider f (x::a) = ...f...
603 -- We're going to check that a isn't unified with anything in the envt,
604 -- so f itself had better not be! So we pass the envt binding f into
605 -- complete_it, which extends the actual envt in TcMatches.tcMatch, after
606 -- dealing with the signature tyvars
608 complete_it extra_val_env `thenTc` \ (mbinds', lie_req_rhss) ->
610 returnTc (mbinds', lie_req_pat `plusLIE` lie_req_rhss, names, mono_ids)
612 sig_fn name = case maybeSig tc_ty_sigs name of
614 Just (TySigInfo _ _ _ _ _ mono_id _ _) -> Just mono_id
616 mk_bind (name, mono_id) = case maybeSig tc_ty_sigs name of
617 Nothing -> (name, mono_id)
618 Just (TySigInfo name poly_id _ _ _ _ _ _) -> (name, poly_id)
620 tc_mb_pats EmptyMonoBinds
621 = returnTc (\ xve -> returnTc (EmptyMonoBinds, emptyLIE), emptyLIE, emptyBag, emptyBag, emptyLIE)
623 tc_mb_pats (AndMonoBinds mb1 mb2)
624 = tc_mb_pats mb1 `thenTc` \ (complete_it1, lie_req1, tvs1, ids1, lie_avail1) ->
625 tc_mb_pats mb2 `thenTc` \ (complete_it2, lie_req2, tvs2, ids2, lie_avail2) ->
627 complete_it xve = complete_it1 xve `thenTc` \ (mb1', lie1) ->
628 complete_it2 xve `thenTc` \ (mb2', lie2) ->
629 returnTc (AndMonoBinds mb1' mb2', lie1 `plusLIE` lie2)
631 returnTc (complete_it,
632 lie_req1 `plusLIE` lie_req2,
633 tvs1 `unionBags` tvs2,
634 ids1 `unionBags` ids2,
635 lie_avail1 `plusLIE` lie_avail2)
637 tc_mb_pats (FunMonoBind name inf matches locn)
638 = newTyVarTy boxedTypeKind `thenNF_Tc` \ bndr_ty ->
639 tcVarPat sig_fn name bndr_ty `thenTc` \ bndr_id ->
641 complete_it xve = tcAddSrcLoc locn $
642 tcMatchesFun xve name bndr_ty matches `thenTc` \ (matches', lie) ->
643 returnTc (FunMonoBind bndr_id inf matches' locn, lie)
645 returnTc (complete_it, emptyLIE, emptyBag, unitBag (name, bndr_id), emptyLIE)
647 tc_mb_pats bind@(PatMonoBind pat grhss locn)
650 -- Figure out the appropriate kind for the pattern,
651 -- and generate a suitable type variable
653 Recursive -> newTyVarTy boxedTypeKind -- Recursive, so no unboxed types
654 NonRecursive -> newTyVarTy_OpenKind -- Non-recursive, so we permit unboxed types
655 ) `thenNF_Tc` \ pat_ty ->
657 -- Now typecheck the pattern
658 -- We don't support binding fresh type variables in the
659 -- pattern of a pattern binding. For example, this is illegal:
661 -- whereas this is ok
662 -- (x::Int, y::Bool) = e
664 -- We don't check explicitly for this problem. Instead, we simply
665 -- type check the pattern with tcPat. If the pattern mentions any
666 -- fresh tyvars we simply get an out-of-scope type variable error
667 tcPat sig_fn pat pat_ty `thenTc` \ (pat', lie_req, tvs, ids, lie_avail) ->
669 complete_it xve = tcAddSrcLoc locn $
670 tcAddErrCtxt (patMonoBindsCtxt bind) $
671 tcExtendLocalValEnv xve $
672 tcGRHSs grhss pat_ty PatBindRhs `thenTc` \ (grhss', lie) ->
673 returnTc (PatMonoBind pat' grhss' locn, lie)
675 returnTc (complete_it, lie_req, tvs, ids, lie_avail)
678 %************************************************************************
680 \subsection{Signatures}
682 %************************************************************************
684 @checkSigMatch@ does the next step in checking signature matching.
685 The tau-type part has already been unified. What we do here is to
686 check that this unification has not over-constrained the (polymorphic)
687 type variables of the original signature type.
689 The error message here is somewhat unsatisfactory, but it'll do for
693 checkSigMatch top_lvl binder_names mono_ids sigs
695 = mapTc check_one_sig sigs `thenTc_`
696 mapTc check_main_ctxt sigs `thenTc_`
698 -- Now unify the main_id with IO t, for any old t
699 tcSetErrCtxt mainTyCheckCtxt (
700 tcLookupTyCon ioTyCon_NAME `thenTc` \ ioTyCon ->
701 newTyVarTy boxedTypeKind `thenNF_Tc` \ t_tv ->
702 unifyTauTy ((mkTyConApp ioTyCon [t_tv]))
703 (idType main_mono_id)
705 returnTc (Just ([], emptyLIE))
708 = mapTc check_one_sig sigs `thenTc_`
709 mapTc check_one_ctxt all_sigs_but_first `thenTc_`
710 returnTc (Just (theta1, sig_lie))
713 = returnTc Nothing -- No constraints from type sigs
716 (TySigInfo _ id1 _ theta1 _ _ _ _ : all_sigs_but_first) = sigs
718 sig1_dict_tys = mk_dict_tys theta1
719 n_sig1_dict_tys = length sig1_dict_tys
720 sig_lie = mkLIE [inst | TySigInfo _ _ _ _ _ _ inst _ <- sigs]
722 maybe_main = find_main top_lvl binder_names mono_ids
723 main_bound_here = maybeToBool maybe_main
724 Just main_mono_id = maybe_main
726 -- CHECK THAT THE SIGNATURE TYVARS AND TAU_TYPES ARE OK
727 -- Doesn't affect substitution
728 check_one_sig (TySigInfo _ id sig_tyvars _ sig_tau _ _ src_loc)
729 = tcAddSrcLoc src_loc $
730 tcAddErrCtxtM (sigCtxt (sig_msg id) (idType id)) $
731 checkSigTyVars sig_tyvars
734 -- CHECK THAT ALL THE SIGNATURE CONTEXTS ARE UNIFIABLE
735 -- The type signatures on a mutually-recursive group of definitions
736 -- must all have the same context (or none).
738 -- We unify them because, with polymorphic recursion, their types
739 -- might not otherwise be related. This is a rather subtle issue.
741 check_one_ctxt sig@(TySigInfo _ id _ theta _ _ _ src_loc)
742 = tcAddSrcLoc src_loc $
743 tcAddErrCtxt (sigContextsCtxt id1 id) $
744 checkTc (length this_sig_dict_tys == n_sig1_dict_tys)
745 sigContextsErr `thenTc_`
746 unifyTauTyLists sig1_dict_tys this_sig_dict_tys
748 this_sig_dict_tys = mk_dict_tys theta
750 -- CHECK THAT FOR A GROUP INVOLVING Main.main, all
751 -- the signature contexts are empty (what a bore)
752 check_main_ctxt sig@(TySigInfo _ id _ theta _ _ _ src_loc)
753 = tcAddSrcLoc src_loc $
754 checkTc (null theta) (mainContextsErr id)
756 mk_dict_tys theta = [mkDictTy c ts | (c,ts) <- theta]
758 sig_msg id tidy_ty = sep [ptext SLIT("When checking the type signature"),
759 nest 4 (ppr id <+> dcolon <+> ppr tidy_ty)]
761 -- Search for Main.main in the binder_names, return corresponding mono_id
762 find_main NotTopLevel binder_names mono_ids = Nothing
763 find_main TopLevel binder_names mono_ids = go binder_names mono_ids
765 go (n:ns) (m:ms) | n == main_NAME = Just m
766 | otherwise = go ns ms
770 %************************************************************************
772 \subsection{SPECIALIZE pragmas}
774 %************************************************************************
777 @tcPragmaSigs@ munches up the "signatures" that arise through *user*
778 pragmas. It is convenient for them to appear in the @[RenamedSig]@
779 part of a binding because then the same machinery can be used for
780 moving them into place as is done for type signatures.
783 tcPragmaSigs :: [RenamedSig] -- The pragma signatures
784 -> TcM s (Name -> IdInfo, -- Maps name to the appropriate IdInfo
789 = mapAndUnzip3Tc tcPragmaSig sigs `thenTc` \ (maybe_info_modifiers, binds, lies) ->
791 prag_fn name = foldr ($) noIdInfo [f | Just (n,f) <- maybe_info_modifiers, n==name]
793 returnTc (prag_fn, andMonoBindList binds, plusLIEs lies)
796 The interesting case is for SPECIALISE pragmas. There are two forms.
797 Here's the first form:
799 f :: Ord a => [a] -> b -> b
800 {-# SPECIALIZE f :: [Int] -> b -> b #-}
803 For this we generate:
805 f* = /\ b -> let d1 = ...
809 where f* is a SpecPragmaId. The **sole** purpose of SpecPragmaIds is to
810 retain a right-hand-side that the simplifier will otherwise discard as
811 dead code... the simplifier has a flag that tells it not to discard
812 SpecPragmaId bindings.
814 In this case the f* retains a call-instance of the overloaded
815 function, f, (including appropriate dictionaries) so that the
816 specialiser will subsequently discover that there's a call of @f@ at
817 Int, and will create a specialisation for @f@. After that, the
818 binding for @f*@ can be discarded.
820 The second form is this:
822 f :: Ord a => [a] -> b -> b
823 {-# SPECIALIZE f :: [Int] -> b -> b = g #-}
826 Here @g@ is specified as a function that implements the specialised
827 version of @f@. Suppose that g has type (a->b->b); that is, g's type
828 is more general than that required. For this we generate
830 f@Int = /\b -> g Int b
834 Here @f@@Int@ is a SpecId, the specialised version of @f@. It inherits
835 f's export status etc. @f*@ is a SpecPragmaId, as before, which just serves
836 to prevent @f@@Int@ from being discarded prematurely. After specialisation,
837 if @f@@Int@ is going to be used at all it will be used explicitly, so the simplifier can
838 discard the f* binding.
840 Actually, there is really only point in giving a SPECIALISE pragma on exported things,
841 and the simplifer won't discard SpecIds for exporte things anyway, so maybe this is
845 tcPragmaSig :: RenamedSig -> TcM s (Maybe (Name, IdInfo -> IdInfo), TcMonoBinds, LIE)
846 tcPragmaSig (Sig _ _ _) = returnTc (Nothing, EmptyMonoBinds, emptyLIE)
847 tcPragmaSig (SpecInstSig _ _) = returnTc (Nothing, EmptyMonoBinds, emptyLIE)
849 tcPragmaSig (InlineSig name loc)
850 = returnTc (Just (name, setInlinePragInfo IWantToBeINLINEd), EmptyMonoBinds, emptyLIE)
852 tcPragmaSig (NoInlineSig name loc)
853 = returnTc (Just (name, setInlinePragInfo IMustNotBeINLINEd), EmptyMonoBinds, emptyLIE)
855 tcPragmaSig (SpecSig name poly_ty maybe_spec_name src_loc)
856 = -- SPECIALISE f :: forall b. theta => tau = g
857 tcAddSrcLoc src_loc $
858 tcAddErrCtxt (valSpecSigCtxt name poly_ty) $
860 -- Get and instantiate its alleged specialised type
861 tcHsType poly_ty `thenTc` \ sig_ty ->
863 -- Check that f has a more general type, and build a RHS for
864 -- the spec-pragma-id at the same time
865 tcExpr (HsVar name) sig_ty `thenTc` \ (spec_expr, spec_lie) ->
867 case maybe_spec_name of
868 Nothing -> -- Just specialise "f" by building a SpecPragmaId binding
869 -- It is the thing that makes sure we don't prematurely
870 -- dead-code-eliminate the binding we are really interested in.
871 newSpecPragmaId name sig_ty `thenNF_Tc` \ spec_id ->
872 returnTc (Nothing, VarMonoBind spec_id spec_expr, spec_lie)
874 Just g_name -> -- Don't create a SpecPragmaId. Instead add some suitable IdIfo
876 panic "Can't handle SPECIALISE with a '= g' part"
878 {- Not yet. Because we're still in the TcType world we
879 can't really add to the SpecEnv of the Id. Instead we have to
880 record the information in a different sort of Sig, and add it to
881 the IdInfo after zonking.
883 For now we just leave out this case
885 -- Get the type of f, and find out what types
886 -- f has to be instantiated at to give the signature type
887 tcLookupValue name `thenNF_Tc` \ f_id ->
888 tcInstTcType (idType f_id) `thenNF_Tc` \ (f_tyvars, f_rho) ->
891 (sig_tyvars, sig_theta, sig_tau) = splitSigmaTy sig_ty
892 (f_theta, f_tau) = splitRhoTy f_rho
893 sig_tyvar_set = mkVarSet sig_tyvars
895 unifyTauTy sig_tau f_tau `thenTc_`
897 tcPolyExpr str (HsVar g_name) (mkSigmaTy sig_tyvars f_theta sig_tau) `thenTc` \ (_, _,
900 tcPragmaSig other = pprTrace "tcPragmaSig: ignoring" (ppr other) $
901 returnTc (Nothing, EmptyMonoBinds, emptyLIE)
905 %************************************************************************
907 \subsection[TcBinds-errors]{Error contexts and messages}
909 %************************************************************************
913 patMonoBindsCtxt bind
914 = hang (ptext SLIT("In a pattern binding:")) 4 (ppr bind)
916 -----------------------------------------------
918 = sep [ptext SLIT("In a SPECIALIZE pragma for a value:"),
919 nest 4 (ppr v <+> dcolon <+> ppr ty)]
921 -----------------------------------------------
922 notAsPolyAsSigErr sig_tau mono_tyvars
923 = hang (ptext SLIT("A type signature is more polymorphic than the inferred type"))
924 4 (vcat [text "Can't for-all the type variable(s)" <+>
925 pprQuotedList mono_tyvars,
926 text "in the type" <+> quotes (ppr sig_tau)
929 -----------------------------------------------
930 badMatchErr sig_ty inferred_ty
931 = hang (ptext SLIT("Type signature doesn't match inferred type"))
932 4 (vcat [hang (ptext SLIT("Signature:")) 4 (ppr sig_ty),
933 hang (ptext SLIT("Inferred :")) 4 (ppr inferred_ty)
936 -----------------------------------------------
938 = ptext SLIT("variable in a lazy pattern binding has unboxed type: ")
941 -----------------------------------------------
943 = ptext SLIT("When checking the type signature(s) for") <+> pprQuotedList ids
945 -----------------------------------------------
947 = ptext SLIT("Mismatched contexts")
949 sigContextsCtxt s1 s2
950 = hang (hsep [ptext SLIT("When matching the contexts of the signatures for"),
951 quotes (ppr s1), ptext SLIT("and"), quotes (ppr s2)])
952 4 (ptext SLIT("(the signature contexts in a mutually recursive group should all be identical)"))
955 | getName id == main_NAME = ptext SLIT("Main.main cannot be overloaded")
957 = quotes (ppr id) <+> ptext SLIT("cannot be overloaded, because it is mutually recursive with Main.main")
960 = hsep [ptext SLIT("When checking that"), ppr main_NAME, ptext SLIT("has the required type")]
962 -----------------------------------------------
963 unliftedBindErr flavour mbind
964 = hang (text flavour <+> ptext SLIT("bindings for unlifted types aren't allowed"))
967 existentialExplode mbinds
968 = hang (vcat [text "My brain just exploded.",
969 text "I can't handle pattern bindings for existentially-quantified constructors.",
970 text "In the binding group"])