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(..), LHsBinds, Sig(..),
16 LSig, Match(..), HsBindGroup(..), IPBind(..),
17 LPat, GRHSs, MatchGroup(..), emptyLHsBinds, isEmptyLHsBinds,
18 collectHsBindBinders, collectPatBinders, pprPatBind
20 import TcHsSyn ( TcId, TcDictBinds, zonkId, mkHsLet )
23 import Inst ( InstOrigin(..), newDictsAtLoc, newIPDict, instToId )
24 import TcEnv ( tcExtendIdEnv, tcExtendIdEnv2, newLocalName, tcLookupLocalIds )
25 import TcUnify ( Expected(..), tcInfer, checkSigTyVars, sigCtxt )
26 import TcSimplify ( tcSimplifyInfer, tcSimplifyInferCheck, tcSimplifyRestricted,
27 tcSimplifyToDicts, tcSimplifyIPs )
28 import TcHsType ( tcHsSigType, UserTypeCtxt(..), tcAddLetBoundTyVars,
29 TcSigInfo(..), TcSigFun, mkTcSig, lookupSig
31 import TcPat ( tcPat, PatCtxt(..) )
32 import TcSimplify ( bindInstsOfLocalFuns )
33 import TcMType ( newTyFlexiVarTy, tcSkolType, zonkQuantifiedTyVar )
34 import TcType ( TcTyVar, SkolemInfo(SigSkol),
35 TcTauType, TcSigmaType,
36 TvSubstEnv, mkTvSubst, substTheta, substTy,
37 mkTyVarTy, mkForAllTys, mkFunTys, tyVarsOfType,
38 mkForAllTy, isUnLiftedType, tcGetTyVar_maybe,
40 import Unify ( tcMatchPreds )
41 import Kind ( argTypeKind, isUnliftedTypeKind )
42 import VarEnv ( lookupVarEnv )
43 import TysPrim ( alphaTyVar )
44 import Id ( mkLocalId, mkSpecPragmaId, setInlinePragma )
45 import Var ( idType, idName )
48 import Var ( tyVarKind )
50 import SrcLoc ( Located(..), unLoc, noLoc, getLoc )
53 import BasicTypes ( TopLevelFlag(..), RecFlag(..), isNonRec, isRec,
54 isNotTopLevel, isAlwaysActive )
55 import FiniteMap ( listToFM, lookupFM )
60 %************************************************************************
62 \subsection{Type-checking bindings}
64 %************************************************************************
66 @tcBindsAndThen@ typechecks a @HsBinds@. The "and then" part is because
67 it needs to know something about the {\em usage} of the things bound,
68 so that it can create specialisations of them. So @tcBindsAndThen@
69 takes a function which, given an extended environment, E, typechecks
70 the scope of the bindings returning a typechecked thing and (most
71 important) an LIE. It is this LIE which is then used as the basis for
72 specialising the things bound.
74 @tcBindsAndThen@ also takes a "combiner" which glues together the
75 bindings and the "thing" to make a new "thing".
77 The real work is done by @tcBindWithSigsAndThen@.
79 Recursive and non-recursive binds are handled in essentially the same
80 way: because of uniques there are no scoping issues left. The only
81 difference is that non-recursive bindings can bind primitive values.
83 Even for non-recursive binding groups we add typings for each binder
84 to the LVE for the following reason. When each individual binding is
85 checked the type of its LHS is unified with that of its RHS; and
86 type-checking the LHS of course requires that the binder is in scope.
88 At the top-level the LIE is sure to contain nothing but constant
89 dictionaries, which we resolve at the module level.
92 tcTopBinds :: [HsBindGroup Name] -> TcM (LHsBinds TcId, TcLclEnv)
93 -- Note: returning the TcLclEnv is more than we really
94 -- want. The bit we care about is the local bindings
95 -- and the free type variables thereof
97 = tc_binds_and_then TopLevel glue binds $
98 getLclEnv `thenM` \ env ->
99 returnM (emptyLHsBinds, env)
101 -- The top level bindings are flattened into a giant
102 -- implicitly-mutually-recursive MonoBinds
103 glue (HsBindGroup binds1 _ _) (binds2, env) = (binds1 `unionBags` binds2, env)
104 -- Can't have a HsIPBinds at top level
108 :: (HsBindGroup TcId -> thing -> thing) -- Combinator
109 -> [HsBindGroup Name]
113 tcBindsAndThen = tc_binds_and_then NotTopLevel
115 tc_binds_and_then top_lvl combiner [] do_next
117 tc_binds_and_then top_lvl combiner (group : groups) do_next
118 = tc_bind_and_then top_lvl combiner group $
119 tc_binds_and_then top_lvl combiner groups do_next
121 tc_bind_and_then top_lvl combiner (HsIPBinds binds) do_next
122 = getLIE do_next `thenM` \ (result, expr_lie) ->
123 mapAndUnzipM (wrapLocSndM tc_ip_bind) binds `thenM` \ (avail_ips, binds') ->
125 -- If the binding binds ?x = E, we must now
126 -- discharge any ?x constraints in expr_lie
127 tcSimplifyIPs avail_ips expr_lie `thenM` \ dict_binds ->
129 returnM (combiner (HsIPBinds binds') $
130 combiner (HsBindGroup dict_binds [] Recursive) result)
132 -- I wonder if we should do these one at at time
135 tc_ip_bind (IPBind ip expr)
136 = newTyFlexiVarTy argTypeKind `thenM` \ ty ->
137 newIPDict (IPBindOrigin ip) ip ty `thenM` \ (ip', ip_inst) ->
138 tcCheckRho expr ty `thenM` \ expr' ->
139 returnM (ip_inst, (IPBind ip' expr'))
141 tc_bind_and_then top_lvl combiner (HsBindGroup binds sigs is_rec) do_next
142 | isEmptyLHsBinds binds
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 tcAddLetBoundTyVars binds $
153 TopLevel -- For the top level don't bother will all this
154 -- bindInstsOfLocalFuns stuff. All the top level
155 -- things are rec'd together anyway, so it's fine to
156 -- leave them to the tcSimplifyTop, and quite a bit faster too
157 -> tcBindWithSigs top_lvl binds sigs is_rec `thenM` \ (poly_binds, poly_ids) ->
158 tc_body poly_ids `thenM` \ (prag_binds, thing) ->
159 returnM (combiner (HsBindGroup
160 (poly_binds `unionBags` prag_binds)
165 NotTopLevel -- For nested bindings we must do the bindInstsOfLocalFuns thing.
166 | not (isRec is_rec) -- Non-recursive group
167 -> -- We want to keep non-recursive things non-recursive
168 -- so that we desugar unlifted bindings correctly
169 tcBindWithSigs top_lvl binds sigs is_rec `thenM` \ (poly_binds, poly_ids) ->
170 getLIE (tc_body poly_ids) `thenM` \ ((prag_binds, thing), lie) ->
172 -- Create specialisations of functions bound here
173 bindInstsOfLocalFuns lie poly_ids `thenM` \ lie_binds ->
176 combiner (HsBindGroup poly_binds [] NonRecursive) $
177 combiner (HsBindGroup prag_binds [] NonRecursive) $
178 combiner (HsBindGroup lie_binds [] Recursive) $
179 -- NB: the binds returned by tcSimplify and
180 -- bindInstsOfLocalFuns aren't guaranteed in
181 -- dependency order (though we could change that);
182 -- hence the Recursive marker.
186 -> -- NB: polymorphic recursion means that a function
187 -- may use an instance of itself, we must look at the LIE arising
188 -- from the function's own right hand side. Hence the getLIE
189 -- encloses the tcBindWithSigs.
192 tcBindWithSigs top_lvl binds sigs is_rec `thenM` \ (poly_binds, poly_ids) ->
193 tc_body poly_ids `thenM` \ (prag_binds, thing) ->
194 returnM (poly_ids, poly_binds `unionBags` prag_binds, thing)
195 ) `thenM` \ ((poly_ids, extra_binds, thing), lie) ->
197 bindInstsOfLocalFuns lie poly_ids `thenM` \ lie_binds ->
199 returnM (combiner (HsBindGroup
200 (extra_binds `unionBags` lie_binds)
204 tc_body poly_ids -- Type check the pragmas and "thing inside"
205 = -- Extend the environment to bind the new polymorphic Ids
206 tcExtendIdEnv poly_ids $
208 -- Build bindings and IdInfos corresponding to user pragmas
209 tcSpecSigs sigs `thenM` \ prag_binds ->
211 -- Now do whatever happens next, in the augmented envt
212 do_next `thenM` \ thing ->
214 returnM (prag_binds, thing)
218 %************************************************************************
220 \subsection{tcBindWithSigs}
222 %************************************************************************
224 @tcBindWithSigs@ deals with a single binding group. It does generalisation,
225 so all the clever stuff is in here.
227 * binder_names and mbind must define the same set of Names
229 * The Names in tc_ty_sigs must be a subset of binder_names
231 * The Ids in tc_ty_sigs don't necessarily have to have the same name
232 as the Name in the tc_ty_sig
235 tcBindWithSigs :: TopLevelFlag
239 -> TcM (LHsBinds TcId, [TcId])
241 tcBindWithSigs top_lvl mbind sigs is_rec = do
242 { -- TYPECHECK THE SIGNATURES
243 tc_ty_sigs <- recoverM (returnM []) $
244 tcTySigs [sig | sig@(L _(Sig name _)) <- sigs]
245 ; let lookup_sig = lookupSig tc_ty_sigs
247 -- SET UP THE MAIN RECOVERY; take advantage of any type sigs
248 ; recoverM (recoveryCode mbind lookup_sig) $ do
250 { traceTc (ptext SLIT("--------------------------------------------------------"))
251 ; traceTc (ptext SLIT("Bindings for") <+> ppr (collectHsBindBinders mbind))
253 -- TYPECHECK THE BINDINGS
254 ; ((mbind', mono_bind_infos), lie_req)
255 <- getLIE (tcMonoBinds mbind lookup_sig is_rec)
258 ; is_unres <- isUnRestrictedGroup mbind tc_ty_sigs
259 ; (tyvars_to_gen, dict_binds, dict_ids)
260 <- setSrcSpan (getLoc (head (bagToList mbind))) $
261 -- TODO: location a bit awkward, but the mbinds have been
262 -- dependency analysed and may no longer be adjacent
263 addErrCtxt (genCtxt (bndrNames mono_bind_infos)) $
264 generalise is_unres mono_bind_infos tc_ty_sigs lie_req
266 -- FINALISE THE QUANTIFIED TYPE VARIABLES
267 -- The quantified type variables often include meta type variables
268 -- we want to freeze them into ordinary type variables, and
269 -- default their kind (e.g. from OpenTypeKind to TypeKind)
270 ; tyvars_to_gen' <- mappM zonkQuantifiedTyVar tyvars_to_gen
272 -- BUILD THE POLYMORPHIC RESULT IDs
274 exports = map mk_export mono_bind_infos
275 poly_ids = [poly_id | (_, poly_id, _) <- exports]
276 dict_tys = map idType dict_ids
278 inlines = mkNameSet [ name
279 | L _ (InlineSig True (L _ name) _) <- sigs]
280 -- Any INLINE sig (regardless of phase control)
281 -- makes the RHS look small
282 inline_phases = listToFM [ (name, phase)
283 | L _ (InlineSig _ (L _ name) phase) <- sigs,
284 not (isAlwaysActive phase)]
285 -- Set the IdInfo field to control the inline phase
286 -- AlwaysActive is the default, so don't bother with them
287 add_inlines id = attachInlinePhase inline_phases id
289 mk_export (binder_name, mb_sig, mono_id)
291 Just sig -> (sig_tvs sig, add_inlines (sig_id sig), mono_id)
292 Nothing -> (tyvars_to_gen', add_inlines new_poly_id, mono_id)
294 new_poly_id = mkLocalId binder_name poly_ty
295 poly_ty = mkForAllTys tyvars_to_gen'
299 -- ZONK THE poly_ids, because they are used to extend the type
300 -- environment; see the invariant on TcEnv.tcExtendIdEnv
301 ; zonked_poly_ids <- mappM zonkId poly_ids
303 ; traceTc (text "binding:" <+> ppr ((dict_ids, dict_binds),
304 exports, map idType zonked_poly_ids))
306 -- Check for an unlifted, non-overloaded group
307 -- In that case we must make extra checks
308 ; if any (isUnLiftedType . idType) zonked_poly_ids
309 then -- Some bindings are unlifted
310 do { checkUnliftedBinds top_lvl is_rec tyvars_to_gen' mbind
313 AbsBinds [] [] exports inlines mbind',
314 -- Do not generate even any x=y bindings
317 else -- The normal case
320 AbsBinds tyvars_to_gen'
324 (dict_binds `unionBags` mbind'),
329 -- If typechecking the binds fails, then return with each
330 -- signature-less binder given type (forall a.a), to minimise
331 -- subsequent error messages
332 recoveryCode mbind lookup_sig
333 = do { traceTc (text "tcBindsWithSigs: error recovery" <+> ppr binder_names)
334 ; return (emptyLHsBinds, poly_ids) }
336 forall_a_a = mkForAllTy alphaTyVar (mkTyVarTy alphaTyVar)
337 binder_names = collectHsBindBinders mbind
338 poly_ids = map mk_dummy binder_names
339 mk_dummy name = case lookup_sig name of
340 Just sig -> sig_id sig -- Signature
341 Nothing -> mkLocalId name forall_a_a -- No signature
343 attachInlinePhase inline_phases bndr
344 = case lookupFM inline_phases (idName bndr) of
345 Just prag -> bndr `setInlinePragma` prag
348 -- Check that non-overloaded unlifted bindings are
351 -- c) non-polymorphic
352 -- d) not a multiple-binding group (more or less implied by (a))
354 checkUnliftedBinds top_lvl is_rec tyvars_to_gen mbind
355 = ASSERT( not (any (isUnliftedTypeKind . tyVarKind) tyvars_to_gen) )
356 -- The instCantBeGeneralised stuff in tcSimplify should have
357 -- already raised an error if we're trying to generalise an
358 -- unboxed tyvar (NB: unboxed tyvars are always introduced
359 -- along with a class constraint) and it's better done there
360 -- because we have more precise origin information.
361 -- That's why we just use an ASSERT here.
363 checkTc (isNotTopLevel top_lvl)
364 (unliftedBindErr "Top-level" mbind) `thenM_`
365 checkTc (isNonRec is_rec)
366 (unliftedBindErr "Recursive" mbind) `thenM_`
367 checkTc (isSingletonBag mbind)
368 (unliftedBindErr "Multiple" mbind) `thenM_`
369 checkTc (null tyvars_to_gen)
370 (unliftedBindErr "Polymorphic" mbind)
374 Polymorphic recursion
375 ~~~~~~~~~~~~~~~~~~~~~
376 The game plan for polymorphic recursion in the code above is
378 * Bind any variable for which we have a type signature
379 to an Id with a polymorphic type. Then when type-checking
380 the RHSs we'll make a full polymorphic call.
382 This fine, but if you aren't a bit careful you end up with a horrendous
383 amount of partial application and (worse) a huge space leak. For example:
385 f :: Eq a => [a] -> [a]
388 If we don't take care, after typechecking we get
390 f = /\a -> \d::Eq a -> let f' = f a d
394 Notice the the stupid construction of (f a d), which is of course
395 identical to the function we're executing. In this case, the
396 polymorphic recursion isn't being used (but that's a very common case).
399 f = /\a -> \d::Eq a -> letrec
400 fm = \ys:[a] -> ...fm...
404 This can lead to a massive space leak, from the following top-level defn
410 Now (f dEqInt) evaluates to a lambda that has f' as a free variable; but
411 f' is another thunk which evaluates to the same thing... and you end
412 up with a chain of identical values all hung onto by the CAF ff.
416 = let f' = f Int dEqInt in \ys. ...f'...
418 = let f' = let f' = f Int dEqInt in \ys. ...f'...
422 Solution: when typechecking the RHSs we always have in hand the
423 *monomorphic* Ids for each binding. So we just need to make sure that
424 if (Method f a d) shows up in the constraints emerging from (...f...)
425 we just use the monomorphic Id. We achieve this by adding monomorphic Ids
426 to the "givens" when simplifying constraints. That's what the "lies_avail"
430 %************************************************************************
432 \subsection{tcMonoBind}
434 %************************************************************************
436 @tcMonoBinds@ deals with a single @MonoBind@.
437 The signatures have been dealt with already.
440 tcMonoBinds :: LHsBinds Name
441 -> TcSigFun -> RecFlag
442 -> TcM (LHsBinds TcId, [MonoBindInfo])
444 type MonoBindInfo = (Name, Maybe TcSigInfo, TcId)
445 -- Type signature (if any), and
446 -- the monomorphic bound things
448 bndrNames :: [MonoBindInfo] -> [Name]
449 bndrNames mbi = [n | (n,_,_) <- mbi]
451 getMonoType :: MonoBindInfo -> TcTauType
452 getMonoType (_,_,mono_id) = idType mono_id
454 tcMonoBinds binds lookup_sig is_rec
455 = do { tc_binds <- mapBagM (wrapLocM (tcLhs lookup_sig)) binds
456 ; let mono_info = getMonoBindInfo tc_binds
457 ; binds' <- tcExtendIdEnv2 (rhsEnvExtension mono_info) $
458 mapBagM (wrapLocM tcRhs) tc_binds
459 ; return (binds', mono_info) }
461 ------------------------
462 -- tcLhs typechecks the LHS of the bindings, to construct the environment in which
463 -- we typecheck the RHSs. Basically what we are doing is this: for each binder:
464 -- if there's a signature for it, use the instantiated signature type
465 -- otherwise invent a type variable
466 -- You see that quite directly in the FunBind case.
468 -- But there's a complication for pattern bindings:
469 -- data T = MkT (forall a. a->a)
471 -- Here we can guess a type variable for the entire LHS (which will be refined to T)
472 -- but we want to get (f::forall a. a->a) as the RHS environment.
473 -- The simplest way to do this is to typecheck the pattern, and then look up the
474 -- bound mono-ids. Then we want to retain the typechecked pattern to avoid re-doing
475 -- it; hence the TcMonoBind data type in which the LHS is done but the RHS isn't
477 data TcMonoBind -- Half completed; LHS done, RHS not done
478 = TcFunBind MonoBindInfo (Located TcId) Bool (MatchGroup Name)
479 | TcPatBind [MonoBindInfo] (LPat TcId) (GRHSs Name) TcSigmaType
481 tcLhs :: TcSigFun -> HsBind Name -> TcM TcMonoBind
482 tcLhs lookup_sig (FunBind (L nm_loc name) inf matches)
483 = do { let mb_sig = lookup_sig name
484 ; mono_name <- newLocalName name
485 ; mono_ty <- mk_mono_ty mb_sig
486 ; let mono_id = mkLocalId mono_name mono_ty
487 ; return (TcFunBind (name, mb_sig, mono_id) (L nm_loc mono_id) inf matches) }
489 mk_mono_ty (Just sig) = return (sig_tau sig)
490 mk_mono_ty Nothing = newTyFlexiVarTy argTypeKind
492 tcLhs lookup_sig bind@(PatBind pat grhss _)
493 = do { let tc_pat exp_ty = tcPat (LetPat lookup_sig) pat exp_ty lookup_infos
494 ; ((pat', ex_tvs, infos), pat_ty)
495 <- addErrCtxt (patMonoBindsCtxt pat grhss)
498 -- Don't know how to deal with pattern-bound existentials yet
499 ; checkTc (null ex_tvs) (existentialExplode bind)
501 ; return (TcPatBind infos pat' grhss pat_ty) }
503 names = collectPatBinders pat
505 -- After typechecking the pattern, look up the binder
506 -- names, which the pattern has brought into scope.
507 lookup_infos :: TcM [MonoBindInfo]
508 lookup_infos = do { mono_ids <- tcLookupLocalIds names
509 ; return [ (name, lookup_sig name, mono_id)
510 | (name, mono_id) <- names `zip` mono_ids] }
513 tcRhs :: TcMonoBind -> TcM (HsBind TcId)
514 tcRhs (TcFunBind _ fun'@(L _ mono_id) inf matches)
515 = do { matches' <- tcMatchesFun (idName mono_id) matches
516 (Check (idType mono_id))
517 ; return (FunBind fun' inf matches') }
519 tcRhs bind@(TcPatBind _ pat' grhss pat_ty)
520 = do { grhss' <- addErrCtxt (patMonoBindsCtxt pat' grhss) $
521 tcGRHSsPat grhss (Check pat_ty)
522 ; return (PatBind pat' grhss' pat_ty) }
525 ---------------------
526 getMonoBindInfo :: Bag (Located TcMonoBind) -> [MonoBindInfo]
527 getMonoBindInfo tc_binds
528 = foldrBag (get_info . unLoc) [] tc_binds
530 get_info (TcFunBind info _ _ _) rest = info : rest
531 get_info (TcPatBind infos _ _ _) rest = infos ++ rest
533 ---------------------
534 rhsEnvExtension :: [MonoBindInfo] -> [(Name, TcId)]
535 -- Environment for RHS of definitions: use type sig if there is one
536 rhsEnvExtension mono_info
539 mk (name, Just sig, _) = (name, sig_id sig)
540 mk (name, Nothing, mono_id) = (name, mono_id)
544 %************************************************************************
546 \subsection{getTyVarsToGen}
548 %************************************************************************
551 tcTySigs :: [LSig Name] -> TcM [TcSigInfo]
552 -- The trick here is that all the signatures should have the same
553 -- context, and we want to share type variables for that context, so that
554 -- all the right hand sides agree a common vocabulary for their type
556 tcTySigs [] = return []
557 tcTySigs (L span (Sig (L _ name) ty) : sigs)
558 = do { -- Typecheck the first signature
559 ; sigma1 <- setSrcSpan span $
560 tcHsSigType (FunSigCtxt name) ty
561 ; let id1 = mkLocalId name sigma1
562 ; tc_sig1 <- mkTcSig id1
564 ; tc_sigs <- mapM (tcTySig tc_sig1) sigs
565 ; return (tc_sig1 : tc_sigs) }
567 tcTySig sig1 (L span (Sig (L _ name) ty))
569 do { sigma_ty <- tcHsSigType (FunSigCtxt name) ty
570 ; (tvs, theta, tau) <- tcSkolType rigid_info sigma_ty
571 ; let poly_id = mkLocalId name sigma_ty
572 bale_out = failWithTc $
573 sigContextsErr (sig_id sig1) name sigma_ty
575 -- Try to match the context of this signature with
576 -- that of the first signature
577 ; case tcMatchPreds tvs (sig_theta sig1) theta of {
580 ; case check_tvs tenv tvs of
584 let subst = mkTvSubst tenv
585 theta' = substTheta subst theta
586 tau' = substTy subst tau
587 ; loc <- getInstLoc (SigOrigin rigid_info)
588 ; return (TcSigInfo { sig_id = poly_id, sig_tvs = tvs',
589 sig_theta = theta', sig_tau = tau',
592 rigid_info = SigSkol name
594 -- Rather tedious check that the type variables
595 -- have been matched only with another type variable,
596 -- and that two type variables have not been matched
598 -- A return of Nothing indicates that one of the bad
599 -- things has happened
600 check_tvs :: TvSubstEnv -> [TcTyVar] -> Maybe [TcTyVar]
601 check_tvs tenv [] = Just []
602 check_tvs tenv (tv:tvs)
603 | Just ty <- lookupVarEnv tenv tv
604 = do { tv' <- tcGetTyVar_maybe ty
605 ; tvs' <- check_tvs tenv tvs
608 else Just (tv':tvs') }
610 = do { tvs' <- check_tvs tenv tvs
615 generalise :: Bool -> [MonoBindInfo] -> [TcSigInfo] -> [Inst]
616 -> TcM ([TcTyVar], TcDictBinds, [TcId])
617 generalise is_unrestricted mono_infos sigs lie_req
618 | not is_unrestricted -- RESTRICTED CASE
619 = -- Check signature contexts are empty
620 do { checkTc (all is_mono_sig sigs)
621 (restrictedBindCtxtErr bndr_names)
623 -- Now simplify with exactly that set of tyvars
624 -- We have to squash those Methods
625 ; (qtvs, binds) <- tcSimplifyRestricted doc tau_tvs lie_req
627 -- Check that signature type variables are OK
628 ; final_qtvs <- checkSigsTyVars qtvs sigs
630 ; return (final_qtvs, binds, []) }
632 | null sigs -- UNRESTRICTED CASE, NO TYPE SIGS
633 = tcSimplifyInfer doc tau_tvs lie_req
635 | otherwise -- UNRESTRICTED CASE, WITH TYPE SIGS
636 = do { let sig1 = head sigs
637 ; sig_lie <- newDictsAtLoc (sig_loc sig1) (sig_theta sig1)
638 ; let -- The "sig_avails" is the stuff available. We get that from
639 -- the context of the type signature, BUT ALSO the lie_avail
640 -- so that polymorphic recursion works right (see comments at end of fn)
641 local_meths = [mkMethInst sig mono_id | (_, Just sig, mono_id) <- mono_infos]
642 sig_avails = sig_lie ++ local_meths
644 -- Check that the needed dicts can be
645 -- expressed in terms of the signature ones
646 ; (forall_tvs, dict_binds) <- tcSimplifyInferCheck doc tau_tvs sig_avails lie_req
648 -- Check that signature type variables are OK
649 ; final_qtvs <- checkSigsTyVars forall_tvs sigs
651 ; returnM (final_qtvs, dict_binds, map instToId sig_lie) }
654 bndr_names = bndrNames mono_infos
655 tau_tvs = foldr (unionVarSet . tyVarsOfType . getMonoType) emptyVarSet mono_infos
656 is_mono_sig sig = null (sig_theta sig)
657 doc = ptext SLIT("type signature(s) for") <+> pprBinders bndr_names
659 mkMethInst (TcSigInfo { sig_id = poly_id, sig_tvs = tvs,
660 sig_theta = theta, sig_tau = tau, sig_loc = loc }) mono_id
661 = Method mono_id poly_id (mkTyVarTys tvs) theta tau loc
663 checkSigsTyVars :: [TcTyVar] -> [TcSigInfo] -> TcM [TcTyVar]
664 checkSigsTyVars qtvs sigs
665 = mappM check_one sigs `thenM` \ sig_tvs_s ->
667 -- Sigh. Make sure that all the tyvars in the type sigs
668 -- appear in the returned ty var list, which is what we are
669 -- going to generalise over. Reason: we occasionally get
671 -- type T a = () -> ()
674 -- Here, 'a' won't appear in qtvs, so we have to add it
676 sig_tvs = foldl extendVarSetList emptyVarSet sig_tvs_s
677 all_tvs = extendVarSetList sig_tvs qtvs
679 returnM (varSetElems all_tvs)
681 check_one (TcSigInfo {sig_id = id, sig_tvs = tvs, sig_theta = theta, sig_tau = tau})
682 = addErrCtxt (ptext SLIT("In the type signature for")
683 <+> quotes (ppr id)) $
684 addErrCtxtM (sigCtxt id tvs theta tau) $
685 do { checkSigTyVars tvs; return tvs }
688 @getTyVarsToGen@ decides what type variables to generalise over.
690 For a "restricted group" -- see the monomorphism restriction
691 for a definition -- we bind no dictionaries, and
692 remove from tyvars_to_gen any constrained type variables
694 *Don't* simplify dicts at this point, because we aren't going
695 to generalise over these dicts. By the time we do simplify them
696 we may well know more. For example (this actually came up)
698 f x = array ... xs where xs = [1,2,3,4,5]
699 We don't want to generate lots of (fromInt Int 1), (fromInt Int 2)
700 stuff. If we simplify only at the f-binding (not the xs-binding)
701 we'll know that the literals are all Ints, and we can just produce
704 Find all the type variables involved in overloading, the
705 "constrained_tyvars". These are the ones we *aren't* going to
706 generalise. We must be careful about doing this:
708 (a) If we fail to generalise a tyvar which is not actually
709 constrained, then it will never, ever get bound, and lands
710 up printed out in interface files! Notorious example:
711 instance Eq a => Eq (Foo a b) where ..
712 Here, b is not constrained, even though it looks as if it is.
713 Another, more common, example is when there's a Method inst in
714 the LIE, whose type might very well involve non-overloaded
716 [NOTE: Jan 2001: I don't understand the problem here so I'm doing
717 the simple thing instead]
719 (b) On the other hand, we mustn't generalise tyvars which are constrained,
720 because we are going to pass on out the unmodified LIE, with those
721 tyvars in it. They won't be in scope if we've generalised them.
723 So we are careful, and do a complete simplification just to find the
724 constrained tyvars. We don't use any of the results, except to
725 find which tyvars are constrained.
728 isUnRestrictedGroup :: LHsBinds Name -> [TcSigInfo] -> TcM Bool
729 isUnRestrictedGroup binds sigs
730 = do { no_MR <- doptM Opt_NoMonomorphismRestriction
731 ; return (no_MR || all_unrestricted) }
733 all_unrestricted = all (unrestricted . unLoc) (bagToList binds)
734 tysig_names = map (idName . sig_id) sigs
736 unrestricted (PatBind other _ _) = False
737 unrestricted (VarBind v _) = v `is_elem` tysig_names
738 unrestricted (FunBind v _ matches) = unrestricted_match matches
739 || unLoc v `is_elem` tysig_names
741 unrestricted_match (MatchGroup (L _ (Match [] _ _) : _) _) = False
742 -- No args => like a pattern binding
743 unrestricted_match other = True
744 -- Some args => a function binding
746 is_elem v vs = isIn "isUnResMono" v vs
750 %************************************************************************
752 \subsection{SPECIALIZE pragmas}
754 %************************************************************************
756 @tcSpecSigs@ munches up the specialisation "signatures" that arise through *user*
757 pragmas. It is convenient for them to appear in the @[RenamedSig]@
758 part of a binding because then the same machinery can be used for
759 moving them into place as is done for type signatures.
764 f :: Ord a => [a] -> b -> b
765 {-# SPECIALIZE f :: [Int] -> b -> b #-}
768 For this we generate:
770 f* = /\ b -> let d1 = ...
774 where f* is a SpecPragmaId. The **sole** purpose of SpecPragmaIds is to
775 retain a right-hand-side that the simplifier will otherwise discard as
776 dead code... the simplifier has a flag that tells it not to discard
777 SpecPragmaId bindings.
779 In this case the f* retains a call-instance of the overloaded
780 function, f, (including appropriate dictionaries) so that the
781 specialiser will subsequently discover that there's a call of @f@ at
782 Int, and will create a specialisation for @f@. After that, the
783 binding for @f*@ can be discarded.
785 We used to have a form
786 {-# SPECIALISE f :: <type> = g #-}
787 which promised that g implemented f at <type>, but we do that with
789 {-# RULES (f::<type>) = g #-}
792 tcSpecSigs :: [LSig Name] -> TcM (LHsBinds TcId)
793 tcSpecSigs (L loc (SpecSig (L nm_loc name) poly_ty) : sigs)
794 = -- SPECIALISE f :: forall b. theta => tau = g
796 addErrCtxt (valSpecSigCtxt name poly_ty) $
798 -- Get and instantiate its alleged specialised type
799 tcHsSigType (FunSigCtxt name) poly_ty `thenM` \ sig_ty ->
801 -- Check that f has a more general type, and build a RHS for
802 -- the spec-pragma-id at the same time
803 getLIE (tcCheckSigma (L nm_loc (HsVar name)) sig_ty) `thenM` \ (spec_expr, spec_lie) ->
805 -- Squeeze out any Methods (see comments with tcSimplifyToDicts)
806 tcSimplifyToDicts spec_lie `thenM` \ spec_binds ->
808 -- Just specialise "f" by building a SpecPragmaId binding
809 -- It is the thing that makes sure we don't prematurely
810 -- dead-code-eliminate the binding we are really interested in.
811 newLocalName name `thenM` \ spec_name ->
813 spec_bind = VarBind (mkSpecPragmaId spec_name sig_ty)
814 (mkHsLet spec_binds spec_expr)
817 -- Do the rest and combine
818 tcSpecSigs sigs `thenM` \ binds_rest ->
819 returnM (binds_rest `snocBag` L loc spec_bind)
821 tcSpecSigs (other_sig : sigs) = tcSpecSigs sigs
822 tcSpecSigs [] = returnM emptyLHsBinds
825 %************************************************************************
827 \subsection[TcBinds-errors]{Error contexts and messages}
829 %************************************************************************
833 -- This one is called on LHS, when pat and grhss are both Name
834 -- and on RHS, when pat is TcId and grhss is still Name
835 patMonoBindsCtxt pat grhss
836 = hang (ptext SLIT("In a pattern binding:")) 4 (pprPatBind pat grhss)
838 -----------------------------------------------
840 = sep [ptext SLIT("In a SPECIALIZE pragma for a value:"),
841 nest 4 (ppr v <+> dcolon <+> ppr ty)]
843 -----------------------------------------------
844 sigContextsErr id1 name ty
845 = vcat [ptext SLIT("Mis-match between the contexts of the signatures for"),
846 nest 2 (vcat [ppr id1 <+> dcolon <+> ppr (idType id1),
847 ppr name <+> dcolon <+> ppr ty]),
848 ptext SLIT("The signature contexts in a mutually recursive group should all be identical")]
851 -----------------------------------------------
852 unliftedBindErr flavour mbind
853 = hang (text flavour <+> ptext SLIT("bindings for unlifted types aren't allowed:"))
856 -----------------------------------------------
857 existentialExplode mbinds
858 = hang (vcat [text "My brain just exploded.",
859 text "I can't handle pattern bindings for existentially-quantified constructors.",
860 text "In the binding group"])
863 -----------------------------------------------
864 restrictedBindCtxtErr binder_names
865 = hang (ptext SLIT("Illegal overloaded type signature(s)"))
866 4 (vcat [ptext SLIT("in a binding group for") <+> pprBinders binder_names,
867 ptext SLIT("that falls under the monomorphism restriction")])
870 = ptext SLIT("When generalising the type(s) for") <+> pprBinders binder_names
872 -- Used in error messages
873 -- Use quotes for a single one; they look a bit "busy" for several
874 pprBinders [bndr] = quotes (ppr bndr)
875 pprBinders bndrs = pprWithCommas ppr bndrs