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 ( tcGRHSsPat, tcMatchesFun )
12 import {-# SOURCE #-} TcExpr ( tcCheckSigma, tcCheckRho )
14 import CmdLineOpts ( DynFlag(Opt_NoMonomorphismRestriction) )
15 import HsSyn ( HsExpr(..), HsBind(..), LHsBind, LHsBinds, Sig(..),
16 LSig, Match(..), HsBindGroup(..), IPBind(..),
17 collectSigTysFromHsBinds, collectHsBindBinders,
19 import TcHsSyn ( TcId, zonkId, mkHsLet )
22 import Inst ( InstOrigin(..), newDicts, newIPDict, instToId )
23 import TcEnv ( tcExtendLocalValEnv, tcExtendLocalValEnv2, newLocalName )
24 import TcUnify ( Expected(..), newHole, unifyTauTyLists, checkSigTyVarsWrt, sigCtxt )
25 import TcSimplify ( tcSimplifyInfer, tcSimplifyInferCheck, tcSimplifyRestricted,
26 tcSimplifyToDicts, tcSimplifyIPs )
27 import TcHsType ( tcHsSigType, UserTypeCtxt(..), TcSigInfo(..),
28 tcTySig, maybeSig, tcAddScopedTyVars
30 import TcPat ( tcPat, tcSubPat, tcMonoPatBndr )
31 import TcSimplify ( bindInstsOfLocalFuns )
32 import TcMType ( newTyVar, newTyVarTy, zonkTcTyVarToTyVar )
33 import TcType ( TcTyVar, mkTyVarTy, mkForAllTys, mkFunTys, tyVarsOfType,
34 mkPredTy, mkForAllTy, isUnLiftedType,
35 unliftedTypeKind, liftedTypeKind, openTypeKind, eqKind
38 import CoreFVs ( idFreeTyVars )
39 import Id ( mkLocalId, mkSpecPragmaId, setInlinePragma )
40 import Var ( idType, idName )
41 import Name ( Name, getSrcLoc )
43 import Var ( tyVarKind )
45 import SrcLoc ( Located(..), srcLocSpan, unLoc, noLoc )
47 import Util ( isIn, equalLength )
48 import BasicTypes ( TopLevelFlag(..), RecFlag(..), isNonRec, isRec,
49 isNotTopLevel, isAlwaysActive )
50 import FiniteMap ( listToFM, lookupFM )
55 %************************************************************************
57 \subsection{Type-checking bindings}
59 %************************************************************************
61 @tcBindsAndThen@ typechecks a @HsBinds@. The "and then" part is because
62 it needs to know something about the {\em usage} of the things bound,
63 so that it can create specialisations of them. So @tcBindsAndThen@
64 takes a function which, given an extended environment, E, typechecks
65 the scope of the bindings returning a typechecked thing and (most
66 important) an LIE. It is this LIE which is then used as the basis for
67 specialising the things bound.
69 @tcBindsAndThen@ also takes a "combiner" which glues together the
70 bindings and the "thing" to make a new "thing".
72 The real work is done by @tcBindWithSigsAndThen@.
74 Recursive and non-recursive binds are handled in essentially the same
75 way: because of uniques there are no scoping issues left. The only
76 difference is that non-recursive bindings can bind primitive values.
78 Even for non-recursive binding groups we add typings for each binder
79 to the LVE for the following reason. When each individual binding is
80 checked the type of its LHS is unified with that of its RHS; and
81 type-checking the LHS of course requires that the binder is in scope.
83 At the top-level the LIE is sure to contain nothing but constant
84 dictionaries, which we resolve at the module level.
87 tcTopBinds :: [HsBindGroup Name] -> TcM (LHsBinds TcId, TcLclEnv)
88 -- Note: returning the TcLclEnv is more than we really
89 -- want. The bit we care about is the local bindings
90 -- and the free type variables thereof
92 = tc_binds_and_then TopLevel glue binds $
93 getLclEnv `thenM` \ env ->
94 returnM (emptyBag, env)
96 -- The top level bindings are flattened into a giant
97 -- implicitly-mutually-recursive MonoBinds
98 glue (HsBindGroup binds1 _ _) (binds2, env) = (binds1 `unionBags` binds2, env)
99 -- Can't have a HsIPBinds at top level
103 :: (HsBindGroup TcId -> thing -> thing) -- Combinator
104 -> [HsBindGroup Name]
108 tcBindsAndThen = tc_binds_and_then NotTopLevel
110 tc_binds_and_then top_lvl combiner [] do_next
112 tc_binds_and_then top_lvl combiner (group : groups) do_next
113 = tc_bind_and_then top_lvl combiner group $
114 tc_binds_and_then top_lvl combiner groups do_next
116 tc_bind_and_then top_lvl combiner (HsIPBinds binds) do_next
117 = getLIE do_next `thenM` \ (result, expr_lie) ->
118 mapAndUnzipM (wrapLocSndM tc_ip_bind) binds `thenM` \ (avail_ips, binds') ->
120 -- If the binding binds ?x = E, we must now
121 -- discharge any ?x constraints in expr_lie
122 tcSimplifyIPs avail_ips expr_lie `thenM` \ dict_binds ->
124 returnM (combiner (HsIPBinds binds') $
125 combiner (HsBindGroup dict_binds [] Recursive) result)
127 -- I wonder if we should do these one at at time
130 tc_ip_bind (IPBind ip expr)
131 = newTyVarTy openTypeKind `thenM` \ ty ->
132 newIPDict (IPBindOrigin ip) ip ty `thenM` \ (ip', ip_inst) ->
133 tcCheckRho expr ty `thenM` \ expr' ->
134 returnM (ip_inst, (IPBind ip' expr'))
136 tc_bind_and_then top_lvl combiner (HsBindGroup binds sigs is_rec) do_next
140 = -- BRING ANY SCOPED TYPE VARIABLES INTO SCOPE
141 -- Notice that they scope over
142 -- a) the type signatures in the binding group
143 -- b) the bindings in the group
144 -- c) the scope of the binding group (the "in" part)
145 tcAddScopedTyVars (collectSigTysFromHsBinds (bagToList binds)) $
146 tcBindWithSigs top_lvl binds sigs is_rec `thenM` \ (poly_binds, poly_ids) ->
149 TopLevel -- For the top level don't bother will all this
150 -- bindInstsOfLocalFuns stuff. All the top level
151 -- things are rec'd together anyway, so it's fine to
152 -- leave them to the tcSimplifyTop, and quite a bit faster too
154 -- Subtle (and ugly) point: furthermore at top level we
155 -- return the TcLclEnv, which contains the LIE var; we
156 -- don't want to return the wrong one!
157 -> tc_body poly_ids `thenM` \ (prag_binds, thing) ->
158 returnM (combiner (HsBindGroup
159 (poly_binds `unionBags` prag_binds)
164 NotTopLevel -- For nested bindings we must do the
165 -- bindInstsOfLocalFuns thing. We must include
166 -- the LIE from the RHSs too -- polymorphic recursion!
167 -> getLIE (tc_body poly_ids) `thenM` \ ((prag_binds, thing), lie) ->
169 -- Create specialisations of functions bound here
170 bindInstsOfLocalFuns lie poly_ids `thenM` \ lie_binds ->
172 -- We want to keep non-recursive things non-recursive
173 -- so that we desugar unlifted bindings correctly
176 combiner (HsBindGroup
177 (poly_binds `unionBags`
178 lie_binds `unionBags`
184 combiner (HsBindGroup poly_binds [] NonRecursive) $
185 combiner (HsBindGroup prag_binds [] NonRecursive) $
186 combiner (HsBindGroup lie_binds [] Recursive) $
187 -- NB: the binds returned by tcSimplify and
188 -- bindInstsOfLocalFuns aren't guaranteed in
189 -- dependency order (though we could change
190 -- that); hence the Recursive marker.
194 = -- BRING ANY SCOPED TYPE VARIABLES INTO SCOPE
195 -- Notice that they scope over
196 -- a) the type signatures in the binding group
197 -- b) the bindings in the group
198 -- c) the scope of the binding group (the "in" part)
199 tcAddScopedTyVars (collectSigTysFromHsBinds (bagToList binds)) $
201 tcBindWithSigs top_lvl binds sigs is_rec `thenM` \ (poly_binds, poly_ids) ->
204 TopLevel -- For the top level don't bother will all this
205 -- bindInstsOfLocalFuns stuff. All the top level
206 -- things are rec'd together anyway, so it's fine to
207 -- leave them to the tcSimplifyTop, and quite a bit faster too
209 -- Subtle (and ugly) point: furthermore at top level we
210 -- return the TcLclEnv, which contains the LIE var; we
211 -- don't want to return the wrong one!
212 -> tc_body poly_ids `thenM` \ (prag_binds, thing) ->
213 returnM (combiner (HsBindGroup
214 (poly_binds `unionBags` prag_binds)
219 NotTopLevel -- For nested bindings we must do teh bindInstsOfLocalFuns thing
220 -> getLIE (tc_body poly_ids) `thenM` \ ((prag_binds, thing), lie) ->
222 -- Create specialisations of functions bound here
223 bindInstsOfLocalFuns lie poly_ids `thenM` \ lie_binds ->
225 -- We want to keep non-recursive things non-recursive
226 -- so that we desugar unlifted bindings correctly
229 combiner (HsBindGroup (
230 poly_binds `unionBags`
231 lie_binds `unionBags`
237 combiner (HsBindGroup poly_binds [] NonRecursive) $
238 combiner (HsBindGroup prag_binds [] NonRecursive) $
239 combiner (HsBindGroup lie_binds [] Recursive) $
240 -- NB: the binds returned by tcSimplify and bindInstsOfLocalFuns
241 -- aren't guaranteed in dependency order (though we could change
242 -- that); hence the Recursive marker.
246 tc_body poly_ids -- Type check the pragmas and "thing inside"
247 = -- Extend the environment to bind the new polymorphic Ids
248 tcExtendLocalValEnv poly_ids $
250 -- Build bindings and IdInfos corresponding to user pragmas
251 tcSpecSigs sigs `thenM` \ prag_binds ->
253 -- Now do whatever happens next, in the augmented envt
254 do_next `thenM` \ thing ->
256 returnM (prag_binds, thing)
260 %************************************************************************
262 \subsection{tcBindWithSigs}
264 %************************************************************************
266 @tcBindWithSigs@ deals with a single binding group. It does generalisation,
267 so all the clever stuff is in here.
269 * binder_names and mbind must define the same set of Names
271 * The Names in tc_ty_sigs must be a subset of binder_names
273 * The Ids in tc_ty_sigs don't necessarily have to have the same name
274 as the Name in the tc_ty_sig
277 tcBindWithSigs :: TopLevelFlag
281 -> TcM (LHsBinds TcId, [TcId])
283 tcBindWithSigs top_lvl mbind sigs is_rec
284 = -- TYPECHECK THE SIGNATURES
285 recoverM (returnM []) (
286 mappM tcTySig [sig | sig@(L _(Sig name _)) <- sigs]
287 ) `thenM` \ tc_ty_sigs ->
289 -- SET UP THE MAIN RECOVERY; take advantage of any type sigs
291 -- If typechecking the binds fails, then return with each
292 -- signature-less binder given type (forall a.a), to minimise subsequent
294 newTyVar liftedTypeKind `thenM` \ alpha_tv ->
296 forall_a_a = mkForAllTy alpha_tv (mkTyVarTy alpha_tv)
297 binder_names = collectHsBindBinders mbind
298 poly_ids = map mk_dummy binder_names
299 mk_dummy name = case maybeSig tc_ty_sigs name of
300 Just sig -> sig_poly_id sig -- Signature
301 Nothing -> mkLocalId name forall_a_a -- No signature
303 traceTc (text "tcBindsWithSigs: error recovery" <+> ppr binder_names) `thenM_`
304 returnM (emptyBag, poly_ids)
307 -- TYPECHECK THE BINDINGS
308 traceTc (ptext SLIT("--------------------------------------------------------")) `thenM_`
309 traceTc (ptext SLIT("Bindings for") <+> ppr (collectHsBindBinders mbind)) `thenM_`
310 getLIE (tcMonoBinds mbind tc_ty_sigs is_rec) `thenM` \ ((mbind', bndr_names_w_ids), lie_req) ->
312 (binder_names, mono_ids) = unzip (bagToList bndr_names_w_ids)
313 tau_tvs = foldr (unionVarSet . tyVarsOfType . idType) emptyVarSet mono_ids
317 -- (it seems a bit crude to have to do getLIE twice,
318 -- but I can't see a better way just now)
319 addSrcSpan (srcLocSpan (minimum (map getSrcLoc binder_names))) $
320 -- TODO: location wrong
322 addErrCtxt (genCtxt binder_names) $
323 getLIE (generalise binder_names mbind tau_tvs lie_req tc_ty_sigs)
324 `thenM` \ ((tc_tyvars_to_gen, dict_binds, dict_ids), lie_free) ->
327 -- ZONK THE GENERALISED TYPE VARIABLES TO REAL TyVars
328 -- This commits any unbound kind variables to boxed kind, by unification
329 -- It's important that the final quanfified type variables
330 -- are fully zonked, *including boxity*, because they'll be
331 -- included in the forall types of the polymorphic Ids.
332 -- At calls of these Ids we'll instantiate fresh type variables from
333 -- them, and we use their boxity then.
334 mappM zonkTcTyVarToTyVar tc_tyvars_to_gen `thenM` \ real_tyvars_to_gen ->
337 -- It's important that the dict Ids are zonked, including the boxity set
338 -- in the previous step, because they are later used to form the type of
339 -- the polymorphic thing, and forall-types must be zonked so far as
340 -- their bound variables are concerned
341 mappM zonkId dict_ids `thenM` \ zonked_dict_ids ->
342 mappM zonkId mono_ids `thenM` \ zonked_mono_ids ->
344 -- BUILD THE POLYMORPHIC RESULT IDs
346 exports = zipWith mk_export binder_names zonked_mono_ids
347 poly_ids = [poly_id | (_, poly_id, _) <- exports]
348 dict_tys = map idType zonked_dict_ids
350 inlines = mkNameSet [ name
351 | L _ (InlineSig True (L _ name) _) <- sigs]
352 -- Any INLINE sig (regardless of phase control)
353 -- makes the RHS look small
355 inline_phases = listToFM [ (name, phase)
356 | L _ (InlineSig _ (L _ name) phase) <- sigs,
357 not (isAlwaysActive phase)]
358 -- Set the IdInfo field to control the inline phase
359 -- AlwaysActive is the default, so don't bother with them
361 mk_export binder_name zonked_mono_id
363 attachInlinePhase inline_phases poly_id,
367 case maybeSig tc_ty_sigs binder_name of
368 Just sig -> (sig_tvs sig, sig_poly_id sig)
369 Nothing -> (real_tyvars_to_gen, new_poly_id)
371 new_poly_id = mkLocalId binder_name poly_ty
372 poly_ty = mkForAllTys real_tyvars_to_gen
374 $ idType zonked_mono_id
375 -- It's important to build a fully-zonked poly_ty, because
376 -- we'll slurp out its free type variables when extending the
377 -- local environment (tcExtendLocalValEnv); if it's not zonked
378 -- it appears to have free tyvars that aren't actually free
382 traceTc (text "binding:" <+> ppr ((zonked_dict_ids, dict_binds),
383 exports, map idType poly_ids)) `thenM_`
385 -- Check for an unlifted, non-overloaded group
386 -- In that case we must make extra checks
387 if any (isUnLiftedType . idType) zonked_mono_ids && null zonked_dict_ids
388 then -- Some bindings are unlifted
389 checkUnliftedBinds top_lvl is_rec real_tyvars_to_gen mbind `thenM_`
391 extendLIEs lie_req `thenM_`
394 AbsBinds [] [] exports inlines mbind',
395 -- Do not generate even any x=y bindings
399 else -- The normal case
400 extendLIEs lie_free `thenM_`
403 AbsBinds real_tyvars_to_gen
407 (dict_binds `unionBags` mbind'),
411 attachInlinePhase inline_phases bndr
412 = case lookupFM inline_phases (idName bndr) of
413 Just prag -> bndr `setInlinePragma` prag
416 -- Check that non-overloaded unlifted bindings are
419 -- c) non-polymorphic
420 -- d) not a multiple-binding group (more or less implied by (a))
422 checkUnliftedBinds top_lvl is_rec real_tyvars_to_gen mbind
423 = ASSERT( not (any ((eqKind unliftedTypeKind) . tyVarKind) real_tyvars_to_gen) )
424 -- The instCantBeGeneralised stuff in tcSimplify should have
425 -- already raised an error if we're trying to generalise an
426 -- unboxed tyvar (NB: unboxed tyvars are always introduced
427 -- along with a class constraint) and it's better done there
428 -- because we have more precise origin information.
429 -- That's why we just use an ASSERT here.
431 checkTc (isNotTopLevel top_lvl)
432 (unliftedBindErr "Top-level" mbind) `thenM_`
433 checkTc (isNonRec is_rec)
434 (unliftedBindErr "Recursive" mbind) `thenM_`
435 checkTc (isSingletonBag mbind)
436 (unliftedBindErr "Multiple" mbind) `thenM_`
437 checkTc (null real_tyvars_to_gen)
438 (unliftedBindErr "Polymorphic" mbind)
442 Polymorphic recursion
443 ~~~~~~~~~~~~~~~~~~~~~
444 The game plan for polymorphic recursion in the code above is
446 * Bind any variable for which we have a type signature
447 to an Id with a polymorphic type. Then when type-checking
448 the RHSs we'll make a full polymorphic call.
450 This fine, but if you aren't a bit careful you end up with a horrendous
451 amount of partial application and (worse) a huge space leak. For example:
453 f :: Eq a => [a] -> [a]
456 If we don't take care, after typechecking we get
458 f = /\a -> \d::Eq a -> let f' = f a d
462 Notice the the stupid construction of (f a d), which is of course
463 identical to the function we're executing. In this case, the
464 polymorphic recursion isn't being used (but that's a very common case).
467 f = /\a -> \d::Eq a -> letrec
468 fm = \ys:[a] -> ...fm...
472 This can lead to a massive space leak, from the following top-level defn
478 Now (f dEqInt) evaluates to a lambda that has f' as a free variable; but
479 f' is another thunk which evaluates to the same thing... and you end
480 up with a chain of identical values all hung onto by the CAF ff.
484 = let f' = f Int dEqInt in \ys. ...f'...
486 = let f' = let f' = f Int dEqInt in \ys. ...f'...
490 Solution: when typechecking the RHSs we always have in hand the
491 *monomorphic* Ids for each binding. So we just need to make sure that
492 if (Method f a d) shows up in the constraints emerging from (...f...)
493 we just use the monomorphic Id. We achieve this by adding monomorphic Ids
494 to the "givens" when simplifying constraints. That's what the "lies_avail"
498 %************************************************************************
500 \subsection{getTyVarsToGen}
502 %************************************************************************
505 generalise binder_names mbind tau_tvs lie_req sigs =
507 -- check for -fno-monomorphism-restriction
508 doptM Opt_NoMonomorphismRestriction `thenM` \ no_MR ->
509 let is_unrestricted | no_MR = True
510 | otherwise = isUnRestrictedGroup tysig_names mbind
513 if not is_unrestricted then -- RESTRICTED CASE
514 -- Check signature contexts are empty
515 checkTc (all is_mono_sig sigs)
516 (restrictedBindCtxtErr binder_names) `thenM_`
518 -- Now simplify with exactly that set of tyvars
519 -- We have to squash those Methods
520 tcSimplifyRestricted doc tau_tvs lie_req `thenM` \ (qtvs, binds) ->
522 -- Check that signature type variables are OK
523 checkSigsTyVars qtvs sigs `thenM` \ final_qtvs ->
525 returnM (final_qtvs, binds, [])
527 else if null sigs then -- UNRESTRICTED CASE, NO TYPE SIGS
528 tcSimplifyInfer doc tau_tvs lie_req
530 else -- UNRESTRICTED CASE, WITH TYPE SIGS
531 -- CHECKING CASE: Unrestricted group, there are type signatures
532 -- Check signature contexts are identical
533 checkSigsCtxts sigs `thenM` \ (sig_avails, sig_dicts) ->
535 -- Check that the needed dicts can be
536 -- expressed in terms of the signature ones
537 tcSimplifyInferCheck doc tau_tvs sig_avails lie_req `thenM` \ (forall_tvs, dict_binds) ->
539 -- Check that signature type variables are OK
540 checkSigsTyVars forall_tvs sigs `thenM` \ final_qtvs ->
542 returnM (final_qtvs, dict_binds, sig_dicts)
545 tysig_names = map (idName . sig_poly_id) sigs
546 is_mono_sig sig = null (sig_theta sig)
548 doc = ptext SLIT("type signature(s) for") <+> pprBinders binder_names
550 -----------------------
551 -- CHECK THAT ALL THE SIGNATURE CONTEXTS ARE UNIFIABLE
552 -- The type signatures on a mutually-recursive group of definitions
553 -- must all have the same context (or none).
555 -- We unify them because, with polymorphic recursion, their types
556 -- might not otherwise be related. This is a rather subtle issue.
558 checkSigsCtxts sigs@(TySigInfo { sig_poly_id = id1, sig_tvs = sig_tvs, sig_theta = theta1, sig_loc = span}
561 mappM_ check_one other_sigs `thenM_`
563 returnM ([], []) -- Non-overloaded type signatures
565 newDicts SignatureOrigin theta1 `thenM` \ sig_dicts ->
567 -- The "sig_avails" is the stuff available. We get that from
568 -- the context of the type signature, BUT ALSO the lie_avail
569 -- so that polymorphic recursion works right (see comments at end of fn)
570 sig_avails = sig_dicts ++ sig_meths
572 returnM (sig_avails, map instToId sig_dicts)
574 sig1_dict_tys = map mkPredTy theta1
575 sig_meths = concatMap sig_insts sigs
577 check_one (TySigInfo {sig_poly_id = id, sig_theta = theta})
578 = addErrCtxt (sigContextsCtxt id1 id) $
579 checkTc (equalLength theta theta1) sigContextsErr `thenM_`
580 unifyTauTyLists sig1_dict_tys (map mkPredTy theta)
582 checkSigsTyVars :: [TcTyVar] -> [TcSigInfo] -> TcM [TcTyVar]
583 checkSigsTyVars qtvs sigs
584 = mappM check_one sigs `thenM` \ sig_tvs_s ->
586 -- Sigh. Make sure that all the tyvars in the type sigs
587 -- appear in the returned ty var list, which is what we are
588 -- going to generalise over. Reason: we occasionally get
590 -- type T a = () -> ()
593 -- Here, 'a' won't appear in qtvs, so we have to add it
595 sig_tvs = foldr (unionVarSet . mkVarSet) emptyVarSet sig_tvs_s
596 all_tvs = mkVarSet qtvs `unionVarSet` sig_tvs
598 returnM (varSetElems all_tvs)
600 check_one (TySigInfo {sig_poly_id = id, sig_tvs = tvs, sig_theta = theta, sig_tau = tau})
601 = addErrCtxt (ptext SLIT("In the type signature for")
602 <+> quotes (ppr id)) $
603 addErrCtxtM (sigCtxt id tvs theta tau) $
604 checkSigTyVarsWrt (idFreeTyVars id) tvs
607 @getTyVarsToGen@ decides what type variables to generalise over.
609 For a "restricted group" -- see the monomorphism restriction
610 for a definition -- we bind no dictionaries, and
611 remove from tyvars_to_gen any constrained type variables
613 *Don't* simplify dicts at this point, because we aren't going
614 to generalise over these dicts. By the time we do simplify them
615 we may well know more. For example (this actually came up)
617 f x = array ... xs where xs = [1,2,3,4,5]
618 We don't want to generate lots of (fromInt Int 1), (fromInt Int 2)
619 stuff. If we simplify only at the f-binding (not the xs-binding)
620 we'll know that the literals are all Ints, and we can just produce
623 Find all the type variables involved in overloading, the
624 "constrained_tyvars". These are the ones we *aren't* going to
625 generalise. We must be careful about doing this:
627 (a) If we fail to generalise a tyvar which is not actually
628 constrained, then it will never, ever get bound, and lands
629 up printed out in interface files! Notorious example:
630 instance Eq a => Eq (Foo a b) where ..
631 Here, b is not constrained, even though it looks as if it is.
632 Another, more common, example is when there's a Method inst in
633 the LIE, whose type might very well involve non-overloaded
635 [NOTE: Jan 2001: I don't understand the problem here so I'm doing
636 the simple thing instead]
638 (b) On the other hand, we mustn't generalise tyvars which are constrained,
639 because we are going to pass on out the unmodified LIE, with those
640 tyvars in it. They won't be in scope if we've generalised them.
642 So we are careful, and do a complete simplification just to find the
643 constrained tyvars. We don't use any of the results, except to
644 find which tyvars are constrained.
647 isUnRestrictedGroup :: [Name] -- Signatures given for these
650 isUnRestrictedGroup sigs binds = all (unrestricted . unLoc) (bagToList binds)
652 unrestricted (PatBind other _) = False
653 unrestricted (VarBind v _) = v `is_elem` sigs
654 unrestricted (FunBind v _ matches) = unrestricted_match matches
655 || unLoc v `is_elem` sigs
657 unrestricted_match (L _ (Match [] _ _) : _) = False
658 -- No args => like a pattern binding
659 unrestricted_match other = True
660 -- Some args => a function binding
662 is_elem v vs = isIn "isUnResMono" v vs
666 %************************************************************************
668 \subsection{tcMonoBind}
670 %************************************************************************
672 @tcMonoBinds@ deals with a single @MonoBind@.
673 The signatures have been dealt with already.
676 tcMonoBinds :: LHsBinds Name
677 -> [TcSigInfo] -> RecFlag
678 -> TcM (LHsBinds TcId,
679 Bag (Name, -- Bound names
680 TcId)) -- Corresponding monomorphic bound things
682 tcMonoBinds mbinds tc_ty_sigs is_rec
684 -- 1. Check the patterns, building up an environment binding
685 -- the variables in this group (in the recursive case)
686 -- 2. Extend the environment
688 = mapBagM tc_lbind_pats mbinds `thenM` \ bag_of_pairs ->
692 (returnM (emptyBag, emptyBag), emptyBag)
694 combine (complete_it1, xve1) (complete_it2, xve2)
695 = (complete_it, xve1 `unionBags` xve2)
697 complete_it = complete_it1 `thenM` \ (b1, bs1) ->
698 complete_it2 `thenM` \ (b2, bs2) ->
699 returnM (b1 `consBag` b2, bs1 `unionBags` bs2)
701 tcExtendLocalValEnv2 (bagToList xve) complete_it
703 tc_lbind_pats :: LHsBind Name
704 -> TcM (TcM (LHsBind TcId, Bag (Name,TcId)), -- Completer
706 -- wrapper for tc_bind_pats to deal with the location stuff
707 tc_lbind_pats (L loc bind)
708 = addSrcSpan loc $ do
709 (tc, bag) <- tc_bind_pats bind
710 return (wrap tc, bag)
712 wrap tc = addSrcSpan loc $ do
714 return (L loc bind, stuff)
717 tc_bind_pats :: HsBind Name
718 -> TcM (TcM (HsBind TcId, Bag (Name,TcId)), -- Completer
720 tc_bind_pats (FunBind (L nm_loc name) inf matches)
722 -- a) Type sig supplied
723 -- b) No type sig and recursive
724 -- c) No type sig and non-recursive
726 | Just sig <- maybeSig tc_ty_sigs name
727 = let -- (a) There is a type signature
728 -- Use it for the environment extension, and check
729 -- the RHS has the appropriate type (with outer for-alls stripped off)
730 mono_id = sig_mono_id sig
731 mono_ty = idType mono_id
732 complete_it = tcMatchesFun name matches (Check mono_ty) `thenM` \ matches' ->
733 returnM (FunBind (L nm_loc mono_id) inf matches',
734 unitBag (name, mono_id))
736 returnM (complete_it, if isRec is_rec then unitBag (name, sig_poly_id sig)
740 = -- (b) No type signature, and recursive
741 -- So we must use an ordinary H-M type variable
742 -- which means the variable gets an inferred tau-type
743 newLocalName name `thenM` \ mono_name ->
744 newTyVarTy openTypeKind `thenM` \ mono_ty ->
746 mono_id = mkLocalId mono_name mono_ty
747 complete_it = tcMatchesFun name matches (Check mono_ty) `thenM` \ matches' ->
748 returnM (FunBind (L nm_loc mono_id) inf matches',
749 unitBag (name, mono_id))
751 returnM (complete_it, unitBag (name, mono_id))
753 | otherwise -- (c) No type signature, and non-recursive
754 = let -- So we can use a 'hole' type to infer a higher-rank type
756 = newHole `thenM` \ hole ->
757 tcMatchesFun name matches (Infer hole) `thenM` \ matches' ->
758 readMutVar hole `thenM` \ fun_ty ->
759 newLocalName name `thenM` \ mono_name ->
761 mono_id = mkLocalId mono_name fun_ty
763 returnM (FunBind (L nm_loc mono_id) inf matches',
764 unitBag (name, mono_id))
766 returnM (complete_it, emptyBag)
768 tc_bind_pats bind@(PatBind pat grhss)
769 = -- Now typecheck the pattern
770 -- We do now support binding fresh (not-already-in-scope) scoped
771 -- type variables in the pattern of a pattern binding.
772 -- For example, this is now legal:
774 -- The type variables are brought into scope in tc_binds_and_then,
775 -- so we don't have to do anything here.
776 newHole `thenM` \ hole ->
777 tcPat tc_pat_bndr pat (Infer hole) `thenM` \ (pat', tvs, ids, lie_avail) ->
778 readMutVar hole `thenM` \ pat_ty ->
780 -- Don't know how to deal with pattern-bound existentials yet
781 checkTc (isEmptyBag tvs && null lie_avail)
782 (existentialExplode bind) `thenM_`
785 complete_it = addErrCtxt (patMonoBindsCtxt bind) $
786 tcGRHSsPat grhss (Check pat_ty) `thenM` \ grhss' ->
787 returnM (PatBind pat' grhss', ids)
789 returnM (complete_it, if isRec is_rec then ids else emptyBag)
791 -- tc_pat_bndr is used when dealing with a LHS binder in a pattern.
792 -- If there was a type sig for that Id, we want to make it much
793 -- as if that type signature had been on the binder as a SigPatIn.
794 -- We check for a type signature; if there is one, we use the mono_id
795 -- from the signature. This is how we make sure the tau part of the
796 -- signature actually matches the type of the LHS; then tc_bind_pats
797 -- ensures the LHS and RHS have the same type
799 tc_pat_bndr name pat_ty
800 = case maybeSig tc_ty_sigs name of
801 Nothing -> newLocalName name `thenM` \ bndr_name ->
802 tcMonoPatBndr bndr_name pat_ty
804 Just sig -> addSrcSpan (srcLocSpan (getSrcLoc name)) $
805 -- TODO: location wrong
806 tcSubPat (idType mono_id) pat_ty `thenM` \ co_fn ->
807 returnM (co_fn, mono_id)
809 mono_id = sig_mono_id sig
813 %************************************************************************
815 \subsection{SPECIALIZE pragmas}
817 %************************************************************************
819 @tcSpecSigs@ munches up the specialisation "signatures" that arise through *user*
820 pragmas. It is convenient for them to appear in the @[RenamedSig]@
821 part of a binding because then the same machinery can be used for
822 moving them into place as is done for type signatures.
827 f :: Ord a => [a] -> b -> b
828 {-# SPECIALIZE f :: [Int] -> b -> b #-}
831 For this we generate:
833 f* = /\ b -> let d1 = ...
837 where f* is a SpecPragmaId. The **sole** purpose of SpecPragmaIds is to
838 retain a right-hand-side that the simplifier will otherwise discard as
839 dead code... the simplifier has a flag that tells it not to discard
840 SpecPragmaId bindings.
842 In this case the f* retains a call-instance of the overloaded
843 function, f, (including appropriate dictionaries) so that the
844 specialiser will subsequently discover that there's a call of @f@ at
845 Int, and will create a specialisation for @f@. After that, the
846 binding for @f*@ can be discarded.
848 We used to have a form
849 {-# SPECIALISE f :: <type> = g #-}
850 which promised that g implemented f at <type>, but we do that with
852 {-# SPECIALISE (f::<type) = g #-}
855 tcSpecSigs :: [LSig Name] -> TcM (LHsBinds TcId)
856 tcSpecSigs (L loc (SpecSig (L nm_loc name) poly_ty) : sigs)
857 = -- SPECIALISE f :: forall b. theta => tau = g
859 addErrCtxt (valSpecSigCtxt name poly_ty) $
861 -- Get and instantiate its alleged specialised type
862 tcHsSigType (FunSigCtxt name) poly_ty `thenM` \ sig_ty ->
864 -- Check that f has a more general type, and build a RHS for
865 -- the spec-pragma-id at the same time
866 getLIE (tcCheckSigma (L nm_loc (HsVar name)) sig_ty) `thenM` \ (spec_expr, spec_lie) ->
868 -- Squeeze out any Methods (see comments with tcSimplifyToDicts)
869 tcSimplifyToDicts spec_lie `thenM` \ spec_binds ->
871 -- Just specialise "f" by building a SpecPragmaId binding
872 -- It is the thing that makes sure we don't prematurely
873 -- dead-code-eliminate the binding we are really interested in.
874 newLocalName name `thenM` \ spec_name ->
876 spec_bind = VarBind (mkSpecPragmaId spec_name sig_ty)
877 (mkHsLet spec_binds spec_expr)
880 -- Do the rest and combine
881 tcSpecSigs sigs `thenM` \ binds_rest ->
882 returnM (binds_rest `snocBag` L loc spec_bind)
884 tcSpecSigs (other_sig : sigs) = tcSpecSigs sigs
885 tcSpecSigs [] = returnM emptyBag
888 %************************************************************************
890 \subsection[TcBinds-errors]{Error contexts and messages}
892 %************************************************************************
896 patMonoBindsCtxt bind
897 = hang (ptext SLIT("In a pattern binding:")) 4 (ppr bind)
899 -----------------------------------------------
901 = sep [ptext SLIT("In a SPECIALIZE pragma for a value:"),
902 nest 4 (ppr v <+> dcolon <+> ppr ty)]
904 -----------------------------------------------
905 sigContextsErr = ptext SLIT("Mismatched contexts")
907 sigContextsCtxt s1 s2
908 = vcat [ptext SLIT("When matching the contexts of the signatures for"),
909 nest 2 (vcat [ppr s1 <+> dcolon <+> ppr (idType s1),
910 ppr s2 <+> dcolon <+> ppr (idType s2)]),
911 ptext SLIT("The signature contexts in a mutually recursive group should all be identical")]
913 -----------------------------------------------
914 unliftedBindErr flavour mbind
915 = hang (text flavour <+> ptext SLIT("bindings for unlifted types aren't allowed:"))
918 -----------------------------------------------
919 existentialExplode mbinds
920 = hang (vcat [text "My brain just exploded.",
921 text "I can't handle pattern bindings for existentially-quantified constructors.",
922 text "In the binding group"])
925 -----------------------------------------------
926 restrictedBindCtxtErr binder_names
927 = hang (ptext SLIT("Illegal overloaded type signature(s)"))
928 4 (vcat [ptext SLIT("in a binding group for") <+> pprBinders binder_names,
929 ptext SLIT("that falls under the monomorphism restriction")])
932 = ptext SLIT("When generalising the type(s) for") <+> pprBinders binder_names
934 -- Used in error messages
935 -- Use quotes for a single one; they look a bit "busy" for several
936 pprBinders [bndr] = quotes (ppr bndr)
937 pprBinders bndrs = pprWithCommas ppr bndrs