2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 \section[TcBinds]{TcBinds}
7 module TcBinds ( tcBindsAndThen, tcTopBinds, tcMonoBinds, tcSpecSigs ) where
9 #include "HsVersions.h"
11 import {-# SOURCE #-} TcMatches ( tcGRHSs, tcMatchesFun )
12 import {-# SOURCE #-} TcExpr ( tcExpr, tcMonoExpr )
14 import CmdLineOpts ( DynFlag(Opt_NoMonomorphismRestriction) )
15 import HsSyn ( HsExpr(..), HsBinds(..), MonoBinds(..), Sig(..),
16 Match(..), HsMatchContext(..), mkMonoBind,
17 collectMonoBinders, andMonoBinds,
18 collectSigTysFromMonoBinds
20 import RnHsSyn ( RenamedHsBinds, RenamedSig, RenamedMonoBinds )
21 import TcHsSyn ( TcHsBinds, TcMonoBinds, TcId, zonkId, mkHsLet )
24 import Inst ( InstOrigin(..), newDicts, newIPDict, instToId )
25 import TcEnv ( tcExtendLocalValEnv, tcExtendLocalValEnv2, newLocalName )
26 import TcUnify ( unifyTauTyLists, checkSigTyVarsWrt, sigCtxt )
27 import TcSimplify ( tcSimplifyInfer, tcSimplifyInferCheck, tcSimplifyRestricted,
28 tcSimplifyToDicts, tcSimplifyIPs )
29 import TcMonoType ( tcHsSigType, UserTypeCtxt(..), TcSigInfo(..),
30 tcTySig, maybeSig, tcSigPolyId, tcSigMonoId, tcAddScopedTyVars
32 import TcPat ( tcPat, tcSubPat, tcMonoPatBndr )
33 import TcSimplify ( bindInstsOfLocalFuns )
34 import TcMType ( newTyVar, newTyVarTy, newHoleTyVarTy,
35 zonkTcTyVarToTyVar, readHoleResult
37 import TcType ( TcTyVar, mkTyVarTy, mkForAllTys, mkFunTys, tyVarsOfType,
38 mkPredTy, mkForAllTy, isUnLiftedType,
39 unliftedTypeKind, liftedTypeKind, openTypeKind, eqKind
42 import CoreFVs ( idFreeTyVars )
43 import Id ( mkLocalId, mkSpecPragmaId, setInlinePragma )
44 import Var ( idType, idName )
45 import Name ( Name, getSrcLoc )
47 import Var ( tyVarKind )
50 import Util ( isIn, equalLength )
51 import BasicTypes ( TopLevelFlag(..), RecFlag(..), isNonRec, isRec,
52 isNotTopLevel, isAlwaysActive )
53 import FiniteMap ( listToFM, lookupFM )
58 %************************************************************************
60 \subsection{Type-checking bindings}
62 %************************************************************************
64 @tcBindsAndThen@ typechecks a @HsBinds@. The "and then" part is because
65 it needs to know something about the {\em usage} of the things bound,
66 so that it can create specialisations of them. So @tcBindsAndThen@
67 takes a function which, given an extended environment, E, typechecks
68 the scope of the bindings returning a typechecked thing and (most
69 important) an LIE. It is this LIE which is then used as the basis for
70 specialising the things bound.
72 @tcBindsAndThen@ also takes a "combiner" which glues together the
73 bindings and the "thing" to make a new "thing".
75 The real work is done by @tcBindWithSigsAndThen@.
77 Recursive and non-recursive binds are handled in essentially the same
78 way: because of uniques there are no scoping issues left. The only
79 difference is that non-recursive bindings can bind primitive values.
81 Even for non-recursive binding groups we add typings for each binder
82 to the LVE for the following reason. When each individual binding is
83 checked the type of its LHS is unified with that of its RHS; and
84 type-checking the LHS of course requires that the binder is in scope.
86 At the top-level the LIE is sure to contain nothing but constant
87 dictionaries, which we resolve at the module level.
90 tcTopBinds :: RenamedHsBinds -> TcM (TcMonoBinds, TcLclEnv)
92 = tc_binds_and_then TopLevel glue binds $
93 getLclEnv `thenM` \ env ->
94 returnM (EmptyMonoBinds, env)
96 -- The top level bindings are flattened into a giant
97 -- implicitly-mutually-recursive MonoBinds
98 glue binds1 (binds2, env) = (flatten binds1 `AndMonoBinds` binds2, env)
99 flatten EmptyBinds = EmptyMonoBinds
100 flatten (b1 `ThenBinds` b2) = flatten b1 `AndMonoBinds` flatten b2
101 flatten (MonoBind b _ _) = b
102 -- Can't have a IPBinds at top level
106 :: (TcHsBinds -> thing -> thing) -- Combinator
111 tcBindsAndThen = tc_binds_and_then NotTopLevel
113 tc_binds_and_then top_lvl combiner EmptyBinds do_next
115 tc_binds_and_then top_lvl combiner (MonoBind EmptyMonoBinds sigs is_rec) do_next
118 tc_binds_and_then top_lvl combiner (ThenBinds b1 b2) do_next
119 = tc_binds_and_then top_lvl combiner b1 $
120 tc_binds_and_then top_lvl combiner b2 $
123 tc_binds_and_then top_lvl combiner (IPBinds binds is_with) do_next
124 = getLIE do_next `thenM` \ (result, expr_lie) ->
125 mapAndUnzipM tc_ip_bind binds `thenM` \ (avail_ips, binds') ->
127 -- If the binding binds ?x = E, we must now
128 -- discharge any ?x constraints in expr_lie
129 tcSimplifyIPs avail_ips expr_lie `thenM` \ dict_binds ->
131 returnM (combiner (IPBinds binds' is_with) $
132 combiner (mkMonoBind Recursive dict_binds) result)
134 -- I wonder if we should do these one at at time
137 tc_ip_bind (ip, expr)
138 = newTyVarTy openTypeKind `thenM` \ ty ->
139 getSrcLocM `thenM` \ loc ->
140 newIPDict (IPBind ip) ip ty `thenM` \ (ip', ip_inst) ->
141 tcMonoExpr expr ty `thenM` \ expr' ->
142 returnM (ip_inst, (ip', expr'))
144 tc_binds_and_then top_lvl combiner (MonoBind bind sigs is_rec) do_next
145 = -- BRING ANY SCOPED TYPE VARIABLES INTO SCOPE
146 -- Notice that they scope over
147 -- a) the type signatures in the binding group
148 -- b) the bindings in the group
149 -- c) the scope of the binding group (the "in" part)
150 tcAddScopedTyVars (collectSigTysFromMonoBinds bind) $
152 tcBindWithSigs top_lvl bind sigs is_rec `thenM` \ (poly_binds, poly_ids) ->
155 -- Extend the environment to bind the new polymorphic Ids
156 tcExtendLocalValEnv poly_ids $
158 -- Build bindings and IdInfos corresponding to user pragmas
159 tcSpecSigs sigs `thenM` \ prag_binds ->
161 -- Now do whatever happens next, in the augmented envt
162 do_next `thenM` \ thing ->
164 returnM (prag_binds, thing)
165 ) `thenM` \ ((prag_binds, thing), lie) ->
169 -- For the top level don't bother will all this bindInstsOfLocalFuns stuff
170 -- All the top level things are rec'd together anyway, so it's fine to
171 -- leave them to the tcSimplifyTop, and quite a bit faster too
173 -> extendLIEs lie `thenM_`
174 returnM (combiner (mkMonoBind Recursive (poly_binds `andMonoBinds` prag_binds))
178 -> bindInstsOfLocalFuns lie poly_ids `thenM` \ lie_binds ->
179 -- Create specialisations of functions bound here
181 -- We want to keep non-recursive things non-recursive
182 -- so that we desugar unlifted bindings correctly
185 combiner (mkMonoBind Recursive (
186 poly_binds `andMonoBinds`
187 lie_binds `andMonoBinds`
192 combiner (mkMonoBind NonRecursive poly_binds) $
193 combiner (mkMonoBind NonRecursive prag_binds) $
194 combiner (mkMonoBind Recursive lie_binds) $
195 -- NB: the binds returned by tcSimplify and bindInstsOfLocalFuns
196 -- aren't guaranteed in dependency order (though we could change
197 -- that); hence the Recursive marker.
202 %************************************************************************
204 \subsection{tcBindWithSigs}
206 %************************************************************************
208 @tcBindWithSigs@ deals with a single binding group. It does generalisation,
209 so all the clever stuff is in here.
211 * binder_names and mbind must define the same set of Names
213 * The Names in tc_ty_sigs must be a subset of binder_names
215 * The Ids in tc_ty_sigs don't necessarily have to have the same name
216 as the Name in the tc_ty_sig
222 -> [RenamedSig] -- Used solely to get INLINE, NOINLINE sigs
224 -> TcM (TcMonoBinds, [TcId])
226 tcBindWithSigs top_lvl mbind sigs is_rec
227 = -- TYPECHECK THE SIGNATURES
228 recoverM (returnM []) (
229 mappM tcTySig [sig | sig@(Sig name _ _) <- sigs]
230 ) `thenM` \ tc_ty_sigs ->
232 -- SET UP THE MAIN RECOVERY; take advantage of any type sigs
234 -- If typechecking the binds fails, then return with each
235 -- signature-less binder given type (forall a.a), to minimise subsequent
237 newTyVar liftedTypeKind `thenM` \ alpha_tv ->
239 forall_a_a = mkForAllTy alpha_tv (mkTyVarTy alpha_tv)
240 binder_names = collectMonoBinders mbind
241 poly_ids = map mk_dummy binder_names
242 mk_dummy name = case maybeSig tc_ty_sigs name of
243 Just sig -> tcSigPolyId sig -- Signature
244 Nothing -> mkLocalId name forall_a_a -- No signature
246 returnM (EmptyMonoBinds, poly_ids)
249 -- TYPECHECK THE BINDINGS
250 getLIE (tcMonoBinds mbind tc_ty_sigs is_rec) `thenM` \ ((mbind', binder_names, mono_ids), lie_req) ->
252 tau_tvs = foldr (unionVarSet . tyVarsOfType . idType) emptyVarSet mono_ids
256 -- (it seems a bit crude to have to do getLIE twice,
257 -- but I can't see a better way just now)
258 addSrcLoc (minimum (map getSrcLoc binder_names)) $
259 addErrCtxt (genCtxt binder_names) $
260 getLIE (generalise binder_names mbind tau_tvs lie_req tc_ty_sigs)
261 `thenM` \ ((tc_tyvars_to_gen, dict_binds, dict_ids), lie_free) ->
264 -- ZONK THE GENERALISED TYPE VARIABLES TO REAL TyVars
265 -- This commits any unbound kind variables to boxed kind, by unification
266 -- It's important that the final quanfified type variables
267 -- are fully zonked, *including boxity*, because they'll be
268 -- included in the forall types of the polymorphic Ids.
269 -- At calls of these Ids we'll instantiate fresh type variables from
270 -- them, and we use their boxity then.
271 mappM zonkTcTyVarToTyVar tc_tyvars_to_gen `thenM` \ real_tyvars_to_gen ->
274 -- It's important that the dict Ids are zonked, including the boxity set
275 -- in the previous step, because they are later used to form the type of
276 -- the polymorphic thing, and forall-types must be zonked so far as
277 -- their bound variables are concerned
278 mappM zonkId dict_ids `thenM` \ zonked_dict_ids ->
279 mappM zonkId mono_ids `thenM` \ zonked_mono_ids ->
281 -- BUILD THE POLYMORPHIC RESULT IDs
283 exports = zipWith mk_export binder_names zonked_mono_ids
284 poly_ids = [poly_id | (_, poly_id, _) <- exports]
285 dict_tys = map idType zonked_dict_ids
287 inlines = mkNameSet [name | InlineSig True name _ loc <- sigs]
288 -- Any INLINE sig (regardless of phase control)
289 -- makes the RHS look small
290 inline_phases = listToFM [(name, phase) | InlineSig _ name phase _ <- sigs,
291 not (isAlwaysActive phase)]
292 -- Set the IdInfo field to control the inline phase
293 -- AlwaysActive is the default, so don't bother with them
295 mk_export binder_name zonked_mono_id
297 attachInlinePhase inline_phases poly_id,
301 case maybeSig tc_ty_sigs binder_name of
302 Just (TySigInfo sig_poly_id sig_tyvars _ _ _ _ _) ->
303 (sig_tyvars, sig_poly_id)
304 Nothing -> (real_tyvars_to_gen, new_poly_id)
306 new_poly_id = mkLocalId binder_name poly_ty
307 poly_ty = mkForAllTys real_tyvars_to_gen
309 $ idType zonked_mono_id
310 -- It's important to build a fully-zonked poly_ty, because
311 -- we'll slurp out its free type variables when extending the
312 -- local environment (tcExtendLocalValEnv); if it's not zonked
313 -- it appears to have free tyvars that aren't actually free
317 traceTc (text "binding:" <+> ppr ((zonked_dict_ids, dict_binds),
318 exports, map idType poly_ids)) `thenM_`
320 -- Check for an unlifted, non-overloaded group
321 -- In that case we must make extra checks
322 if any (isUnLiftedType . idType) zonked_mono_ids && null zonked_dict_ids
323 then -- Some bindings are unlifted
324 checkUnliftedBinds top_lvl is_rec real_tyvars_to_gen mbind `thenM_`
326 extendLIEs lie_req `thenM_`
328 AbsBinds [] [] exports inlines mbind',
329 -- Do not generate even any x=y bindings
333 else -- The normal case
334 extendLIEs lie_free `thenM_`
336 AbsBinds real_tyvars_to_gen
340 (dict_binds `andMonoBinds` mbind'),
344 attachInlinePhase inline_phases bndr
345 = case lookupFM inline_phases (idName bndr) of
346 Just prag -> bndr `setInlinePragma` prag
349 -- Check that non-overloaded unlifted bindings are
352 -- c) non-polymorphic
353 -- d) not a multiple-binding group (more or less implied by (a))
355 checkUnliftedBinds top_lvl is_rec real_tyvars_to_gen mbind
356 = ASSERT( not (any ((eqKind unliftedTypeKind) . tyVarKind) real_tyvars_to_gen) )
357 -- The instCantBeGeneralised stuff in tcSimplify should have
358 -- already raised an error if we're trying to generalise an
359 -- unboxed tyvar (NB: unboxed tyvars are always introduced
360 -- along with a class constraint) and it's better done there
361 -- because we have more precise origin information.
362 -- That's why we just use an ASSERT here.
364 checkTc (isNotTopLevel top_lvl)
365 (unliftedBindErr "Top-level" mbind) `thenM_`
366 checkTc (isNonRec is_rec)
367 (unliftedBindErr "Recursive" mbind) `thenM_`
368 checkTc (single_bind mbind)
369 (unliftedBindErr "Multiple" mbind) `thenM_`
370 checkTc (null real_tyvars_to_gen)
371 (unliftedBindErr "Polymorphic" mbind)
374 single_bind (PatMonoBind _ _ _) = True
375 single_bind (FunMonoBind _ _ _ _) = True
376 single_bind other = False
380 Polymorphic recursion
381 ~~~~~~~~~~~~~~~~~~~~~
382 The game plan for polymorphic recursion in the code above is
384 * Bind any variable for which we have a type signature
385 to an Id with a polymorphic type. Then when type-checking
386 the RHSs we'll make a full polymorphic call.
388 This fine, but if you aren't a bit careful you end up with a horrendous
389 amount of partial application and (worse) a huge space leak. For example:
391 f :: Eq a => [a] -> [a]
394 If we don't take care, after typechecking we get
396 f = /\a -> \d::Eq a -> let f' = f a d
400 Notice the the stupid construction of (f a d), which is of course
401 identical to the function we're executing. In this case, the
402 polymorphic recursion isn't being used (but that's a very common case).
405 f = /\a -> \d::Eq a -> letrec
406 fm = \ys:[a] -> ...fm...
410 This can lead to a massive space leak, from the following top-level defn
416 Now (f dEqInt) evaluates to a lambda that has f' as a free variable; but
417 f' is another thunk which evaluates to the same thing... and you end
418 up with a chain of identical values all hung onto by the CAF ff.
422 = let f' = f Int dEqInt in \ys. ...f'...
424 = let f' = let f' = f Int dEqInt in \ys. ...f'...
428 Solution: when typechecking the RHSs we always have in hand the
429 *monomorphic* Ids for each binding. So we just need to make sure that
430 if (Method f a d) shows up in the constraints emerging from (...f...)
431 we just use the monomorphic Id. We achieve this by adding monomorphic Ids
432 to the "givens" when simplifying constraints. That's what the "lies_avail"
436 %************************************************************************
438 \subsection{getTyVarsToGen}
440 %************************************************************************
443 generalise binder_names mbind tau_tvs lie_req sigs =
445 -- check for -fno-monomorphism-restriction
446 doptM Opt_NoMonomorphismRestriction `thenM` \ no_MR ->
447 let is_unrestricted | no_MR = True
448 | otherwise = isUnRestrictedGroup tysig_names mbind
451 if not is_unrestricted then -- RESTRICTED CASE
452 -- Check signature contexts are empty
453 checkTc (all is_mono_sig sigs)
454 (restrictedBindCtxtErr binder_names) `thenM_`
456 -- Now simplify with exactly that set of tyvars
457 -- We have to squash those Methods
458 tcSimplifyRestricted doc tau_tvs lie_req `thenM` \ (qtvs, binds) ->
460 -- Check that signature type variables are OK
461 checkSigsTyVars qtvs sigs `thenM` \ final_qtvs ->
463 returnM (final_qtvs, binds, [])
465 else if null sigs then -- UNRESTRICTED CASE, NO TYPE SIGS
466 tcSimplifyInfer doc tau_tvs lie_req
468 else -- UNRESTRICTED CASE, WITH TYPE SIGS
469 -- CHECKING CASE: Unrestricted group, there are type signatures
470 -- Check signature contexts are identical
471 checkSigsCtxts sigs `thenM` \ (sig_avails, sig_dicts) ->
473 -- Check that the needed dicts can be
474 -- expressed in terms of the signature ones
475 tcSimplifyInferCheck doc tau_tvs sig_avails lie_req `thenM` \ (forall_tvs, dict_binds) ->
477 -- Check that signature type variables are OK
478 checkSigsTyVars forall_tvs sigs `thenM` \ final_qtvs ->
480 returnM (final_qtvs, dict_binds, sig_dicts)
483 tysig_names = map (idName . tcSigPolyId) sigs
484 is_mono_sig (TySigInfo _ _ theta _ _ _ _) = null theta
486 doc = ptext SLIT("type signature(s) for") <+> pprBinders binder_names
488 -----------------------
489 -- CHECK THAT ALL THE SIGNATURE CONTEXTS ARE UNIFIABLE
490 -- The type signatures on a mutually-recursive group of definitions
491 -- must all have the same context (or none).
493 -- We unify them because, with polymorphic recursion, their types
494 -- might not otherwise be related. This is a rather subtle issue.
496 checkSigsCtxts sigs@(TySigInfo id1 sig_tvs theta1 _ _ _ src_loc : other_sigs)
497 = addSrcLoc src_loc $
498 mappM_ check_one other_sigs `thenM_`
500 returnM ([], []) -- Non-overloaded type signatures
502 newDicts SignatureOrigin theta1 `thenM` \ sig_dicts ->
504 -- The "sig_avails" is the stuff available. We get that from
505 -- the context of the type signature, BUT ALSO the lie_avail
506 -- so that polymorphic recursion works right (see comments at end of fn)
507 sig_avails = sig_dicts ++ sig_meths
509 returnM (sig_avails, map instToId sig_dicts)
511 sig1_dict_tys = map mkPredTy theta1
512 sig_meths = concat [insts | TySigInfo _ _ _ _ _ insts _ <- sigs]
514 check_one sig@(TySigInfo id _ theta _ _ _ _)
515 = addErrCtxt (sigContextsCtxt id1 id) $
516 checkTc (equalLength theta theta1) sigContextsErr `thenM_`
517 unifyTauTyLists sig1_dict_tys (map mkPredTy theta)
519 checkSigsTyVars :: [TcTyVar] -> [TcSigInfo] -> TcM [TcTyVar]
520 checkSigsTyVars qtvs sigs
521 = mappM check_one sigs `thenM` \ sig_tvs_s ->
523 -- Sigh. Make sure that all the tyvars in the type sigs
524 -- appear in the returned ty var list, which is what we are
525 -- going to generalise over. Reason: we occasionally get
527 -- type T a = () -> ()
530 -- Here, 'a' won't appear in qtvs, so we have to add it
532 sig_tvs = foldr (unionVarSet . mkVarSet) emptyVarSet sig_tvs_s
533 all_tvs = mkVarSet qtvs `unionVarSet` sig_tvs
535 returnM (varSetElems all_tvs)
537 check_one (TySigInfo id sig_tyvars sig_theta sig_tau _ _ src_loc)
538 = addSrcLoc src_loc $
539 addErrCtxt (ptext SLIT("When checking the type signature for")
540 <+> quotes (ppr id)) $
541 addErrCtxtM (sigCtxt id sig_tyvars sig_theta sig_tau) $
542 checkSigTyVarsWrt (idFreeTyVars id) sig_tyvars
545 @getTyVarsToGen@ decides what type variables to generalise over.
547 For a "restricted group" -- see the monomorphism restriction
548 for a definition -- we bind no dictionaries, and
549 remove from tyvars_to_gen any constrained type variables
551 *Don't* simplify dicts at this point, because we aren't going
552 to generalise over these dicts. By the time we do simplify them
553 we may well know more. For example (this actually came up)
555 f x = array ... xs where xs = [1,2,3,4,5]
556 We don't want to generate lots of (fromInt Int 1), (fromInt Int 2)
557 stuff. If we simplify only at the f-binding (not the xs-binding)
558 we'll know that the literals are all Ints, and we can just produce
561 Find all the type variables involved in overloading, the
562 "constrained_tyvars". These are the ones we *aren't* going to
563 generalise. We must be careful about doing this:
565 (a) If we fail to generalise a tyvar which is not actually
566 constrained, then it will never, ever get bound, and lands
567 up printed out in interface files! Notorious example:
568 instance Eq a => Eq (Foo a b) where ..
569 Here, b is not constrained, even though it looks as if it is.
570 Another, more common, example is when there's a Method inst in
571 the LIE, whose type might very well involve non-overloaded
573 [NOTE: Jan 2001: I don't understand the problem here so I'm doing
574 the simple thing instead]
576 (b) On the other hand, we mustn't generalise tyvars which are constrained,
577 because we are going to pass on out the unmodified LIE, with those
578 tyvars in it. They won't be in scope if we've generalised them.
580 So we are careful, and do a complete simplification just to find the
581 constrained tyvars. We don't use any of the results, except to
582 find which tyvars are constrained.
585 isUnRestrictedGroup :: [Name] -- Signatures given for these
589 is_elem v vs = isIn "isUnResMono" v vs
591 isUnRestrictedGroup sigs (PatMonoBind other _ _) = False
592 isUnRestrictedGroup sigs (VarMonoBind v _) = v `is_elem` sigs
593 isUnRestrictedGroup sigs (FunMonoBind v _ matches _) = isUnRestrictedMatch matches ||
595 isUnRestrictedGroup sigs (AndMonoBinds mb1 mb2) = isUnRestrictedGroup sigs mb1 &&
596 isUnRestrictedGroup sigs mb2
597 isUnRestrictedGroup sigs EmptyMonoBinds = True
599 isUnRestrictedMatch (Match [] _ _ : _) = False -- No args => like a pattern binding
600 isUnRestrictedMatch other = True -- Some args => a function binding
604 %************************************************************************
606 \subsection{tcMonoBind}
608 %************************************************************************
610 @tcMonoBinds@ deals with a single @MonoBind@.
611 The signatures have been dealt with already.
614 tcMonoBinds :: RenamedMonoBinds
618 [Name], -- Bound names
619 [TcId]) -- Corresponding monomorphic bound things
621 tcMonoBinds mbinds tc_ty_sigs is_rec
622 = tc_mb_pats mbinds `thenM` \ (complete_it, tvs, ids, lie_avail) ->
624 id_list = bagToList ids
625 (names, mono_ids) = unzip id_list
627 -- This last defn is the key one:
628 -- extend the val envt with bindings for the
629 -- things bound in this group, overriding the monomorphic
630 -- ids with the polymorphic ones from the pattern
631 extra_val_env = case is_rec of
632 Recursive -> map mk_bind id_list
635 -- Don't know how to deal with pattern-bound existentials yet
636 checkTc (isEmptyBag tvs && null lie_avail)
637 (existentialExplode mbinds) `thenM_`
639 -- *Before* checking the RHSs, but *after* checking *all* the patterns,
640 -- extend the envt with bindings for all the bound ids;
641 -- and *then* override with the polymorphic Ids from the signatures
642 -- That is the whole point of the "complete_it" stuff.
644 -- There's a further wrinkle: we have to delay extending the environment
645 -- until after we've dealt with any pattern-bound signature type variables
646 -- Consider f (x::a) = ...f...
647 -- We're going to check that a isn't unified with anything in the envt,
648 -- so f itself had better not be! So we pass the envt binding f into
649 -- complete_it, which extends the actual envt in TcMatches.tcMatch, after
650 -- dealing with the signature tyvars
652 complete_it extra_val_env `thenM` \ mbinds' ->
654 returnM (mbinds', names, mono_ids)
657 mk_bind (name, mono_id) = case maybeSig tc_ty_sigs name of
658 Nothing -> (name, mono_id)
659 Just sig -> (idName poly_id, poly_id)
661 poly_id = tcSigPolyId sig
663 tc_mb_pats EmptyMonoBinds
664 = returnM (\ xve -> returnM EmptyMonoBinds, emptyBag, emptyBag, [])
666 tc_mb_pats (AndMonoBinds mb1 mb2)
667 = tc_mb_pats mb1 `thenM` \ (complete_it1, tvs1, ids1, lie_avail1) ->
668 tc_mb_pats mb2 `thenM` \ (complete_it2, tvs2, ids2, lie_avail2) ->
670 complete_it xve = complete_it1 xve `thenM` \ mb1' ->
671 complete_it2 xve `thenM` \ mb2' ->
672 returnM (AndMonoBinds mb1' mb2')
674 returnM (complete_it,
675 tvs1 `unionBags` tvs2,
676 ids1 `unionBags` ids2,
677 lie_avail1 ++ lie_avail2)
679 tc_mb_pats (FunMonoBind name inf matches locn)
680 = (case maybeSig tc_ty_sigs name of
681 Just sig -> returnM (tcSigMonoId sig)
682 Nothing -> newLocalName name `thenM` \ bndr_name ->
683 newTyVarTy openTypeKind `thenM` \ bndr_ty ->
684 -- NB: not a 'hole' tyvar; since there is no type
685 -- signature, we revert to ordinary H-M typechecking
686 -- which means the variable gets an inferred tau-type
687 returnM (mkLocalId bndr_name bndr_ty)
688 ) `thenM` \ bndr_id ->
690 bndr_ty = idType bndr_id
691 complete_it xve = addSrcLoc locn $
692 tcMatchesFun xve name bndr_ty matches `thenM` \ matches' ->
693 returnM (FunMonoBind bndr_id inf matches' locn)
695 returnM (complete_it, emptyBag, unitBag (name, bndr_id), [])
697 tc_mb_pats bind@(PatMonoBind pat grhss locn)
699 newHoleTyVarTy `thenM` \ pat_ty ->
701 -- Now typecheck the pattern
702 -- We do now support binding fresh (not-already-in-scope) scoped
703 -- type variables in the pattern of a pattern binding.
704 -- For example, this is now legal:
706 -- The type variables are brought into scope in tc_binds_and_then,
707 -- so we don't have to do anything here.
709 tcPat tc_pat_bndr pat pat_ty `thenM` \ (pat', tvs, ids, lie_avail) ->
710 readHoleResult pat_ty `thenM` \ pat_ty' ->
712 complete_it xve = addSrcLoc locn $
713 addErrCtxt (patMonoBindsCtxt bind) $
714 tcExtendLocalValEnv2 xve $
715 tcGRHSs PatBindRhs grhss pat_ty' `thenM` \ grhss' ->
716 returnM (PatMonoBind pat' grhss' locn)
718 returnM (complete_it, tvs, ids, lie_avail)
720 -- tc_pat_bndr is used when dealing with a LHS binder in a pattern.
721 -- If there was a type sig for that Id, we want to make it much
722 -- as if that type signature had been on the binder as a SigPatIn.
723 -- We check for a type signature; if there is one, we use the mono_id
724 -- from the signature. This is how we make sure the tau part of the
725 -- signature actually matches the type of the LHS; then tc_mb_pats
726 -- ensures the LHS and RHS have the same type
728 tc_pat_bndr name pat_ty
729 = case maybeSig tc_ty_sigs name of
731 -> newLocalName name `thenM` \ bndr_name ->
732 tcMonoPatBndr bndr_name pat_ty
734 Just sig -> addSrcLoc (getSrcLoc name) $
735 tcSubPat (idType mono_id) pat_ty `thenM` \ co_fn ->
736 returnM (co_fn, mono_id)
738 mono_id = tcSigMonoId sig
742 %************************************************************************
744 \subsection{SPECIALIZE pragmas}
746 %************************************************************************
748 @tcSpecSigs@ munches up the specialisation "signatures" that arise through *user*
749 pragmas. It is convenient for them to appear in the @[RenamedSig]@
750 part of a binding because then the same machinery can be used for
751 moving them into place as is done for type signatures.
756 f :: Ord a => [a] -> b -> b
757 {-# SPECIALIZE f :: [Int] -> b -> b #-}
760 For this we generate:
762 f* = /\ b -> let d1 = ...
766 where f* is a SpecPragmaId. The **sole** purpose of SpecPragmaIds is to
767 retain a right-hand-side that the simplifier will otherwise discard as
768 dead code... the simplifier has a flag that tells it not to discard
769 SpecPragmaId bindings.
771 In this case the f* retains a call-instance of the overloaded
772 function, f, (including appropriate dictionaries) so that the
773 specialiser will subsequently discover that there's a call of @f@ at
774 Int, and will create a specialisation for @f@. After that, the
775 binding for @f*@ can be discarded.
777 We used to have a form
778 {-# SPECIALISE f :: <type> = g #-}
779 which promised that g implemented f at <type>, but we do that with
781 {-# SPECIALISE (f::<type) = g #-}
784 tcSpecSigs :: [RenamedSig] -> TcM TcMonoBinds
785 tcSpecSigs (SpecSig name poly_ty src_loc : sigs)
786 = -- SPECIALISE f :: forall b. theta => tau = g
788 addErrCtxt (valSpecSigCtxt name poly_ty) $
790 -- Get and instantiate its alleged specialised type
791 tcHsSigType (FunSigCtxt name) poly_ty `thenM` \ sig_ty ->
793 -- Check that f has a more general type, and build a RHS for
794 -- the spec-pragma-id at the same time
795 getLIE (tcExpr (HsVar name) sig_ty) `thenM` \ (spec_expr, spec_lie) ->
797 -- Squeeze out any Methods (see comments with tcSimplifyToDicts)
798 tcSimplifyToDicts spec_lie `thenM` \ spec_binds ->
800 -- Just specialise "f" by building a SpecPragmaId binding
801 -- It is the thing that makes sure we don't prematurely
802 -- dead-code-eliminate the binding we are really interested in.
803 newLocalName name `thenM` \ spec_name ->
805 spec_bind = VarMonoBind (mkSpecPragmaId spec_name sig_ty)
806 (mkHsLet spec_binds spec_expr)
809 -- Do the rest and combine
810 tcSpecSigs sigs `thenM` \ binds_rest ->
811 returnM (binds_rest `andMonoBinds` spec_bind)
813 tcSpecSigs (other_sig : sigs) = tcSpecSigs sigs
814 tcSpecSigs [] = returnM EmptyMonoBinds
818 %************************************************************************
820 \subsection[TcBinds-errors]{Error contexts and messages}
822 %************************************************************************
826 patMonoBindsCtxt bind
827 = hang (ptext SLIT("In a pattern binding:")) 4 (ppr bind)
829 -----------------------------------------------
831 = sep [ptext SLIT("In a SPECIALIZE pragma for a value:"),
832 nest 4 (ppr v <+> dcolon <+> ppr ty)]
834 -----------------------------------------------
835 sigContextsErr = ptext SLIT("Mismatched contexts")
837 sigContextsCtxt s1 s2
838 = vcat [ptext SLIT("When matching the contexts of the signatures for"),
839 nest 2 (vcat [ppr s1 <+> dcolon <+> ppr (idType s1),
840 ppr s2 <+> dcolon <+> ppr (idType s2)]),
841 ptext SLIT("The signature contexts in a mutually recursive group should all be identical")]
843 -----------------------------------------------
844 unliftedBindErr flavour mbind
845 = hang (text flavour <+> ptext SLIT("bindings for unlifted types aren't allowed:"))
848 -----------------------------------------------
849 existentialExplode mbinds
850 = hang (vcat [text "My brain just exploded.",
851 text "I can't handle pattern bindings for existentially-quantified constructors.",
852 text "In the binding group"])
855 -----------------------------------------------
856 restrictedBindCtxtErr binder_names
857 = hang (ptext SLIT("Illegal overloaded type signature(s)"))
858 4 (vcat [ptext SLIT("in a binding group for") <+> pprBinders binder_names,
859 ptext SLIT("that falls under the monomorphism restriction")])
862 = ptext SLIT("When generalising the type(s) for") <+> pprBinders binder_names
864 -- Used in error messages
865 -- Use quotes for a single one; they look a bit "busy" for several
866 pprBinders [bndr] = quotes (ppr bndr)
867 pprBinders bndrs = pprWithCommas ppr bndrs