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, zonkTcTypes )
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])
240 -- The returned TcIds are guaranteed zonked
242 tcBindWithSigs top_lvl mbind sigs is_rec = do
243 { -- TYPECHECK THE SIGNATURES
244 tc_ty_sigs <- recoverM (returnM []) $
245 tcTySigs [sig | sig@(L _(Sig name _)) <- sigs]
246 ; let lookup_sig = lookupSig tc_ty_sigs
248 -- SET UP THE MAIN RECOVERY; take advantage of any type sigs
249 ; recoverM (recoveryCode mbind lookup_sig) $ do
251 { traceTc (ptext SLIT("--------------------------------------------------------"))
252 ; traceTc (ptext SLIT("Bindings for") <+> ppr (collectHsBindBinders mbind))
254 -- TYPECHECK THE BINDINGS
255 ; ((mbind', mono_bind_infos), lie_req)
256 <- getLIE (tcMonoBinds mbind lookup_sig is_rec)
258 -- CHECK FOR UNLIFTED BINDINGS
259 -- These must be non-recursive etc, and are not generalised
260 -- They desugar to a case expression in the end
261 ; zonked_mono_tys <- zonkTcTypes (map getMonoType mono_bind_infos)
262 ; if any isUnLiftedType zonked_mono_tys then
263 do { -- Unlifted bindings
264 checkUnliftedBinds top_lvl is_rec mbind
266 ; let exports = zipWith mk_export mono_bind_infos zonked_mono_tys
267 mk_export (name, Nothing, mono_id) mono_ty = ([], mkLocalId name mono_ty, mono_id)
268 mk_export (name, Just sig, mono_id) mono_ty = ([], sig_id sig, mono_id)
270 ; return ( unitBag $ noLoc $ AbsBinds [] [] exports emptyNameSet mbind',
271 [poly_id | (_, poly_id, _) <- exports]) } -- Guaranteed zonked
273 else do -- The normal lifted case: GENERALISE
274 { is_unres <- isUnRestrictedGroup mbind tc_ty_sigs
275 ; (tyvars_to_gen, dict_binds, dict_ids)
276 <- setSrcSpan (getLoc (head (bagToList mbind))) $
277 -- TODO: location a bit awkward, but the mbinds have been
278 -- dependency analysed and may no longer be adjacent
279 addErrCtxt (genCtxt (bndrNames mono_bind_infos)) $
280 generalise is_unres mono_bind_infos tc_ty_sigs lie_req
282 -- FINALISE THE QUANTIFIED TYPE VARIABLES
283 -- The quantified type variables often include meta type variables
284 -- we want to freeze them into ordinary type variables, and
285 -- default their kind (e.g. from OpenTypeKind to TypeKind)
286 ; tyvars_to_gen' <- mappM zonkQuantifiedTyVar tyvars_to_gen
288 -- BUILD THE POLYMORPHIC RESULT IDs
290 exports = map mk_export mono_bind_infos
291 poly_ids = [poly_id | (_, poly_id, _) <- exports]
292 dict_tys = map idType dict_ids
294 inlines = mkNameSet [ name
295 | L _ (InlineSig True (L _ name) _) <- sigs]
296 -- Any INLINE sig (regardless of phase control)
297 -- makes the RHS look small
298 inline_phases = listToFM [ (name, phase)
299 | L _ (InlineSig _ (L _ name) phase) <- sigs,
300 not (isAlwaysActive phase)]
301 -- Set the IdInfo field to control the inline phase
302 -- AlwaysActive is the default, so don't bother with them
303 add_inlines id = attachInlinePhase inline_phases id
305 mk_export (binder_name, mb_sig, mono_id)
307 Just sig -> (sig_tvs sig, add_inlines (sig_id sig), mono_id)
308 Nothing -> (tyvars_to_gen', add_inlines new_poly_id, mono_id)
310 new_poly_id = mkLocalId binder_name poly_ty
311 poly_ty = mkForAllTys tyvars_to_gen'
315 -- ZONK THE poly_ids, because they are used to extend the type
316 -- environment; see the invariant on TcEnv.tcExtendIdEnv
317 ; zonked_poly_ids <- mappM zonkId poly_ids
319 ; traceTc (text "binding:" <+> ppr ((dict_ids, dict_binds),
320 exports, map idType zonked_poly_ids))
324 AbsBinds tyvars_to_gen'
328 (dict_binds `unionBags` mbind'),
333 -- If typechecking the binds fails, then return with each
334 -- signature-less binder given type (forall a.a), to minimise
335 -- subsequent error messages
336 recoveryCode mbind lookup_sig
337 = do { traceTc (text "tcBindsWithSigs: error recovery" <+> ppr binder_names)
338 ; return (emptyLHsBinds, poly_ids) }
340 forall_a_a = mkForAllTy alphaTyVar (mkTyVarTy alphaTyVar)
341 binder_names = collectHsBindBinders mbind
342 poly_ids = map mk_dummy binder_names
343 mk_dummy name = case lookup_sig name of
344 Just sig -> sig_id sig -- Signature
345 Nothing -> mkLocalId name forall_a_a -- No signature
347 attachInlinePhase inline_phases bndr
348 = case lookupFM inline_phases (idName bndr) of
349 Just prag -> bndr `setInlinePragma` prag
352 -- Check that non-overloaded unlifted bindings are
355 -- c) not a multiple-binding group (more or less implied by (a))
357 checkUnliftedBinds top_lvl is_rec mbind
358 = checkTc (isNotTopLevel top_lvl)
359 (unliftedBindErr "Top-level" mbind) `thenM_`
360 checkTc (isNonRec is_rec)
361 (unliftedBindErr "Recursive" mbind) `thenM_`
362 checkTc (isSingletonBag mbind)
363 (unliftedBindErr "Multiple" mbind)
367 Polymorphic recursion
368 ~~~~~~~~~~~~~~~~~~~~~
369 The game plan for polymorphic recursion in the code above is
371 * Bind any variable for which we have a type signature
372 to an Id with a polymorphic type. Then when type-checking
373 the RHSs we'll make a full polymorphic call.
375 This fine, but if you aren't a bit careful you end up with a horrendous
376 amount of partial application and (worse) a huge space leak. For example:
378 f :: Eq a => [a] -> [a]
381 If we don't take care, after typechecking we get
383 f = /\a -> \d::Eq a -> let f' = f a d
387 Notice the the stupid construction of (f a d), which is of course
388 identical to the function we're executing. In this case, the
389 polymorphic recursion isn't being used (but that's a very common case).
392 f = /\a -> \d::Eq a -> letrec
393 fm = \ys:[a] -> ...fm...
397 This can lead to a massive space leak, from the following top-level defn
403 Now (f dEqInt) evaluates to a lambda that has f' as a free variable; but
404 f' is another thunk which evaluates to the same thing... and you end
405 up with a chain of identical values all hung onto by the CAF ff.
409 = let f' = f Int dEqInt in \ys. ...f'...
411 = let f' = let f' = f Int dEqInt in \ys. ...f'...
415 Solution: when typechecking the RHSs we always have in hand the
416 *monomorphic* Ids for each binding. So we just need to make sure that
417 if (Method f a d) shows up in the constraints emerging from (...f...)
418 we just use the monomorphic Id. We achieve this by adding monomorphic Ids
419 to the "givens" when simplifying constraints. That's what the "lies_avail"
423 %************************************************************************
425 \subsection{tcMonoBind}
427 %************************************************************************
429 @tcMonoBinds@ deals with a single @MonoBind@.
430 The signatures have been dealt with already.
433 tcMonoBinds :: LHsBinds Name
434 -> TcSigFun -> RecFlag
435 -> TcM (LHsBinds TcId, [MonoBindInfo])
437 type MonoBindInfo = (Name, Maybe TcSigInfo, TcId)
438 -- Type signature (if any), and
439 -- the monomorphic bound things
441 bndrNames :: [MonoBindInfo] -> [Name]
442 bndrNames mbi = [n | (n,_,_) <- mbi]
444 getMonoType :: MonoBindInfo -> TcTauType
445 getMonoType (_,_,mono_id) = idType mono_id
447 tcMonoBinds binds lookup_sig is_rec
448 = do { tc_binds <- mapBagM (wrapLocM (tcLhs lookup_sig)) binds
449 ; let mono_info = getMonoBindInfo tc_binds
450 ; binds' <- tcExtendIdEnv2 (rhsEnvExtension mono_info) $
451 mapBagM (wrapLocM tcRhs) tc_binds
452 ; return (binds', mono_info) }
454 ------------------------
455 -- tcLhs typechecks the LHS of the bindings, to construct the environment in which
456 -- we typecheck the RHSs. Basically what we are doing is this: for each binder:
457 -- if there's a signature for it, use the instantiated signature type
458 -- otherwise invent a type variable
459 -- You see that quite directly in the FunBind case.
461 -- But there's a complication for pattern bindings:
462 -- data T = MkT (forall a. a->a)
464 -- Here we can guess a type variable for the entire LHS (which will be refined to T)
465 -- but we want to get (f::forall a. a->a) as the RHS environment.
466 -- The simplest way to do this is to typecheck the pattern, and then look up the
467 -- bound mono-ids. Then we want to retain the typechecked pattern to avoid re-doing
468 -- it; hence the TcMonoBind data type in which the LHS is done but the RHS isn't
470 data TcMonoBind -- Half completed; LHS done, RHS not done
471 = TcFunBind MonoBindInfo (Located TcId) Bool (MatchGroup Name)
472 | TcPatBind [MonoBindInfo] (LPat TcId) (GRHSs Name) TcSigmaType
474 tcLhs :: TcSigFun -> HsBind Name -> TcM TcMonoBind
475 tcLhs lookup_sig (FunBind (L nm_loc name) inf matches)
476 = do { let mb_sig = lookup_sig name
477 ; mono_name <- newLocalName name
478 ; mono_ty <- mk_mono_ty mb_sig
479 ; let mono_id = mkLocalId mono_name mono_ty
480 ; return (TcFunBind (name, mb_sig, mono_id) (L nm_loc mono_id) inf matches) }
482 mk_mono_ty (Just sig) = return (sig_tau sig)
483 mk_mono_ty Nothing = newTyFlexiVarTy argTypeKind
485 tcLhs lookup_sig bind@(PatBind pat grhss _)
486 = do { let tc_pat exp_ty = tcPat (LetPat lookup_sig) pat exp_ty lookup_infos
487 ; ((pat', ex_tvs, infos), pat_ty)
488 <- addErrCtxt (patMonoBindsCtxt pat grhss)
491 -- Don't know how to deal with pattern-bound existentials yet
492 ; checkTc (null ex_tvs) (existentialExplode bind)
494 ; return (TcPatBind infos pat' grhss pat_ty) }
496 names = collectPatBinders pat
498 -- After typechecking the pattern, look up the binder
499 -- names, which the pattern has brought into scope.
500 lookup_infos :: TcM [MonoBindInfo]
501 lookup_infos = do { mono_ids <- tcLookupLocalIds names
502 ; return [ (name, lookup_sig name, mono_id)
503 | (name, mono_id) <- names `zip` mono_ids] }
506 tcRhs :: TcMonoBind -> TcM (HsBind TcId)
507 tcRhs (TcFunBind _ fun'@(L _ mono_id) inf matches)
508 = do { matches' <- tcMatchesFun (idName mono_id) matches
509 (Check (idType mono_id))
510 ; return (FunBind fun' inf matches') }
512 tcRhs bind@(TcPatBind _ pat' grhss pat_ty)
513 = do { grhss' <- addErrCtxt (patMonoBindsCtxt pat' grhss) $
514 tcGRHSsPat grhss (Check pat_ty)
515 ; return (PatBind pat' grhss' pat_ty) }
518 ---------------------
519 getMonoBindInfo :: Bag (Located TcMonoBind) -> [MonoBindInfo]
520 getMonoBindInfo tc_binds
521 = foldrBag (get_info . unLoc) [] tc_binds
523 get_info (TcFunBind info _ _ _) rest = info : rest
524 get_info (TcPatBind infos _ _ _) rest = infos ++ rest
526 ---------------------
527 rhsEnvExtension :: [MonoBindInfo] -> [(Name, TcId)]
528 -- Environment for RHS of definitions: use type sig if there is one
529 rhsEnvExtension mono_info
532 mk (name, Just sig, _) = (name, sig_id sig)
533 mk (name, Nothing, mono_id) = (name, mono_id)
537 %************************************************************************
539 \subsection{getTyVarsToGen}
541 %************************************************************************
544 tcTySigs :: [LSig Name] -> TcM [TcSigInfo]
545 -- The trick here is that all the signatures should have the same
546 -- context, and we want to share type variables for that context, so that
547 -- all the right hand sides agree a common vocabulary for their type
549 tcTySigs [] = return []
550 tcTySigs (L span (Sig (L _ name) ty) : sigs)
551 = do { -- Typecheck the first signature
552 ; sigma1 <- setSrcSpan span $
553 tcHsSigType (FunSigCtxt name) ty
554 ; let id1 = mkLocalId name sigma1
555 ; tc_sig1 <- mkTcSig id1
557 ; tc_sigs <- mapM (tcTySig tc_sig1) sigs
558 ; return (tc_sig1 : tc_sigs) }
560 tcTySig sig1 (L span (Sig (L _ name) ty))
562 do { sigma_ty <- tcHsSigType (FunSigCtxt name) ty
563 ; (tvs, theta, tau) <- tcSkolType rigid_info sigma_ty
564 ; let poly_id = mkLocalId name sigma_ty
565 bale_out = failWithTc $
566 sigContextsErr (sig_id sig1) name sigma_ty
568 -- Try to match the context of this signature with
569 -- that of the first signature
570 ; case tcMatchPreds tvs (sig_theta sig1) theta of {
573 ; case check_tvs tenv tvs of
577 let subst = mkTvSubst tenv
578 theta' = substTheta subst theta
579 tau' = substTy subst tau
580 ; loc <- getInstLoc (SigOrigin rigid_info)
581 ; return (TcSigInfo { sig_id = poly_id, sig_tvs = tvs',
582 sig_theta = theta', sig_tau = tau',
585 rigid_info = SigSkol name
587 -- Rather tedious check that the type variables
588 -- have been matched only with another type variable,
589 -- and that two type variables have not been matched
591 -- A return of Nothing indicates that one of the bad
592 -- things has happened
593 check_tvs :: TvSubstEnv -> [TcTyVar] -> Maybe [TcTyVar]
594 check_tvs tenv [] = Just []
595 check_tvs tenv (tv:tvs)
596 | Just ty <- lookupVarEnv tenv tv
597 = do { tv' <- tcGetTyVar_maybe ty
598 ; tvs' <- check_tvs tenv tvs
601 else Just (tv':tvs') }
603 = do { tvs' <- check_tvs tenv tvs
608 generalise :: Bool -> [MonoBindInfo] -> [TcSigInfo] -> [Inst]
609 -> TcM ([TcTyVar], TcDictBinds, [TcId])
610 generalise is_unrestricted mono_infos sigs lie_req
611 | not is_unrestricted -- RESTRICTED CASE
612 = -- Check signature contexts are empty
613 do { checkTc (all is_mono_sig sigs)
614 (restrictedBindCtxtErr bndr_names)
616 -- Now simplify with exactly that set of tyvars
617 -- We have to squash those Methods
618 ; (qtvs, binds) <- tcSimplifyRestricted doc tau_tvs lie_req
620 -- Check that signature type variables are OK
621 ; final_qtvs <- checkSigsTyVars qtvs sigs
623 ; return (final_qtvs, binds, []) }
625 | null sigs -- UNRESTRICTED CASE, NO TYPE SIGS
626 = tcSimplifyInfer doc tau_tvs lie_req
628 | otherwise -- UNRESTRICTED CASE, WITH TYPE SIGS
629 = do { let sig1 = head sigs
630 ; sig_lie <- newDictsAtLoc (sig_loc sig1) (sig_theta sig1)
631 ; let -- The "sig_avails" is the stuff available. We get that from
632 -- the context of the type signature, BUT ALSO the lie_avail
633 -- so that polymorphic recursion works right (see comments at end of fn)
634 local_meths = [mkMethInst sig mono_id | (_, Just sig, mono_id) <- mono_infos]
635 sig_avails = sig_lie ++ local_meths
637 -- Check that the needed dicts can be
638 -- expressed in terms of the signature ones
639 ; (forall_tvs, dict_binds) <- tcSimplifyInferCheck doc tau_tvs sig_avails lie_req
641 -- Check that signature type variables are OK
642 ; final_qtvs <- checkSigsTyVars forall_tvs sigs
644 ; returnM (final_qtvs, dict_binds, map instToId sig_lie) }
647 bndr_names = bndrNames mono_infos
648 tau_tvs = foldr (unionVarSet . tyVarsOfType . getMonoType) emptyVarSet mono_infos
649 is_mono_sig sig = null (sig_theta sig)
650 doc = ptext SLIT("type signature(s) for") <+> pprBinders bndr_names
652 mkMethInst (TcSigInfo { sig_id = poly_id, sig_tvs = tvs,
653 sig_theta = theta, sig_tau = tau, sig_loc = loc }) mono_id
654 = Method mono_id poly_id (mkTyVarTys tvs) theta tau loc
656 checkSigsTyVars :: [TcTyVar] -> [TcSigInfo] -> TcM [TcTyVar]
657 checkSigsTyVars qtvs sigs
658 = mappM check_one sigs `thenM` \ sig_tvs_s ->
660 -- Sigh. Make sure that all the tyvars in the type sigs
661 -- appear in the returned ty var list, which is what we are
662 -- going to generalise over. Reason: we occasionally get
664 -- type T a = () -> ()
667 -- Here, 'a' won't appear in qtvs, so we have to add it
669 sig_tvs = foldl extendVarSetList emptyVarSet sig_tvs_s
670 all_tvs = extendVarSetList sig_tvs qtvs
672 returnM (varSetElems all_tvs)
674 check_one (TcSigInfo {sig_id = id, sig_tvs = tvs, sig_theta = theta, sig_tau = tau})
675 = addErrCtxt (ptext SLIT("In the type signature for")
676 <+> quotes (ppr id)) $
677 addErrCtxtM (sigCtxt id tvs theta tau) $
678 do { checkSigTyVars tvs; return tvs }
681 @getTyVarsToGen@ decides what type variables to generalise over.
683 For a "restricted group" -- see the monomorphism restriction
684 for a definition -- we bind no dictionaries, and
685 remove from tyvars_to_gen any constrained type variables
687 *Don't* simplify dicts at this point, because we aren't going
688 to generalise over these dicts. By the time we do simplify them
689 we may well know more. For example (this actually came up)
691 f x = array ... xs where xs = [1,2,3,4,5]
692 We don't want to generate lots of (fromInt Int 1), (fromInt Int 2)
693 stuff. If we simplify only at the f-binding (not the xs-binding)
694 we'll know that the literals are all Ints, and we can just produce
697 Find all the type variables involved in overloading, the
698 "constrained_tyvars". These are the ones we *aren't* going to
699 generalise. We must be careful about doing this:
701 (a) If we fail to generalise a tyvar which is not actually
702 constrained, then it will never, ever get bound, and lands
703 up printed out in interface files! Notorious example:
704 instance Eq a => Eq (Foo a b) where ..
705 Here, b is not constrained, even though it looks as if it is.
706 Another, more common, example is when there's a Method inst in
707 the LIE, whose type might very well involve non-overloaded
709 [NOTE: Jan 2001: I don't understand the problem here so I'm doing
710 the simple thing instead]
712 (b) On the other hand, we mustn't generalise tyvars which are constrained,
713 because we are going to pass on out the unmodified LIE, with those
714 tyvars in it. They won't be in scope if we've generalised them.
716 So we are careful, and do a complete simplification just to find the
717 constrained tyvars. We don't use any of the results, except to
718 find which tyvars are constrained.
721 isUnRestrictedGroup :: LHsBinds Name -> [TcSigInfo] -> TcM Bool
722 isUnRestrictedGroup binds sigs
723 = do { no_MR <- doptM Opt_NoMonomorphismRestriction
724 ; return (no_MR || all_unrestricted) }
726 all_unrestricted = all (unrestricted . unLoc) (bagToList binds)
727 tysig_names = map (idName . sig_id) sigs
729 unrestricted (PatBind other _ _) = False
730 unrestricted (VarBind v _) = v `is_elem` tysig_names
731 unrestricted (FunBind v _ matches) = unrestricted_match matches
732 || unLoc v `is_elem` tysig_names
734 unrestricted_match (MatchGroup (L _ (Match [] _ _) : _) _) = False
735 -- No args => like a pattern binding
736 unrestricted_match other = True
737 -- Some args => a function binding
739 is_elem v vs = isIn "isUnResMono" v vs
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 {-# RULES (f::<type>) = g #-}
785 tcSpecSigs :: [LSig Name] -> TcM (LHsBinds TcId)
786 tcSpecSigs (L loc (SpecSig (L nm_loc name) poly_ty) : 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 (tcCheckSigma (L nm_loc (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 = VarBind (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 `snocBag` L loc spec_bind)
814 tcSpecSigs (other_sig : sigs) = tcSpecSigs sigs
815 tcSpecSigs [] = returnM emptyLHsBinds
818 %************************************************************************
820 \subsection[TcBinds-errors]{Error contexts and messages}
822 %************************************************************************
826 -- This one is called on LHS, when pat and grhss are both Name
827 -- and on RHS, when pat is TcId and grhss is still Name
828 patMonoBindsCtxt pat grhss
829 = hang (ptext SLIT("In a pattern binding:")) 4 (pprPatBind pat grhss)
831 -----------------------------------------------
833 = sep [ptext SLIT("In a SPECIALIZE pragma for a value:"),
834 nest 4 (ppr v <+> dcolon <+> ppr ty)]
836 -----------------------------------------------
837 sigContextsErr id1 name ty
838 = vcat [ptext SLIT("Mis-match between the contexts of the signatures for"),
839 nest 2 (vcat [ppr id1 <+> dcolon <+> ppr (idType id1),
840 ppr name <+> dcolon <+> ppr ty]),
841 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