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 traceTc (text "tcBindsWithSigs: error recovery" <+> ppr binder_names) `thenM_`
247 returnM (EmptyMonoBinds, poly_ids)
250 -- TYPECHECK THE BINDINGS
251 getLIE (tcMonoBinds mbind tc_ty_sigs is_rec) `thenM` \ ((mbind', binder_names, mono_ids), lie_req) ->
253 tau_tvs = foldr (unionVarSet . tyVarsOfType . idType) emptyVarSet mono_ids
257 -- (it seems a bit crude to have to do getLIE twice,
258 -- but I can't see a better way just now)
259 addSrcLoc (minimum (map getSrcLoc binder_names)) $
260 addErrCtxt (genCtxt binder_names) $
261 getLIE (generalise binder_names mbind tau_tvs lie_req tc_ty_sigs)
262 `thenM` \ ((tc_tyvars_to_gen, dict_binds, dict_ids), lie_free) ->
265 -- ZONK THE GENERALISED TYPE VARIABLES TO REAL TyVars
266 -- This commits any unbound kind variables to boxed kind, by unification
267 -- It's important that the final quanfified type variables
268 -- are fully zonked, *including boxity*, because they'll be
269 -- included in the forall types of the polymorphic Ids.
270 -- At calls of these Ids we'll instantiate fresh type variables from
271 -- them, and we use their boxity then.
272 mappM zonkTcTyVarToTyVar tc_tyvars_to_gen `thenM` \ real_tyvars_to_gen ->
275 -- It's important that the dict Ids are zonked, including the boxity set
276 -- in the previous step, because they are later used to form the type of
277 -- the polymorphic thing, and forall-types must be zonked so far as
278 -- their bound variables are concerned
279 mappM zonkId dict_ids `thenM` \ zonked_dict_ids ->
280 mappM zonkId mono_ids `thenM` \ zonked_mono_ids ->
282 -- BUILD THE POLYMORPHIC RESULT IDs
284 exports = zipWith mk_export binder_names zonked_mono_ids
285 poly_ids = [poly_id | (_, poly_id, _) <- exports]
286 dict_tys = map idType zonked_dict_ids
288 inlines = mkNameSet [name | InlineSig True name _ loc <- sigs]
289 -- Any INLINE sig (regardless of phase control)
290 -- makes the RHS look small
291 inline_phases = listToFM [(name, phase) | InlineSig _ name phase _ <- sigs,
292 not (isAlwaysActive phase)]
293 -- Set the IdInfo field to control the inline phase
294 -- AlwaysActive is the default, so don't bother with them
296 mk_export binder_name zonked_mono_id
298 attachInlinePhase inline_phases poly_id,
302 case maybeSig tc_ty_sigs binder_name of
303 Just (TySigInfo sig_poly_id sig_tyvars _ _ _ _ _) ->
304 (sig_tyvars, sig_poly_id)
305 Nothing -> (real_tyvars_to_gen, new_poly_id)
307 new_poly_id = mkLocalId binder_name poly_ty
308 poly_ty = mkForAllTys real_tyvars_to_gen
310 $ idType zonked_mono_id
311 -- It's important to build a fully-zonked poly_ty, because
312 -- we'll slurp out its free type variables when extending the
313 -- local environment (tcExtendLocalValEnv); if it's not zonked
314 -- it appears to have free tyvars that aren't actually free
318 traceTc (text "binding:" <+> ppr ((zonked_dict_ids, dict_binds),
319 exports, map idType poly_ids)) `thenM_`
321 -- Check for an unlifted, non-overloaded group
322 -- In that case we must make extra checks
323 if any (isUnLiftedType . idType) zonked_mono_ids && null zonked_dict_ids
324 then -- Some bindings are unlifted
325 checkUnliftedBinds top_lvl is_rec real_tyvars_to_gen mbind `thenM_`
327 extendLIEs lie_req `thenM_`
329 AbsBinds [] [] exports inlines mbind',
330 -- Do not generate even any x=y bindings
334 else -- The normal case
335 extendLIEs lie_free `thenM_`
337 AbsBinds real_tyvars_to_gen
341 (dict_binds `andMonoBinds` mbind'),
345 attachInlinePhase inline_phases bndr
346 = case lookupFM inline_phases (idName bndr) of
347 Just prag -> bndr `setInlinePragma` prag
350 -- Check that non-overloaded unlifted bindings are
353 -- c) non-polymorphic
354 -- d) not a multiple-binding group (more or less implied by (a))
356 checkUnliftedBinds top_lvl is_rec real_tyvars_to_gen mbind
357 = ASSERT( not (any ((eqKind unliftedTypeKind) . tyVarKind) real_tyvars_to_gen) )
358 -- The instCantBeGeneralised stuff in tcSimplify should have
359 -- already raised an error if we're trying to generalise an
360 -- unboxed tyvar (NB: unboxed tyvars are always introduced
361 -- along with a class constraint) and it's better done there
362 -- because we have more precise origin information.
363 -- That's why we just use an ASSERT here.
365 checkTc (isNotTopLevel top_lvl)
366 (unliftedBindErr "Top-level" mbind) `thenM_`
367 checkTc (isNonRec is_rec)
368 (unliftedBindErr "Recursive" mbind) `thenM_`
369 checkTc (single_bind mbind)
370 (unliftedBindErr "Multiple" mbind) `thenM_`
371 checkTc (null real_tyvars_to_gen)
372 (unliftedBindErr "Polymorphic" mbind)
375 single_bind (PatMonoBind _ _ _) = True
376 single_bind (FunMonoBind _ _ _ _) = True
377 single_bind other = False
381 Polymorphic recursion
382 ~~~~~~~~~~~~~~~~~~~~~
383 The game plan for polymorphic recursion in the code above is
385 * Bind any variable for which we have a type signature
386 to an Id with a polymorphic type. Then when type-checking
387 the RHSs we'll make a full polymorphic call.
389 This fine, but if you aren't a bit careful you end up with a horrendous
390 amount of partial application and (worse) a huge space leak. For example:
392 f :: Eq a => [a] -> [a]
395 If we don't take care, after typechecking we get
397 f = /\a -> \d::Eq a -> let f' = f a d
401 Notice the the stupid construction of (f a d), which is of course
402 identical to the function we're executing. In this case, the
403 polymorphic recursion isn't being used (but that's a very common case).
406 f = /\a -> \d::Eq a -> letrec
407 fm = \ys:[a] -> ...fm...
411 This can lead to a massive space leak, from the following top-level defn
417 Now (f dEqInt) evaluates to a lambda that has f' as a free variable; but
418 f' is another thunk which evaluates to the same thing... and you end
419 up with a chain of identical values all hung onto by the CAF ff.
423 = let f' = f Int dEqInt in \ys. ...f'...
425 = let f' = let f' = f Int dEqInt in \ys. ...f'...
429 Solution: when typechecking the RHSs we always have in hand the
430 *monomorphic* Ids for each binding. So we just need to make sure that
431 if (Method f a d) shows up in the constraints emerging from (...f...)
432 we just use the monomorphic Id. We achieve this by adding monomorphic Ids
433 to the "givens" when simplifying constraints. That's what the "lies_avail"
437 %************************************************************************
439 \subsection{getTyVarsToGen}
441 %************************************************************************
444 generalise binder_names mbind tau_tvs lie_req sigs =
446 -- check for -fno-monomorphism-restriction
447 doptM Opt_NoMonomorphismRestriction `thenM` \ no_MR ->
448 let is_unrestricted | no_MR = True
449 | otherwise = isUnRestrictedGroup tysig_names mbind
452 if not is_unrestricted then -- RESTRICTED CASE
453 -- Check signature contexts are empty
454 checkTc (all is_mono_sig sigs)
455 (restrictedBindCtxtErr binder_names) `thenM_`
457 -- Now simplify with exactly that set of tyvars
458 -- We have to squash those Methods
459 tcSimplifyRestricted doc tau_tvs lie_req `thenM` \ (qtvs, binds) ->
461 -- Check that signature type variables are OK
462 checkSigsTyVars qtvs sigs `thenM` \ final_qtvs ->
464 returnM (final_qtvs, binds, [])
466 else if null sigs then -- UNRESTRICTED CASE, NO TYPE SIGS
467 tcSimplifyInfer doc tau_tvs lie_req
469 else -- UNRESTRICTED CASE, WITH TYPE SIGS
470 -- CHECKING CASE: Unrestricted group, there are type signatures
471 -- Check signature contexts are identical
472 checkSigsCtxts sigs `thenM` \ (sig_avails, sig_dicts) ->
474 -- Check that the needed dicts can be
475 -- expressed in terms of the signature ones
476 tcSimplifyInferCheck doc tau_tvs sig_avails lie_req `thenM` \ (forall_tvs, dict_binds) ->
478 -- Check that signature type variables are OK
479 checkSigsTyVars forall_tvs sigs `thenM` \ final_qtvs ->
481 returnM (final_qtvs, dict_binds, sig_dicts)
484 tysig_names = map (idName . tcSigPolyId) sigs
485 is_mono_sig (TySigInfo _ _ theta _ _ _ _) = null theta
487 doc = ptext SLIT("type signature(s) for") <+> pprBinders binder_names
489 -----------------------
490 -- CHECK THAT ALL THE SIGNATURE CONTEXTS ARE UNIFIABLE
491 -- The type signatures on a mutually-recursive group of definitions
492 -- must all have the same context (or none).
494 -- We unify them because, with polymorphic recursion, their types
495 -- might not otherwise be related. This is a rather subtle issue.
497 checkSigsCtxts sigs@(TySigInfo id1 sig_tvs theta1 _ _ _ src_loc : other_sigs)
498 = addSrcLoc src_loc $
499 mappM_ check_one other_sigs `thenM_`
501 returnM ([], []) -- Non-overloaded type signatures
503 newDicts SignatureOrigin theta1 `thenM` \ sig_dicts ->
505 -- The "sig_avails" is the stuff available. We get that from
506 -- the context of the type signature, BUT ALSO the lie_avail
507 -- so that polymorphic recursion works right (see comments at end of fn)
508 sig_avails = sig_dicts ++ sig_meths
510 returnM (sig_avails, map instToId sig_dicts)
512 sig1_dict_tys = map mkPredTy theta1
513 sig_meths = concat [insts | TySigInfo _ _ _ _ _ insts _ <- sigs]
515 check_one sig@(TySigInfo id _ theta _ _ _ _)
516 = addErrCtxt (sigContextsCtxt id1 id) $
517 checkTc (equalLength theta theta1) sigContextsErr `thenM_`
518 unifyTauTyLists sig1_dict_tys (map mkPredTy theta)
520 checkSigsTyVars :: [TcTyVar] -> [TcSigInfo] -> TcM [TcTyVar]
521 checkSigsTyVars qtvs sigs
522 = mappM check_one sigs `thenM` \ sig_tvs_s ->
524 -- Sigh. Make sure that all the tyvars in the type sigs
525 -- appear in the returned ty var list, which is what we are
526 -- going to generalise over. Reason: we occasionally get
528 -- type T a = () -> ()
531 -- Here, 'a' won't appear in qtvs, so we have to add it
533 sig_tvs = foldr (unionVarSet . mkVarSet) emptyVarSet sig_tvs_s
534 all_tvs = mkVarSet qtvs `unionVarSet` sig_tvs
536 returnM (varSetElems all_tvs)
538 check_one (TySigInfo id sig_tyvars sig_theta sig_tau _ _ src_loc)
539 = addSrcLoc src_loc $
540 addErrCtxt (ptext SLIT("When checking the type signature for")
541 <+> quotes (ppr id)) $
542 addErrCtxtM (sigCtxt id sig_tyvars sig_theta sig_tau) $
543 checkSigTyVarsWrt (idFreeTyVars id) sig_tyvars
546 @getTyVarsToGen@ decides what type variables to generalise over.
548 For a "restricted group" -- see the monomorphism restriction
549 for a definition -- we bind no dictionaries, and
550 remove from tyvars_to_gen any constrained type variables
552 *Don't* simplify dicts at this point, because we aren't going
553 to generalise over these dicts. By the time we do simplify them
554 we may well know more. For example (this actually came up)
556 f x = array ... xs where xs = [1,2,3,4,5]
557 We don't want to generate lots of (fromInt Int 1), (fromInt Int 2)
558 stuff. If we simplify only at the f-binding (not the xs-binding)
559 we'll know that the literals are all Ints, and we can just produce
562 Find all the type variables involved in overloading, the
563 "constrained_tyvars". These are the ones we *aren't* going to
564 generalise. We must be careful about doing this:
566 (a) If we fail to generalise a tyvar which is not actually
567 constrained, then it will never, ever get bound, and lands
568 up printed out in interface files! Notorious example:
569 instance Eq a => Eq (Foo a b) where ..
570 Here, b is not constrained, even though it looks as if it is.
571 Another, more common, example is when there's a Method inst in
572 the LIE, whose type might very well involve non-overloaded
574 [NOTE: Jan 2001: I don't understand the problem here so I'm doing
575 the simple thing instead]
577 (b) On the other hand, we mustn't generalise tyvars which are constrained,
578 because we are going to pass on out the unmodified LIE, with those
579 tyvars in it. They won't be in scope if we've generalised them.
581 So we are careful, and do a complete simplification just to find the
582 constrained tyvars. We don't use any of the results, except to
583 find which tyvars are constrained.
586 isUnRestrictedGroup :: [Name] -- Signatures given for these
590 is_elem v vs = isIn "isUnResMono" v vs
592 isUnRestrictedGroup sigs (PatMonoBind other _ _) = False
593 isUnRestrictedGroup sigs (VarMonoBind v _) = v `is_elem` sigs
594 isUnRestrictedGroup sigs (FunMonoBind v _ matches _) = isUnRestrictedMatch matches ||
596 isUnRestrictedGroup sigs (AndMonoBinds mb1 mb2) = isUnRestrictedGroup sigs mb1 &&
597 isUnRestrictedGroup sigs mb2
598 isUnRestrictedGroup sigs EmptyMonoBinds = True
600 isUnRestrictedMatch (Match [] _ _ : _) = False -- No args => like a pattern binding
601 isUnRestrictedMatch other = True -- Some args => a function binding
605 %************************************************************************
607 \subsection{tcMonoBind}
609 %************************************************************************
611 @tcMonoBinds@ deals with a single @MonoBind@.
612 The signatures have been dealt with already.
615 tcMonoBinds :: RenamedMonoBinds
619 [Name], -- Bound names
620 [TcId]) -- Corresponding monomorphic bound things
622 tcMonoBinds mbinds tc_ty_sigs is_rec
623 = tc_mb_pats mbinds `thenM` \ (complete_it, tvs, ids, lie_avail) ->
625 id_list = bagToList ids
626 (names, mono_ids) = unzip id_list
628 -- This last defn is the key one:
629 -- extend the val envt with bindings for the
630 -- things bound in this group, overriding the monomorphic
631 -- ids with the polymorphic ones from the pattern
632 extra_val_env = case is_rec of
633 Recursive -> map mk_bind id_list
636 -- Don't know how to deal with pattern-bound existentials yet
637 checkTc (isEmptyBag tvs && null lie_avail)
638 (existentialExplode mbinds) `thenM_`
640 -- *Before* checking the RHSs, but *after* checking *all* the patterns,
641 -- extend the envt with bindings for all the bound ids;
642 -- and *then* override with the polymorphic Ids from the signatures
643 -- That is the whole point of the "complete_it" stuff.
645 -- There's a further wrinkle: we have to delay extending the environment
646 -- until after we've dealt with any pattern-bound signature type variables
647 -- Consider f (x::a) = ...f...
648 -- We're going to check that a isn't unified with anything in the envt,
649 -- so f itself had better not be! So we pass the envt binding f into
650 -- complete_it, which extends the actual envt in TcMatches.tcMatch, after
651 -- dealing with the signature tyvars
653 complete_it extra_val_env `thenM` \ mbinds' ->
655 returnM (mbinds', names, mono_ids)
658 mk_bind (name, mono_id) = case maybeSig tc_ty_sigs name of
659 Nothing -> (name, mono_id)
660 Just sig -> (idName poly_id, poly_id)
662 poly_id = tcSigPolyId sig
664 tc_mb_pats EmptyMonoBinds
665 = returnM (\ xve -> returnM EmptyMonoBinds, emptyBag, emptyBag, [])
667 tc_mb_pats (AndMonoBinds mb1 mb2)
668 = tc_mb_pats mb1 `thenM` \ (complete_it1, tvs1, ids1, lie_avail1) ->
669 tc_mb_pats mb2 `thenM` \ (complete_it2, tvs2, ids2, lie_avail2) ->
671 complete_it xve = complete_it1 xve `thenM` \ mb1' ->
672 complete_it2 xve `thenM` \ mb2' ->
673 returnM (AndMonoBinds mb1' mb2')
675 returnM (complete_it,
676 tvs1 `unionBags` tvs2,
677 ids1 `unionBags` ids2,
678 lie_avail1 ++ lie_avail2)
680 tc_mb_pats (FunMonoBind name inf matches locn)
681 = (case maybeSig tc_ty_sigs name of
682 Just sig -> returnM (tcSigMonoId sig)
683 Nothing -> newLocalName name `thenM` \ bndr_name ->
684 newTyVarTy openTypeKind `thenM` \ bndr_ty ->
685 -- NB: not a 'hole' tyvar; since there is no type
686 -- signature, we revert to ordinary H-M typechecking
687 -- which means the variable gets an inferred tau-type
688 returnM (mkLocalId bndr_name bndr_ty)
689 ) `thenM` \ bndr_id ->
691 bndr_ty = idType bndr_id
692 complete_it xve = addSrcLoc locn $
693 tcMatchesFun xve name bndr_ty matches `thenM` \ matches' ->
694 returnM (FunMonoBind bndr_id inf matches' locn)
696 returnM (complete_it, emptyBag, unitBag (name, bndr_id), [])
698 tc_mb_pats bind@(PatMonoBind pat grhss locn)
700 newHoleTyVarTy `thenM` \ pat_ty ->
702 -- Now typecheck the pattern
703 -- We do now support binding fresh (not-already-in-scope) scoped
704 -- type variables in the pattern of a pattern binding.
705 -- For example, this is now legal:
707 -- The type variables are brought into scope in tc_binds_and_then,
708 -- so we don't have to do anything here.
710 tcPat tc_pat_bndr pat pat_ty `thenM` \ (pat', tvs, ids, lie_avail) ->
711 readHoleResult pat_ty `thenM` \ pat_ty' ->
713 complete_it xve = addSrcLoc locn $
714 addErrCtxt (patMonoBindsCtxt bind) $
715 tcExtendLocalValEnv2 xve $
716 tcGRHSs PatBindRhs grhss pat_ty' `thenM` \ grhss' ->
717 returnM (PatMonoBind pat' grhss' locn)
719 returnM (complete_it, tvs, ids, lie_avail)
721 -- tc_pat_bndr is used when dealing with a LHS binder in a pattern.
722 -- If there was a type sig for that Id, we want to make it much
723 -- as if that type signature had been on the binder as a SigPatIn.
724 -- We check for a type signature; if there is one, we use the mono_id
725 -- from the signature. This is how we make sure the tau part of the
726 -- signature actually matches the type of the LHS; then tc_mb_pats
727 -- ensures the LHS and RHS have the same type
729 tc_pat_bndr name pat_ty
730 = case maybeSig tc_ty_sigs name of
732 -> newLocalName name `thenM` \ bndr_name ->
733 tcMonoPatBndr bndr_name pat_ty
735 Just sig -> addSrcLoc (getSrcLoc name) $
736 tcSubPat (idType mono_id) pat_ty `thenM` \ co_fn ->
737 returnM (co_fn, mono_id)
739 mono_id = tcSigMonoId sig
743 %************************************************************************
745 \subsection{SPECIALIZE pragmas}
747 %************************************************************************
749 @tcSpecSigs@ munches up the specialisation "signatures" that arise through *user*
750 pragmas. It is convenient for them to appear in the @[RenamedSig]@
751 part of a binding because then the same machinery can be used for
752 moving them into place as is done for type signatures.
757 f :: Ord a => [a] -> b -> b
758 {-# SPECIALIZE f :: [Int] -> b -> b #-}
761 For this we generate:
763 f* = /\ b -> let d1 = ...
767 where f* is a SpecPragmaId. The **sole** purpose of SpecPragmaIds is to
768 retain a right-hand-side that the simplifier will otherwise discard as
769 dead code... the simplifier has a flag that tells it not to discard
770 SpecPragmaId bindings.
772 In this case the f* retains a call-instance of the overloaded
773 function, f, (including appropriate dictionaries) so that the
774 specialiser will subsequently discover that there's a call of @f@ at
775 Int, and will create a specialisation for @f@. After that, the
776 binding for @f*@ can be discarded.
778 We used to have a form
779 {-# SPECIALISE f :: <type> = g #-}
780 which promised that g implemented f at <type>, but we do that with
782 {-# SPECIALISE (f::<type) = g #-}
785 tcSpecSigs :: [RenamedSig] -> TcM TcMonoBinds
786 tcSpecSigs (SpecSig name poly_ty src_loc : sigs)
787 = -- SPECIALISE f :: forall b. theta => tau = g
789 addErrCtxt (valSpecSigCtxt name poly_ty) $
791 -- Get and instantiate its alleged specialised type
792 tcHsSigType (FunSigCtxt name) poly_ty `thenM` \ sig_ty ->
794 -- Check that f has a more general type, and build a RHS for
795 -- the spec-pragma-id at the same time
796 getLIE (tcExpr (HsVar name) sig_ty) `thenM` \ (spec_expr, spec_lie) ->
798 -- Squeeze out any Methods (see comments with tcSimplifyToDicts)
799 tcSimplifyToDicts spec_lie `thenM` \ spec_binds ->
801 -- Just specialise "f" by building a SpecPragmaId binding
802 -- It is the thing that makes sure we don't prematurely
803 -- dead-code-eliminate the binding we are really interested in.
804 newLocalName name `thenM` \ spec_name ->
806 spec_bind = VarMonoBind (mkSpecPragmaId spec_name sig_ty)
807 (mkHsLet spec_binds spec_expr)
810 -- Do the rest and combine
811 tcSpecSigs sigs `thenM` \ binds_rest ->
812 returnM (binds_rest `andMonoBinds` spec_bind)
814 tcSpecSigs (other_sig : sigs) = tcSpecSigs sigs
815 tcSpecSigs [] = returnM EmptyMonoBinds
819 %************************************************************************
821 \subsection[TcBinds-errors]{Error contexts and messages}
823 %************************************************************************
827 patMonoBindsCtxt bind
828 = hang (ptext SLIT("In a pattern binding:")) 4 (ppr bind)
830 -----------------------------------------------
832 = sep [ptext SLIT("In a SPECIALIZE pragma for a value:"),
833 nest 4 (ppr v <+> dcolon <+> ppr ty)]
835 -----------------------------------------------
836 sigContextsErr = ptext SLIT("Mismatched contexts")
838 sigContextsCtxt s1 s2
839 = vcat [ptext SLIT("When matching the contexts of the signatures for"),
840 nest 2 (vcat [ppr s1 <+> dcolon <+> ppr (idType s1),
841 ppr s2 <+> dcolon <+> ppr (idType s2)]),
842 ptext SLIT("The signature contexts in a mutually recursive group should all be identical")]
844 -----------------------------------------------
845 unliftedBindErr flavour mbind
846 = hang (text flavour <+> ptext SLIT("bindings for unlifted types aren't allowed:"))
849 -----------------------------------------------
850 existentialExplode mbinds
851 = hang (vcat [text "My brain just exploded.",
852 text "I can't handle pattern bindings for existentially-quantified constructors.",
853 text "In the binding group"])
856 -----------------------------------------------
857 restrictedBindCtxtErr binder_names
858 = hang (ptext SLIT("Illegal overloaded type signature(s)"))
859 4 (vcat [ptext SLIT("in a binding group for") <+> pprBinders binder_names,
860 ptext SLIT("that falls under the monomorphism restriction")])
863 = ptext SLIT("When generalising the type(s) for") <+> pprBinders binder_names
865 -- Used in error messages
866 -- Use quotes for a single one; they look a bit "busy" for several
867 pprBinders [bndr] = quotes (ppr bndr)
868 pprBinders bndrs = pprWithCommas ppr bndrs