2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 \section[TcBinds]{TcBinds}
7 module TcBinds ( tcBindsAndThen, tcTopBinds,
8 tcHsBootSigs, tcMonoBinds, tcSpecSigs,
11 #include "HsVersions.h"
13 import {-# SOURCE #-} TcMatches ( tcGRHSsPat, tcMatchesFun )
14 import {-# SOURCE #-} TcExpr ( tcCheckSigma, tcCheckRho )
16 import DynFlags ( DynFlag(Opt_MonomorphismRestriction) )
17 import HsSyn ( HsExpr(..), HsBind(..), LHsBinds, Sig(..),
18 LSig, Match(..), HsBindGroup(..), IPBind(..),
19 HsType(..), HsExplicitForAll(..), hsLTyVarNames, isVanillaLSig,
20 LPat, GRHSs, MatchGroup(..), emptyLHsBinds, isEmptyLHsBinds,
21 collectHsBindBinders, collectPatBinders, pprPatBind
23 import TcHsSyn ( TcId, TcDictBinds, zonkId, mkHsLet )
26 import Inst ( InstOrigin(..), newDictsAtLoc, newIPDict, instToId )
27 import TcEnv ( tcExtendIdEnv, tcExtendIdEnv2, tcExtendTyVarEnv2,
28 newLocalName, tcLookupLocalIds, pprBinders,
30 import TcUnify ( Expected(..), tcInfer, unifyTheta,
31 bleatEscapedTvs, sigCtxt )
32 import TcSimplify ( tcSimplifyInfer, tcSimplifyInferCheck, tcSimplifyRestricted,
33 tcSimplifyToDicts, tcSimplifyIPs )
34 import TcHsType ( tcHsSigType, UserTypeCtxt(..), tcAddLetBoundTyVars,
35 TcSigInfo(..), TcSigFun, lookupSig
37 import TcPat ( tcPat, PatCtxt(..) )
38 import TcSimplify ( bindInstsOfLocalFuns )
39 import TcMType ( newTyFlexiVarTy, zonkQuantifiedTyVar,
40 tcInstSigType, zonkTcTypes, zonkTcTyVar )
41 import TcType ( TcTyVar, SkolemInfo(SigSkol),
42 TcTauType, TcSigmaType,
43 mkTyVarTy, mkForAllTys, mkFunTys, tyVarsOfType,
44 mkForAllTy, isUnLiftedType, tcGetTyVar,
45 mkTyVarTys, tidyOpenTyVar )
46 import Kind ( argTypeKind )
47 import VarEnv ( TyVarEnv, emptyVarEnv, lookupVarEnv, extendVarEnv, emptyTidyEnv )
48 import TysPrim ( alphaTyVar )
49 import Id ( Id, mkLocalId, mkVanillaGlobal, mkSpecPragmaId, setInlinePragma )
50 import IdInfo ( vanillaIdInfo )
51 import Var ( idType, idName )
55 import SrcLoc ( Located(..), unLoc, noLoc, getLoc )
57 import ErrUtils ( Message )
59 import BasicTypes ( TopLevelFlag(..), RecFlag(..), isNonRec, isRec,
60 isNotTopLevel, isAlwaysActive )
61 import FiniteMap ( listToFM, lookupFM )
66 %************************************************************************
68 \subsection{Type-checking bindings}
70 %************************************************************************
72 @tcBindsAndThen@ typechecks a @HsBinds@. The "and then" part is because
73 it needs to know something about the {\em usage} of the things bound,
74 so that it can create specialisations of them. So @tcBindsAndThen@
75 takes a function which, given an extended environment, E, typechecks
76 the scope of the bindings returning a typechecked thing and (most
77 important) an LIE. It is this LIE which is then used as the basis for
78 specialising the things bound.
80 @tcBindsAndThen@ also takes a "combiner" which glues together the
81 bindings and the "thing" to make a new "thing".
83 The real work is done by @tcBindWithSigsAndThen@.
85 Recursive and non-recursive binds are handled in essentially the same
86 way: because of uniques there are no scoping issues left. The only
87 difference is that non-recursive bindings can bind primitive values.
89 Even for non-recursive binding groups we add typings for each binder
90 to the LVE for the following reason. When each individual binding is
91 checked the type of its LHS is unified with that of its RHS; and
92 type-checking the LHS of course requires that the binder is in scope.
94 At the top-level the LIE is sure to contain nothing but constant
95 dictionaries, which we resolve at the module level.
98 tcTopBinds :: [HsBindGroup Name] -> TcM (LHsBinds TcId, TcLclEnv)
99 -- Note: returning the TcLclEnv is more than we really
100 -- want. The bit we care about is the local bindings
101 -- and the free type variables thereof
103 = tc_binds_and_then TopLevel glue binds $
104 do { env <- getLclEnv
105 ; return (emptyLHsBinds, env) }
107 -- The top level bindings are flattened into a giant
108 -- implicitly-mutually-recursive MonoBinds
109 glue (HsBindGroup binds1 _ _) (binds2, env) = (binds1 `unionBags` binds2, env)
110 glue (HsIPBinds _) _ = panic "Top-level HsIpBinds"
111 -- Can't have a HsIPBinds at top level
113 tcHsBootSigs :: [HsBindGroup Name] -> TcM [Id]
114 -- A hs-boot file has only one BindGroup, and it only has type
115 -- signatures in it. The renamer checked all this
116 tcHsBootSigs [HsBindGroup binds sigs _]
117 = do { checkTc (isEmptyLHsBinds binds) badBootDeclErr
118 ; mapM (addLocM tc_boot_sig) (filter isVanillaLSig sigs) }
120 tc_boot_sig (Sig (L _ name) ty)
121 = do { sigma_ty <- tcHsSigType (FunSigCtxt name) ty
122 ; return (mkVanillaGlobal name sigma_ty vanillaIdInfo) }
123 -- Notice that we make GlobalIds, not LocalIds
125 badBootDeclErr :: Message
126 badBootDeclErr = ptext SLIT("Illegal declarations in an hs-boot file")
129 :: (HsBindGroup TcId -> thing -> thing) -- Combinator
130 -> [HsBindGroup Name]
134 tcBindsAndThen = tc_binds_and_then NotTopLevel
136 tc_binds_and_then top_lvl combiner [] do_next
138 tc_binds_and_then top_lvl combiner (group : groups) do_next
139 = tc_bind_and_then top_lvl combiner group $
140 tc_binds_and_then top_lvl combiner groups do_next
142 tc_bind_and_then top_lvl combiner (HsIPBinds binds) do_next
143 = getLIE do_next `thenM` \ (result, expr_lie) ->
144 mapAndUnzipM (wrapLocSndM tc_ip_bind) binds `thenM` \ (avail_ips, binds') ->
146 -- If the binding binds ?x = E, we must now
147 -- discharge any ?x constraints in expr_lie
148 tcSimplifyIPs avail_ips expr_lie `thenM` \ dict_binds ->
150 returnM (combiner (HsIPBinds binds') $
151 combiner (HsBindGroup dict_binds [] Recursive) result)
153 -- I wonder if we should do these one at at time
156 tc_ip_bind (IPBind ip expr)
157 = newTyFlexiVarTy argTypeKind `thenM` \ ty ->
158 newIPDict (IPBindOrigin ip) ip ty `thenM` \ (ip', ip_inst) ->
159 tcCheckRho expr ty `thenM` \ expr' ->
160 returnM (ip_inst, (IPBind ip' expr'))
162 tc_bind_and_then top_lvl combiner (HsBindGroup binds sigs is_rec) do_next
163 | isEmptyLHsBinds binds
166 = -- BRING ANY SCOPED TYPE VARIABLES INTO SCOPE
167 -- Notice that they scope over
168 -- a) the type signatures in the binding group
169 -- b) the bindings in the group
170 -- c) the scope of the binding group (the "in" part)
171 tcAddLetBoundTyVars binds $
174 TopLevel -- For the top level don't bother will all this
175 -- bindInstsOfLocalFuns stuff. All the top level
176 -- things are rec'd together anyway, so it's fine to
177 -- leave them to the tcSimplifyTop, and quite a bit faster too
178 -> tcBindWithSigs top_lvl binds sigs is_rec `thenM` \ (poly_binds, poly_ids) ->
179 tc_body poly_ids `thenM` \ (prag_binds, thing) ->
180 returnM (combiner (HsBindGroup
181 (poly_binds `unionBags` prag_binds)
186 NotTopLevel -- For nested bindings we must do the bindInstsOfLocalFuns thing.
187 | not (isRec is_rec) -- Non-recursive group
188 -> -- We want to keep non-recursive things non-recursive
189 -- so that we desugar unlifted bindings correctly
190 tcBindWithSigs top_lvl binds sigs is_rec `thenM` \ (poly_binds, poly_ids) ->
191 getLIE (tc_body poly_ids) `thenM` \ ((prag_binds, thing), lie) ->
193 -- Create specialisations of functions bound here
194 bindInstsOfLocalFuns lie poly_ids `thenM` \ lie_binds ->
197 combiner (HsBindGroup poly_binds [] NonRecursive) $
198 combiner (HsBindGroup prag_binds [] NonRecursive) $
199 combiner (HsBindGroup lie_binds [] Recursive) $
200 -- NB: the binds returned by tcSimplify and
201 -- bindInstsOfLocalFuns aren't guaranteed in
202 -- dependency order (though we could change that);
203 -- hence the Recursive marker.
207 -> -- NB: polymorphic recursion means that a function
208 -- may use an instance of itself, we must look at the LIE arising
209 -- from the function's own right hand side. Hence the getLIE
210 -- encloses the tcBindWithSigs.
213 tcBindWithSigs top_lvl binds sigs is_rec `thenM` \ (poly_binds, poly_ids) ->
214 tc_body poly_ids `thenM` \ (prag_binds, thing) ->
215 returnM (poly_ids, poly_binds `unionBags` prag_binds, thing)
216 ) `thenM` \ ((poly_ids, extra_binds, thing), lie) ->
218 bindInstsOfLocalFuns lie poly_ids `thenM` \ lie_binds ->
220 returnM (combiner (HsBindGroup
221 (extra_binds `unionBags` lie_binds)
225 tc_body poly_ids -- Type check the pragmas and "thing inside"
226 = -- Extend the environment to bind the new polymorphic Ids
227 tcExtendIdEnv poly_ids $
229 -- Build bindings and IdInfos corresponding to user pragmas
230 tcSpecSigs sigs `thenM` \ prag_binds ->
232 -- Now do whatever happens next, in the augmented envt
233 do_next `thenM` \ thing ->
235 returnM (prag_binds, thing)
239 %************************************************************************
241 \subsection{tcBindWithSigs}
243 %************************************************************************
245 @tcBindWithSigs@ deals with a single binding group. It does generalisation,
246 so all the clever stuff is in here.
248 * binder_names and mbind must define the same set of Names
250 * The Names in tc_ty_sigs must be a subset of binder_names
252 * The Ids in tc_ty_sigs don't necessarily have to have the same name
253 as the Name in the tc_ty_sig
256 tcBindWithSigs :: TopLevelFlag
260 -> TcM (LHsBinds TcId, [TcId])
261 -- The returned TcIds are guaranteed zonked
263 tcBindWithSigs top_lvl mbind sigs is_rec = do
264 { -- TYPECHECK THE SIGNATURES
265 tc_ty_sigs <- recoverM (returnM []) $
266 tcTySigs (filter isVanillaLSig sigs)
267 ; let lookup_sig = lookupSig tc_ty_sigs
269 -- SET UP THE MAIN RECOVERY; take advantage of any type sigs
270 ; recoverM (recoveryCode mbind lookup_sig) $ do
272 { traceTc (ptext SLIT("--------------------------------------------------------"))
273 ; traceTc (ptext SLIT("Bindings for") <+> ppr (collectHsBindBinders mbind))
275 -- TYPECHECK THE BINDINGS
276 ; ((mbind', mono_bind_infos), lie_req)
277 <- getLIE (tcMonoBinds mbind lookup_sig is_rec)
279 -- CHECK FOR UNLIFTED BINDINGS
280 -- These must be non-recursive etc, and are not generalised
281 -- They desugar to a case expression in the end
282 ; zonked_mono_tys <- zonkTcTypes (map getMonoType mono_bind_infos)
283 ; if any isUnLiftedType zonked_mono_tys then
284 do { -- Unlifted bindings
285 checkUnliftedBinds top_lvl is_rec mbind
287 ; let exports = zipWith mk_export mono_bind_infos zonked_mono_tys
288 mk_export (name, Nothing, mono_id) mono_ty = ([], mkLocalId name mono_ty, mono_id)
289 mk_export (name, Just sig, mono_id) mono_ty = ([], sig_id sig, mono_id)
291 ; return ( unitBag $ noLoc $ AbsBinds [] [] exports emptyNameSet mbind',
292 [poly_id | (_, poly_id, _) <- exports]) } -- Guaranteed zonked
294 else do -- The normal lifted case: GENERALISE
295 { is_unres <- isUnRestrictedGroup mbind tc_ty_sigs
296 ; (tyvars_to_gen, dict_binds, dict_ids)
297 <- setSrcSpan (getLoc (head (bagToList mbind))) $
298 -- TODO: location a bit awkward, but the mbinds have been
299 -- dependency analysed and may no longer be adjacent
300 addErrCtxt (genCtxt (bndrNames mono_bind_infos)) $
301 generalise top_lvl is_unres mono_bind_infos tc_ty_sigs lie_req
303 -- FINALISE THE QUANTIFIED TYPE VARIABLES
304 -- The quantified type variables often include meta type variables
305 -- we want to freeze them into ordinary type variables, and
306 -- default their kind (e.g. from OpenTypeKind to TypeKind)
307 ; tyvars_to_gen' <- mappM zonkQuantifiedTyVar tyvars_to_gen
309 -- BUILD THE POLYMORPHIC RESULT IDs
311 exports = map mk_export mono_bind_infos
312 poly_ids = [poly_id | (_, poly_id, _) <- exports]
313 dict_tys = map idType dict_ids
315 inlines = mkNameSet [ name
316 | L _ (InlineSig True (L _ name) _) <- sigs]
317 -- Any INLINE sig (regardless of phase control)
318 -- makes the RHS look small
319 inline_phases = listToFM [ (name, phase)
320 | L _ (InlineSig _ (L _ name) phase) <- sigs,
321 not (isAlwaysActive phase)]
322 -- Set the IdInfo field to control the inline phase
323 -- AlwaysActive is the default, so don't bother with them
324 add_inlines id = attachInlinePhase inline_phases id
326 mk_export (binder_name, mb_sig, mono_id)
328 Just sig -> (sig_tvs sig, add_inlines (sig_id sig), mono_id)
329 Nothing -> (tyvars_to_gen', add_inlines new_poly_id, mono_id)
331 new_poly_id = mkLocalId binder_name poly_ty
332 poly_ty = mkForAllTys tyvars_to_gen'
336 -- ZONK THE poly_ids, because they are used to extend the type
337 -- environment; see the invariant on TcEnv.tcExtendIdEnv
338 ; zonked_poly_ids <- mappM zonkId poly_ids
340 ; traceTc (text "binding:" <+> ppr ((dict_ids, dict_binds),
341 exports, map idType zonked_poly_ids))
345 AbsBinds tyvars_to_gen'
349 (dict_binds `unionBags` mbind'),
354 -- If typechecking the binds fails, then return with each
355 -- signature-less binder given type (forall a.a), to minimise
356 -- subsequent error messages
357 recoveryCode mbind lookup_sig
358 = do { traceTc (text "tcBindsWithSigs: error recovery" <+> ppr binder_names)
359 ; return (emptyLHsBinds, poly_ids) }
361 forall_a_a = mkForAllTy alphaTyVar (mkTyVarTy alphaTyVar)
362 binder_names = collectHsBindBinders mbind
363 poly_ids = map mk_dummy binder_names
364 mk_dummy name = case lookup_sig name of
365 Just sig -> sig_id sig -- Signature
366 Nothing -> mkLocalId name forall_a_a -- No signature
368 attachInlinePhase inline_phases bndr
369 = case lookupFM inline_phases (idName bndr) of
370 Just prag -> bndr `setInlinePragma` prag
373 -- Check that non-overloaded unlifted bindings are
376 -- c) not a multiple-binding group (more or less implied by (a))
378 checkUnliftedBinds top_lvl is_rec mbind
379 = checkTc (isNotTopLevel top_lvl)
380 (unliftedBindErr "Top-level" mbind) `thenM_`
381 checkTc (isNonRec is_rec)
382 (unliftedBindErr "Recursive" mbind) `thenM_`
383 checkTc (isSingletonBag mbind)
384 (unliftedBindErr "Multiple" mbind)
388 Polymorphic recursion
389 ~~~~~~~~~~~~~~~~~~~~~
390 The game plan for polymorphic recursion in the code above is
392 * Bind any variable for which we have a type signature
393 to an Id with a polymorphic type. Then when type-checking
394 the RHSs we'll make a full polymorphic call.
396 This fine, but if you aren't a bit careful you end up with a horrendous
397 amount of partial application and (worse) a huge space leak. For example:
399 f :: Eq a => [a] -> [a]
402 If we don't take care, after typechecking we get
404 f = /\a -> \d::Eq a -> let f' = f a d
408 Notice the the stupid construction of (f a d), which is of course
409 identical to the function we're executing. In this case, the
410 polymorphic recursion isn't being used (but that's a very common case).
413 f = /\a -> \d::Eq a -> letrec
414 fm = \ys:[a] -> ...fm...
418 This can lead to a massive space leak, from the following top-level defn
424 Now (f dEqInt) evaluates to a lambda that has f' as a free variable; but
425 f' is another thunk which evaluates to the same thing... and you end
426 up with a chain of identical values all hung onto by the CAF ff.
430 = let f' = f Int dEqInt in \ys. ...f'...
432 = let f' = let f' = f Int dEqInt in \ys. ...f'...
436 Solution: when typechecking the RHSs we always have in hand the
437 *monomorphic* Ids for each binding. So we just need to make sure that
438 if (Method f a d) shows up in the constraints emerging from (...f...)
439 we just use the monomorphic Id. We achieve this by adding monomorphic Ids
440 to the "givens" when simplifying constraints. That's what the "lies_avail"
444 %************************************************************************
446 \subsection{tcMonoBind}
448 %************************************************************************
450 @tcMonoBinds@ deals with a single @MonoBind@.
451 The signatures have been dealt with already.
454 tcMonoBinds :: LHsBinds Name
455 -> TcSigFun -> RecFlag
456 -> TcM (LHsBinds TcId, [MonoBindInfo])
458 tcMonoBinds binds lookup_sig is_rec
459 = do { tc_binds <- mapBagM (wrapLocM (tcLhs lookup_sig)) binds
461 -- Bring (a) the scoped type variables, and (b) the Ids, into scope for the RHSs
462 -- For (a) it's ok to bring them all into scope at once, even
463 -- though each type sig should scope only over its own RHS,
464 -- because the renamer has sorted all that out.
465 ; let mono_info = getMonoBindInfo tc_binds
466 rhs_tvs = [ (name, mkTyVarTy tv)
467 | (_, Just sig, _) <- mono_info,
468 (name, tv) <- sig_scoped sig `zip` sig_tvs sig ]
469 rhs_id_env = map mk mono_info -- A binding for each term variable
471 ; binds' <- tcExtendTyVarEnv2 rhs_tvs $
472 tcExtendIdEnv2 rhs_id_env $
473 traceTc (text "tcMonoBinds" <+> vcat [ppr n <+> ppr id <+> ppr (idType id) | (n,id) <- rhs_id_env]) `thenM_`
474 mapBagM (wrapLocM tcRhs) tc_binds
475 ; return (binds', mono_info) }
477 mk (name, Just sig, _) = (name, sig_id sig) -- Use the type sig if there is one
478 mk (name, Nothing, mono_id) = (name, mono_id) -- otherwise use a monomorphic version
480 ------------------------
481 -- tcLhs typechecks the LHS of the bindings, to construct the environment in which
482 -- we typecheck the RHSs. Basically what we are doing is this: for each binder:
483 -- if there's a signature for it, use the instantiated signature type
484 -- otherwise invent a type variable
485 -- You see that quite directly in the FunBind case.
487 -- But there's a complication for pattern bindings:
488 -- data T = MkT (forall a. a->a)
490 -- Here we can guess a type variable for the entire LHS (which will be refined to T)
491 -- but we want to get (f::forall a. a->a) as the RHS environment.
492 -- The simplest way to do this is to typecheck the pattern, and then look up the
493 -- bound mono-ids. Then we want to retain the typechecked pattern to avoid re-doing
494 -- it; hence the TcMonoBind data type in which the LHS is done but the RHS isn't
496 data TcMonoBind -- Half completed; LHS done, RHS not done
497 = TcFunBind MonoBindInfo (Located TcId) Bool (MatchGroup Name)
498 | TcPatBind [MonoBindInfo] (LPat TcId) (GRHSs Name) TcSigmaType
500 type MonoBindInfo = (Name, Maybe TcSigInfo, TcId)
501 -- Type signature (if any), and
502 -- the monomorphic bound things
504 bndrNames :: [MonoBindInfo] -> [Name]
505 bndrNames mbi = [n | (n,_,_) <- mbi]
507 getMonoType :: MonoBindInfo -> TcTauType
508 getMonoType (_,_,mono_id) = idType mono_id
510 tcLhs :: TcSigFun -> HsBind Name -> TcM TcMonoBind
511 tcLhs lookup_sig (FunBind (L nm_loc name) inf matches)
512 = do { let mb_sig = lookup_sig name
513 ; mono_name <- newLocalName name
514 ; mono_ty <- mk_mono_ty mb_sig
515 ; let mono_id = mkLocalId mono_name mono_ty
516 ; return (TcFunBind (name, mb_sig, mono_id) (L nm_loc mono_id) inf matches) }
518 mk_mono_ty (Just sig) = return (sig_tau sig)
519 mk_mono_ty Nothing = newTyFlexiVarTy argTypeKind
521 tcLhs lookup_sig bind@(PatBind pat grhss _)
522 = do { let tc_pat exp_ty = tcPat (LetPat lookup_sig) pat exp_ty lookup_infos
523 ; ((pat', ex_tvs, infos), pat_ty)
524 <- addErrCtxt (patMonoBindsCtxt pat grhss)
527 -- Don't know how to deal with pattern-bound existentials yet
528 ; checkTc (null ex_tvs) (existentialExplode bind)
530 ; return (TcPatBind infos pat' grhss pat_ty) }
532 names = collectPatBinders pat
534 -- After typechecking the pattern, look up the binder
535 -- names, which the pattern has brought into scope.
536 lookup_infos :: TcM [MonoBindInfo]
537 lookup_infos = do { mono_ids <- tcLookupLocalIds names
538 ; return [ (name, lookup_sig name, mono_id)
539 | (name, mono_id) <- names `zip` mono_ids] }
542 tcRhs :: TcMonoBind -> TcM (HsBind TcId)
543 tcRhs (TcFunBind info fun'@(L _ mono_id) inf matches)
544 = do { matches' <- tcMatchesFun (idName mono_id) matches
545 (Check (idType mono_id))
546 ; return (FunBind fun' inf matches') }
548 tcRhs bind@(TcPatBind _ pat' grhss pat_ty)
549 = do { grhss' <- addErrCtxt (patMonoBindsCtxt pat' grhss) $
550 tcGRHSsPat grhss (Check pat_ty)
551 ; return (PatBind pat' grhss' pat_ty) }
554 ---------------------
555 getMonoBindInfo :: Bag (Located TcMonoBind) -> [MonoBindInfo]
556 getMonoBindInfo tc_binds
557 = foldrBag (get_info . unLoc) [] tc_binds
559 get_info (TcFunBind info _ _ _) rest = info : rest
560 get_info (TcPatBind infos _ _ _) rest = infos ++ rest
564 %************************************************************************
566 \subsection{getTyVarsToGen}
568 %************************************************************************
570 Type signatures are tricky. See Note [Signature skolems] in TcType
573 tcTySigs :: [LSig Name] -> TcM [TcSigInfo]
574 -- The trick here is that all the signatures should have the same
575 -- context, and we want to share type variables for that context, so that
576 -- all the right hand sides agree a common vocabulary for their type
578 tcTySigs [] = return []
581 = do { (tc_sig1 : tc_sigs) <- mappM tcTySig sigs
582 ; mapM (check_ctxt tc_sig1) tc_sigs
583 ; return (tc_sig1 : tc_sigs) }
585 -- Check tha all the signature contexts are the same
586 -- The type signatures on a mutually-recursive group of definitions
587 -- must all have the same context (or none).
589 -- We unify them because, with polymorphic recursion, their types
590 -- might not otherwise be related. This is a rather subtle issue.
591 check_ctxt :: TcSigInfo -> TcSigInfo -> TcM ()
592 check_ctxt sig1@(TcSigInfo { sig_theta = theta1 }) sig@(TcSigInfo { sig_theta = theta })
593 = setSrcSpan (instLocSrcSpan (sig_loc sig)) $
594 addErrCtxt (sigContextsCtxt sig1 sig) $
595 unifyTheta theta1 theta
598 tcTySig :: LSig Name -> TcM TcSigInfo
599 tcTySig (L span (Sig (L _ name) ty))
601 do { sigma_ty <- tcHsSigType (FunSigCtxt name) ty
602 ; (tvs, theta, tau) <- tcInstSigType name scoped_names sigma_ty
603 ; loc <- getInstLoc (SigOrigin (SigSkol name))
604 ; return (TcSigInfo { sig_id = mkLocalId name sigma_ty,
605 sig_tvs = tvs, sig_theta = theta, sig_tau = tau,
606 sig_scoped = scoped_names, sig_loc = loc }) }
608 -- The scoped names are the ones explicitly mentioned
609 -- in the HsForAll. (There may be more in sigma_ty, because
610 -- of nested type synonyms. See Note [Scoped] with TcSigInfo.)
611 scoped_names = case ty of
612 L _ (HsForAllTy Explicit tvs _ _) -> hsLTyVarNames tvs
617 generalise :: TopLevelFlag -> Bool -> [MonoBindInfo] -> [TcSigInfo] -> [Inst]
618 -> TcM ([TcTyVar], TcDictBinds, [TcId])
619 generalise top_lvl is_unrestricted mono_infos sigs lie_req
620 | not is_unrestricted -- RESTRICTED CASE
621 = -- Check signature contexts are empty
622 do { checkTc (all is_mono_sig sigs)
623 (restrictedBindCtxtErr bndr_names)
625 -- Now simplify with exactly that set of tyvars
626 -- We have to squash those Methods
627 ; (qtvs, binds) <- tcSimplifyRestricted doc top_lvl bndr_names
630 -- Check that signature type variables are OK
631 ; final_qtvs <- checkSigsTyVars qtvs sigs
633 ; return (final_qtvs, binds, []) }
635 | null sigs -- UNRESTRICTED CASE, NO TYPE SIGS
636 = tcSimplifyInfer doc tau_tvs lie_req
638 | otherwise -- UNRESTRICTED CASE, WITH TYPE SIGS
639 = do { let sig1 = head sigs
640 ; sig_lie <- newDictsAtLoc (sig_loc sig1) (sig_theta sig1)
641 ; let -- The "sig_avails" is the stuff available. We get that from
642 -- the context of the type signature, BUT ALSO the lie_avail
643 -- so that polymorphic recursion works right (see comments at end of fn)
644 local_meths = [mkMethInst sig mono_id | (_, Just sig, mono_id) <- mono_infos]
645 sig_avails = sig_lie ++ local_meths
647 -- Check that the needed dicts can be
648 -- expressed in terms of the signature ones
649 ; (forall_tvs, dict_binds) <- tcSimplifyInferCheck doc tau_tvs sig_avails lie_req
651 -- Check that signature type variables are OK
652 ; final_qtvs <- checkSigsTyVars forall_tvs sigs
654 ; returnM (final_qtvs, dict_binds, map instToId sig_lie) }
657 bndr_names = bndrNames mono_infos
658 tau_tvs = foldr (unionVarSet . tyVarsOfType . getMonoType) emptyVarSet mono_infos
659 is_mono_sig sig = null (sig_theta sig)
660 doc = ptext SLIT("type signature(s) for") <+> pprBinders bndr_names
662 mkMethInst (TcSigInfo { sig_id = poly_id, sig_tvs = tvs,
663 sig_theta = theta, sig_tau = tau, sig_loc = loc }) mono_id
664 = Method mono_id poly_id (mkTyVarTys tvs) theta tau loc
666 checkSigsTyVars :: [TcTyVar] -> [TcSigInfo] -> TcM [TcTyVar]
667 checkSigsTyVars qtvs sigs
668 = do { gbl_tvs <- tcGetGlobalTyVars
669 ; sig_tvs_s <- mappM (check_sig gbl_tvs) sigs
671 ; let -- Sigh. Make sure that all the tyvars in the type sigs
672 -- appear in the returned ty var list, which is what we are
673 -- going to generalise over. Reason: we occasionally get
675 -- type T a = () -> ()
678 -- Here, 'a' won't appear in qtvs, so we have to add it
679 sig_tvs = foldl extendVarSetList emptyVarSet sig_tvs_s
680 all_tvs = varSetElems (extendVarSetList sig_tvs qtvs)
683 check_sig gbl_tvs (TcSigInfo {sig_id = id, sig_tvs = tvs,
684 sig_theta = theta, sig_tau = tau})
685 = addErrCtxt (ptext SLIT("In the type signature for") <+> quotes (ppr id)) $
686 addErrCtxtM (sigCtxt id tvs theta tau) $
687 do { tvs' <- checkDistinctTyVars tvs
688 ; ifM (any (`elemVarSet` gbl_tvs) tvs')
689 (bleatEscapedTvs gbl_tvs tvs tvs')
692 checkDistinctTyVars :: [TcTyVar] -> TcM [TcTyVar]
693 -- (checkDistinctTyVars tvs) checks that the tvs from one type signature
694 -- are still all type variables, and all distinct from each other.
695 -- It returns a zonked set of type variables.
696 -- For example, if the type sig is
697 -- f :: forall a b. a -> b -> b
698 -- we want to check that 'a' and 'b' haven't
699 -- (a) been unified with a non-tyvar type
700 -- (b) been unified with each other (all distinct)
702 checkDistinctTyVars sig_tvs
703 = do { zonked_tvs <- mapM zonk_one sig_tvs
704 ; foldlM check_dup emptyVarEnv (sig_tvs `zip` zonked_tvs)
705 ; return zonked_tvs }
707 zonk_one sig_tv = do { ty <- zonkTcTyVar sig_tv
708 ; return (tcGetTyVar "checkDistinctTyVars" ty) }
709 -- 'ty' is bound to be a type variable, because SigSkolTvs
710 -- can only be unified with type variables
712 check_dup :: TyVarEnv TcTyVar -> (TcTyVar, TcTyVar) -> TcM (TyVarEnv TcTyVar)
713 -- The TyVarEnv maps each zonked type variable back to its
714 -- corresponding user-written signature type variable
715 check_dup acc (sig_tv, zonked_tv)
716 = case lookupVarEnv acc zonked_tv of
717 Just sig_tv' -> bomb_out sig_tv sig_tv'
719 Nothing -> return (extendVarEnv acc zonked_tv sig_tv)
721 bomb_out sig_tv1 sig_tv2
722 = failWithTc (ptext SLIT("Quantified type variable") <+> quotes (ppr tidy_tv1)
723 <+> ptext SLIT("is unified with another quantified type variable")
724 <+> quotes (ppr tidy_tv2))
726 (env1, tidy_tv1) = tidyOpenTyVar emptyTidyEnv sig_tv1
727 (_env2, tidy_tv2) = tidyOpenTyVar env1 sig_tv2
731 @getTyVarsToGen@ decides what type variables to generalise over.
733 For a "restricted group" -- see the monomorphism restriction
734 for a definition -- we bind no dictionaries, and
735 remove from tyvars_to_gen any constrained type variables
737 *Don't* simplify dicts at this point, because we aren't going
738 to generalise over these dicts. By the time we do simplify them
739 we may well know more. For example (this actually came up)
741 f x = array ... xs where xs = [1,2,3,4,5]
742 We don't want to generate lots of (fromInt Int 1), (fromInt Int 2)
743 stuff. If we simplify only at the f-binding (not the xs-binding)
744 we'll know that the literals are all Ints, and we can just produce
747 Find all the type variables involved in overloading, the
748 "constrained_tyvars". These are the ones we *aren't* going to
749 generalise. We must be careful about doing this:
751 (a) If we fail to generalise a tyvar which is not actually
752 constrained, then it will never, ever get bound, and lands
753 up printed out in interface files! Notorious example:
754 instance Eq a => Eq (Foo a b) where ..
755 Here, b is not constrained, even though it looks as if it is.
756 Another, more common, example is when there's a Method inst in
757 the LIE, whose type might very well involve non-overloaded
759 [NOTE: Jan 2001: I don't understand the problem here so I'm doing
760 the simple thing instead]
762 (b) On the other hand, we mustn't generalise tyvars which are constrained,
763 because we are going to pass on out the unmodified LIE, with those
764 tyvars in it. They won't be in scope if we've generalised them.
766 So we are careful, and do a complete simplification just to find the
767 constrained tyvars. We don't use any of the results, except to
768 find which tyvars are constrained.
771 isUnRestrictedGroup :: LHsBinds Name -> [TcSigInfo] -> TcM Bool
772 isUnRestrictedGroup binds sigs
773 = do { mono_restriction <- doptM Opt_MonomorphismRestriction
774 ; return (not mono_restriction || all_unrestricted) }
776 all_unrestricted = all (unrestricted . unLoc) (bagToList binds)
777 tysig_names = map (idName . sig_id) sigs
779 unrestricted (PatBind other _ _) = False
780 unrestricted (VarBind v _) = v `is_elem` tysig_names
781 unrestricted (FunBind v _ matches) = unrestricted_match matches
782 || unLoc v `is_elem` tysig_names
784 unrestricted_match (MatchGroup (L _ (Match [] _ _) : _) _) = False
785 -- No args => like a pattern binding
786 unrestricted_match other = True
787 -- Some args => a function binding
789 is_elem v vs = isIn "isUnResMono" v vs
793 %************************************************************************
795 \subsection{SPECIALIZE pragmas}
797 %************************************************************************
799 @tcSpecSigs@ munches up the specialisation "signatures" that arise through *user*
800 pragmas. It is convenient for them to appear in the @[RenamedSig]@
801 part of a binding because then the same machinery can be used for
802 moving them into place as is done for type signatures.
807 f :: Ord a => [a] -> b -> b
808 {-# SPECIALIZE f :: [Int] -> b -> b #-}
811 For this we generate:
813 f* = /\ b -> let d1 = ...
817 where f* is a SpecPragmaId. The **sole** purpose of SpecPragmaIds is to
818 retain a right-hand-side that the simplifier will otherwise discard as
819 dead code... the simplifier has a flag that tells it not to discard
820 SpecPragmaId bindings.
822 In this case the f* retains a call-instance of the overloaded
823 function, f, (including appropriate dictionaries) so that the
824 specialiser will subsequently discover that there's a call of @f@ at
825 Int, and will create a specialisation for @f@. After that, the
826 binding for @f*@ can be discarded.
828 We used to have a form
829 {-# SPECIALISE f :: <type> = g #-}
830 which promised that g implemented f at <type>, but we do that with
832 {-# RULES (f::<type>) = g #-}
835 tcSpecSigs :: [LSig Name] -> TcM (LHsBinds TcId)
836 tcSpecSigs (L loc (SpecSig (L nm_loc name) poly_ty) : sigs)
837 = -- SPECIALISE f :: forall b. theta => tau = g
839 addErrCtxt (valSpecSigCtxt name poly_ty) $
841 -- Get and instantiate its alleged specialised type
842 tcHsSigType (FunSigCtxt name) poly_ty `thenM` \ sig_ty ->
844 -- Check that f has a more general type, and build a RHS for
845 -- the spec-pragma-id at the same time
846 getLIE (tcCheckSigma (L nm_loc (HsVar name)) sig_ty) `thenM` \ (spec_expr, spec_lie) ->
848 -- Squeeze out any Methods (see comments with tcSimplifyToDicts)
849 tcSimplifyToDicts spec_lie `thenM` \ spec_binds ->
851 -- Just specialise "f" by building a SpecPragmaId binding
852 -- It is the thing that makes sure we don't prematurely
853 -- dead-code-eliminate the binding we are really interested in.
854 newLocalName name `thenM` \ spec_name ->
856 spec_bind = VarBind (mkSpecPragmaId spec_name sig_ty)
857 (mkHsLet spec_binds spec_expr)
860 -- Do the rest and combine
861 tcSpecSigs sigs `thenM` \ binds_rest ->
862 returnM (binds_rest `snocBag` L loc spec_bind)
864 tcSpecSigs (other_sig : sigs) = tcSpecSigs sigs
865 tcSpecSigs [] = returnM emptyLHsBinds
868 %************************************************************************
870 \subsection[TcBinds-errors]{Error contexts and messages}
872 %************************************************************************
876 -- This one is called on LHS, when pat and grhss are both Name
877 -- and on RHS, when pat is TcId and grhss is still Name
878 patMonoBindsCtxt pat grhss
879 = hang (ptext SLIT("In a pattern binding:")) 4 (pprPatBind pat grhss)
881 -----------------------------------------------
883 = sep [ptext SLIT("In a SPECIALIZE pragma for a value:"),
884 nest 4 (ppr v <+> dcolon <+> ppr ty)]
886 -----------------------------------------------
887 sigContextsCtxt sig1 sig2
888 = vcat [ptext SLIT("When matching the contexts of the signatures for"),
889 nest 2 (vcat [ppr id1 <+> dcolon <+> ppr (idType id1),
890 ppr id2 <+> dcolon <+> ppr (idType id2)]),
891 ptext SLIT("The signature contexts in a mutually recursive group should all be identical")]
897 -----------------------------------------------
898 unliftedBindErr flavour mbind
899 = hang (text flavour <+> ptext SLIT("bindings for unlifted types aren't allowed:"))
902 -----------------------------------------------
903 existentialExplode mbinds
904 = hang (vcat [text "My brain just exploded.",
905 text "I can't handle pattern bindings for existentially-quantified constructors.",
906 text "In the binding group"])
909 -----------------------------------------------
910 restrictedBindCtxtErr binder_names
911 = hang (ptext SLIT("Illegal overloaded type signature(s)"))
912 4 (vcat [ptext SLIT("in a binding group for") <+> pprBinders binder_names,
913 ptext SLIT("that falls under the monomorphism restriction")])
916 = ptext SLIT("When generalising the type(s) for") <+> pprBinders binder_names