X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcBinds.lhs;h=38f4306e06a751819ab122ff31f83820bb20a8a8;hb=21044c2db566270297baef26c0a8d9228e66af7c;hp=07a0a942f331882342483e1d31ebbda3045b45ce;hpb=1bade0c9060d3aec4fd4590803d411d54f0ea927;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcBinds.lhs b/ghc/compiler/typecheck/TcBinds.lhs index 07a0a94..38f4306 100644 --- a/ghc/compiler/typecheck/TcBinds.lhs +++ b/ghc/compiler/typecheck/TcBinds.lhs @@ -4,51 +4,68 @@ \section[TcBinds]{TcBinds} \begin{code} -module TcBinds ( tcBindsAndThen, tcTopBinds, tcMonoBinds, tcSpecSigs ) where +module TcBinds ( tcLocalBinds, tcTopBinds, + tcHsBootSigs, tcMonoBinds, + TcPragFun, tcSpecPrag, tcPrags, mkPragFun, + TcSigInfo(..), + badBootDeclErr ) where #include "HsVersions.h" import {-# SOURCE #-} TcMatches ( tcGRHSsPat, tcMatchesFun ) -import {-# SOURCE #-} TcExpr ( tcCheckSigma, tcCheckRho ) - -import CmdLineOpts ( DynFlag(Opt_NoMonomorphismRestriction) ) -import HsSyn ( HsExpr(..), HsBinds(..), MonoBinds(..), Sig(..), - Match(..), mkMonoBind, - collectMonoBinders, andMonoBinds, - collectSigTysFromMonoBinds +import {-# SOURCE #-} TcExpr ( tcMonoExpr ) + +import DynFlags ( DynFlag(Opt_MonomorphismRestriction, Opt_GlasgowExts) ) +import HsSyn ( HsExpr(..), HsBind(..), LHsBinds, LHsBind, Sig(..), + HsLocalBinds(..), HsValBinds(..), HsIPBinds(..), + LSig, Match(..), IPBind(..), Prag(..), + HsType(..), LHsType, HsExplicitForAll(..), hsLTyVarNames, + isVanillaLSig, sigName, placeHolderNames, isPragLSig, + LPat, GRHSs, MatchGroup(..), pprLHsBinds, mkHsCoerce, + collectHsBindBinders, collectPatBinders, pprPatBind ) -import RnHsSyn ( RenamedHsBinds, RenamedSig, RenamedMonoBinds ) -import TcHsSyn ( TcHsBinds, TcMonoBinds, TcId, zonkId, mkHsLet ) +import TcHsSyn ( zonkId ) import TcRnMonad -import Inst ( InstOrigin(..), newDicts, newIPDict, instToId ) -import TcEnv ( tcExtendLocalValEnv, tcExtendLocalValEnv2, newLocalName ) -import TcUnify ( Expected(..), newHole, unifyTauTyLists, checkSigTyVarsWrt, sigCtxt ) -import TcSimplify ( tcSimplifyInfer, tcSimplifyInferCheck, tcSimplifyRestricted, - tcSimplifyToDicts, tcSimplifyIPs ) -import TcHsType ( tcHsSigType, UserTypeCtxt(..), TcSigInfo(..), - tcTySig, maybeSig, tcSigPolyId, tcSigMonoId, tcAddScopedTyVars - ) -import TcPat ( tcPat, tcSubPat, tcMonoPatBndr ) +import Inst ( newDictsAtLoc, newIPDict, instToId ) +import TcEnv ( tcExtendIdEnv, tcExtendIdEnv2, tcExtendTyVarEnv2, + pprBinders, tcLookupLocalId_maybe, tcLookupId, + tcGetGlobalTyVars ) +import TcUnify ( tcInfer, tcSubExp, unifyTheta, + bleatEscapedTvs, sigCtxt ) +import TcSimplify ( tcSimplifyInfer, tcSimplifyInferCheck, + tcSimplifyRestricted, tcSimplifyIPs ) +import TcHsType ( tcHsSigType, UserTypeCtxt(..) ) +import TcPat ( tcPat, PatCtxt(..) ) import TcSimplify ( bindInstsOfLocalFuns ) -import TcMType ( newTyVar, newTyVarTy, zonkTcTyVarToTyVar ) -import TcType ( TcTyVar, mkTyVarTy, mkForAllTys, mkFunTys, tyVarsOfType, - mkPredTy, mkForAllTy, isUnLiftedType, - unliftedTypeKind, liftedTypeKind, openTypeKind, eqKind - ) - -import CoreFVs ( idFreeTyVars ) -import Id ( mkLocalId, mkSpecPragmaId, setInlinePragma ) -import Var ( idType, idName ) -import Name ( Name, getSrcLoc ) +import TcMType ( newFlexiTyVarTy, zonkQuantifiedTyVar, zonkSigTyVar, + tcInstSigTyVars, tcInstSkolTyVars, tcInstType, + zonkTcType, zonkTcTypes, zonkTcTyVars ) +import TcType ( TcType, TcTyVar, TcThetaType, + SkolemInfo(SigSkol), UserTypeCtxt(FunSigCtxt), + TcTauType, TcSigmaType, isUnboxedTupleType, + mkTyVarTy, mkForAllTys, mkFunTys, exactTyVarsOfType, + mkForAllTy, isUnLiftedType, tcGetTyVar, + mkTyVarTys, tidyOpenTyVar ) +import Kind ( argTypeKind ) +import VarEnv ( TyVarEnv, emptyVarEnv, lookupVarEnv, extendVarEnv ) +import TysWiredIn ( unitTy ) +import TysPrim ( alphaTyVar ) +import Id ( Id, mkLocalId, mkVanillaGlobal ) +import IdInfo ( vanillaIdInfo ) +import Var ( TyVar, idType, idName ) +import Name ( Name ) import NameSet -import Var ( tyVarKind ) +import NameEnv import VarSet +import SrcLoc ( Located(..), unLoc, getLoc ) import Bag -import Util ( isIn, equalLength ) -import BasicTypes ( TopLevelFlag(..), RecFlag(..), isNonRec, isRec, - isNotTopLevel, isAlwaysActive ) -import FiniteMap ( listToFM, lookupFM ) +import ErrUtils ( Message ) +import Digraph ( SCC(..), stronglyConnComp ) +import Maybes ( fromJust, isJust, isNothing, orElse ) +import Util ( singleton ) +import BasicTypes ( TopLevelFlag(..), isTopLevel, isNotTopLevel, + RecFlag(..), isNonRec, InlineSpec, defaultInlineSpec ) import Outputable \end{code} @@ -85,470 +102,715 @@ At the top-level the LIE is sure to contain nothing but constant dictionaries, which we resolve at the module level. \begin{code} -tcTopBinds :: RenamedHsBinds -> TcM (TcMonoBinds, TcLclEnv) +tcTopBinds :: HsValBinds Name -> TcM (LHsBinds TcId, TcLclEnv) -- Note: returning the TcLclEnv is more than we really -- want. The bit we care about is the local bindings -- and the free type variables thereof tcTopBinds binds - = tc_binds_and_then TopLevel glue binds $ - getLclEnv `thenM` \ env -> - returnM (EmptyMonoBinds, env) - where + = do { (ValBindsOut prs _, env) <- tcValBinds TopLevel binds getLclEnv + ; return (foldr (unionBags . snd) emptyBag prs, env) } -- The top level bindings are flattened into a giant - -- implicitly-mutually-recursive MonoBinds - glue binds1 (binds2, env) = (flatten binds1 `AndMonoBinds` binds2, env) - flatten EmptyBinds = EmptyMonoBinds - flatten (b1 `ThenBinds` b2) = flatten b1 `AndMonoBinds` flatten b2 - flatten (MonoBind b _ _) = b - -- Can't have a IPBinds at top level - + -- implicitly-mutually-recursive LHsBinds + +tcHsBootSigs :: HsValBinds Name -> TcM [Id] +-- A hs-boot file has only one BindGroup, and it only has type +-- signatures in it. The renamer checked all this +tcHsBootSigs (ValBindsOut binds sigs) + = do { checkTc (null binds) badBootDeclErr + ; mapM (addLocM tc_boot_sig) (filter isVanillaLSig sigs) } + where + tc_boot_sig (TypeSig (L _ name) ty) + = do { sigma_ty <- tcHsSigType (FunSigCtxt name) ty + ; return (mkVanillaGlobal name sigma_ty vanillaIdInfo) } + -- Notice that we make GlobalIds, not LocalIds +tcHsBootSigs groups = pprPanic "tcHsBootSigs" (ppr groups) -tcBindsAndThen - :: (TcHsBinds -> thing -> thing) -- Combinator - -> RenamedHsBinds - -> TcM thing - -> TcM thing +badBootDeclErr :: Message +badBootDeclErr = ptext SLIT("Illegal declarations in an hs-boot file") -tcBindsAndThen = tc_binds_and_then NotTopLevel +------------------------ +tcLocalBinds :: HsLocalBinds Name -> TcM thing + -> TcM (HsLocalBinds TcId, thing) -tc_binds_and_then top_lvl combiner EmptyBinds do_next - = do_next -tc_binds_and_then top_lvl combiner (MonoBind EmptyMonoBinds sigs is_rec) do_next - = do_next +tcLocalBinds EmptyLocalBinds thing_inside + = do { thing <- thing_inside + ; return (EmptyLocalBinds, thing) } -tc_binds_and_then top_lvl combiner (ThenBinds b1 b2) do_next - = tc_binds_and_then top_lvl combiner b1 $ - tc_binds_and_then top_lvl combiner b2 $ - do_next +tcLocalBinds (HsValBinds binds) thing_inside + = do { (binds', thing) <- tcValBinds NotTopLevel binds thing_inside + ; return (HsValBinds binds', thing) } -tc_binds_and_then top_lvl combiner (IPBinds binds) do_next - = getLIE do_next `thenM` \ (result, expr_lie) -> - mapAndUnzipM tc_ip_bind binds `thenM` \ (avail_ips, binds') -> +tcLocalBinds (HsIPBinds (IPBinds ip_binds _)) thing_inside + = do { (thing, lie) <- getLIE thing_inside + ; (avail_ips, ip_binds') <- mapAndUnzipM (wrapLocSndM tc_ip_bind) ip_binds -- If the binding binds ?x = E, we must now -- discharge any ?x constraints in expr_lie - tcSimplifyIPs avail_ips expr_lie `thenM` \ dict_binds -> - - returnM (combiner (IPBinds binds') $ - combiner (mkMonoBind Recursive dict_binds) result) + ; dict_binds <- tcSimplifyIPs avail_ips lie + ; return (HsIPBinds (IPBinds ip_binds' dict_binds), thing) } where -- I wonder if we should do these one at at time -- Consider ?x = 4 -- ?y = ?x + 1 - tc_ip_bind (ip, expr) - = newTyVarTy openTypeKind `thenM` \ ty -> - getSrcLocM `thenM` \ loc -> - newIPDict (IPBind ip) ip ty `thenM` \ (ip', ip_inst) -> - tcCheckRho expr ty `thenM` \ expr' -> - returnM (ip_inst, (ip', expr')) - -tc_binds_and_then top_lvl combiner (MonoBind bind sigs is_rec) do_next - = -- BRING ANY SCOPED TYPE VARIABLES INTO SCOPE - -- Notice that they scope over - -- a) the type signatures in the binding group - -- b) the bindings in the group - -- c) the scope of the binding group (the "in" part) - tcAddScopedTyVars (collectSigTysFromMonoBinds bind) $ - - tcBindWithSigs top_lvl bind sigs is_rec `thenM` \ (poly_binds, poly_ids) -> - - case top_lvl of - TopLevel -- For the top level don't bother will all this - -- bindInstsOfLocalFuns stuff. All the top level - -- things are rec'd together anyway, so it's fine to - -- leave them to the tcSimplifyTop, and quite a bit faster too - -- - -- Subtle (and ugly) point: furthermore at top level we - -- return the TcLclEnv, which contains the LIE var; we - -- don't want to return the wrong one! - -> tc_body poly_ids `thenM` \ (prag_binds, thing) -> - returnM (combiner (mkMonoBind Recursive (poly_binds `andMonoBinds` prag_binds)) - thing) - - NotTopLevel -- For nested bindings we must do teh bindInstsOfLocalFuns thing - -> getLIE (tc_body poly_ids) `thenM` \ ((prag_binds, thing), lie) -> - - -- Create specialisations of functions bound here - bindInstsOfLocalFuns lie poly_ids `thenM` \ lie_binds -> - - -- We want to keep non-recursive things non-recursive - -- so that we desugar unlifted bindings correctly - if isRec is_rec then - returnM ( - combiner (mkMonoBind Recursive ( - poly_binds `andMonoBinds` - lie_binds `andMonoBinds` - prag_binds)) thing - ) - else - returnM ( - combiner (mkMonoBind NonRecursive poly_binds) $ - combiner (mkMonoBind NonRecursive prag_binds) $ - combiner (mkMonoBind Recursive lie_binds) $ - -- NB: the binds returned by tcSimplify and bindInstsOfLocalFuns - -- aren't guaranteed in dependency order (though we could change - -- that); hence the Recursive marker. - thing) + tc_ip_bind (IPBind ip expr) + = newFlexiTyVarTy argTypeKind `thenM` \ ty -> + newIPDict (IPBindOrigin ip) ip ty `thenM` \ (ip', ip_inst) -> + tcMonoExpr expr ty `thenM` \ expr' -> + returnM (ip_inst, (IPBind ip' expr')) + +------------------------ +tcValBinds :: TopLevelFlag + -> HsValBinds Name -> TcM thing + -> TcM (HsValBinds TcId, thing) + +tcValBinds top_lvl (ValBindsIn binds sigs) thing_inside + = pprPanic "tcValBinds" (ppr binds) + +tcValBinds top_lvl (ValBindsOut binds sigs) thing_inside + = do { -- Typecheck the signature + ; let { prag_fn = mkPragFun sigs + ; ty_sigs = filter isVanillaLSig sigs + ; sig_fn = mkSigFun ty_sigs } + + ; poly_ids <- mapM tcTySig ty_sigs + + -- Extend the envt right away with all + -- the Ids declared with type signatures + ; (binds', thing) <- tcExtendIdEnv poly_ids $ + tc_val_binds top_lvl sig_fn prag_fn + binds thing_inside + + ; return (ValBindsOut binds' sigs, thing) } + +------------------------ +tc_val_binds :: TopLevelFlag -> TcSigFun -> TcPragFun + -> [(RecFlag, LHsBinds Name)] -> TcM thing + -> TcM ([(RecFlag, LHsBinds TcId)], thing) +-- Typecheck a whole lot of value bindings, +-- one strongly-connected component at a time + +tc_val_binds top_lvl sig_fn prag_fn [] thing_inside + = do { thing <- thing_inside + ; return ([], thing) } + +tc_val_binds top_lvl sig_fn prag_fn (group : groups) thing_inside + = do { (group', (groups', thing)) + <- tc_group top_lvl sig_fn prag_fn group $ + tc_val_binds top_lvl sig_fn prag_fn groups thing_inside + ; return (group' ++ groups', thing) } + +------------------------ +tc_group :: TopLevelFlag -> TcSigFun -> TcPragFun + -> (RecFlag, LHsBinds Name) -> TcM thing + -> TcM ([(RecFlag, LHsBinds TcId)], thing) + +-- Typecheck one strongly-connected component of the original program. +-- We get a list of groups back, because there may +-- be specialisations etc as well + +tc_group top_lvl sig_fn prag_fn (NonRecursive, binds) thing_inside + = -- A single non-recursive binding + -- We want to keep non-recursive things non-recursive + -- so that we desugar unlifted bindings correctly + do { (binds, thing) <- tcPolyBinds top_lvl NonRecursive NonRecursive + sig_fn prag_fn binds thing_inside + ; return ([(NonRecursive, b) | b <- binds], thing) } + +tc_group top_lvl sig_fn prag_fn (Recursive, binds) thing_inside + = -- A recursive strongly-connected component + -- To maximise polymorphism (with -fglasgow-exts), we do a new + -- strongly-connected-component analysis, this time omitting + -- any references to variables with type signatures. + -- + -- Then we bring into scope all the variables with type signatures + do { traceTc (text "tc_group rec" <+> pprLHsBinds binds) + ; gla_exts <- doptM Opt_GlasgowExts + ; (binds,thing) <- if gla_exts + then go new_sccs + else tc_binds Recursive binds thing_inside + ; return ([(Recursive, unionManyBags binds)], thing) } + -- Rec them all together where - tc_body poly_ids -- Type check the pragmas and "thing inside" - = -- Extend the environment to bind the new polymorphic Ids - tcExtendLocalValEnv poly_ids $ - - -- Build bindings and IdInfos corresponding to user pragmas - tcSpecSigs sigs `thenM` \ prag_binds -> + new_sccs :: [SCC (LHsBind Name)] + new_sccs = stronglyConnComp (mkEdges sig_fn binds) - -- Now do whatever happens next, in the augmented envt - do_next `thenM` \ thing -> +-- go :: SCC (LHsBind Name) -> TcM ([LHsBind TcId], thing) + go (scc:sccs) = do { (binds1, (binds2, thing)) <- go1 scc (go sccs) + ; return (binds1 ++ binds2, thing) } + go [] = do { thing <- thing_inside; return ([], thing) } - returnM (prag_binds, thing) -\end{code} + go1 (AcyclicSCC bind) = tc_binds NonRecursive (unitBag bind) + go1 (CyclicSCC binds) = tc_binds Recursive (listToBag binds) + tc_binds rec_tc binds = tcPolyBinds top_lvl Recursive rec_tc sig_fn prag_fn binds -%************************************************************************ -%* * -\subsection{tcBindWithSigs} -%* * -%************************************************************************ +------------------------ +mkEdges :: TcSigFun -> LHsBinds Name + -> [(LHsBind Name, BKey, [BKey])] -@tcBindWithSigs@ deals with a single binding group. It does generalisation, -so all the clever stuff is in here. +type BKey = Int -- Just number off the bindings -* binder_names and mbind must define the same set of Names +mkEdges sig_fn binds + = [ (bind, key, [fromJust mb_key | n <- nameSetToList (bind_fvs (unLoc bind)), + let mb_key = lookupNameEnv key_map n, + isJust mb_key, + no_sig n ]) + | (bind, key) <- keyd_binds + ] + where + no_sig :: Name -> Bool + no_sig n = isNothing (sig_fn n) + + keyd_binds = bagToList binds `zip` [0::BKey ..] + + key_map :: NameEnv BKey -- Which binding it comes from + key_map = mkNameEnv [(bndr, key) | (L _ bind, key) <- keyd_binds + , bndr <- bindersOfHsBind bind ] + +bindersOfHsBind :: HsBind Name -> [Name] +bindersOfHsBind (PatBind { pat_lhs = pat }) = collectPatBinders pat +bindersOfHsBind (FunBind { fun_id = L _ f }) = [f] + +------------------------ +tcPolyBinds :: TopLevelFlag + -> RecFlag -- Whether the group is really recursive + -> RecFlag -- Whether it's recursive for typechecking purposes + -> TcSigFun -> TcPragFun + -> LHsBinds Name + -> TcM thing + -> TcM ([LHsBinds TcId], thing) + +-- Typechecks a single bunch of bindings all together, +-- and generalises them. The bunch may be only part of a recursive +-- group, because we use type signatures to maximise polymorphism +-- +-- Deals with the bindInstsOfLocalFuns thing too +-- +-- Returns a list because the input may be a single non-recursive binding, +-- in which case the dependency order of the resulting bindings is +-- important. + +tcPolyBinds top_lvl rec_group rec_tc sig_fn prag_fn scc thing_inside + = -- NB: polymorphic recursion means that a function + -- may use an instance of itself, we must look at the LIE arising + -- from the function's own right hand side. Hence the getLIE + -- encloses the tc_poly_binds. + do { traceTc (text "tcPolyBinds" <+> ppr scc) + ; ((binds1, poly_ids, thing), lie) <- getLIE $ + do { (binds1, poly_ids) <- tc_poly_binds top_lvl rec_group rec_tc + sig_fn prag_fn scc + ; thing <- tcExtendIdEnv poly_ids thing_inside + ; return (binds1, poly_ids, thing) } + + ; if isTopLevel top_lvl + then -- For the top level don't bother will all this + -- bindInstsOfLocalFuns stuff. All the top level + -- things are rec'd together anyway, so it's fine to + -- leave them to the tcSimplifyTop, + -- and quite a bit faster too + do { extendLIEs lie; return (binds1, thing) } + + else do -- Nested case + { lie_binds <- bindInstsOfLocalFuns lie poly_ids + ; return (binds1 ++ [lie_binds], thing) }} + +------------------------ +tc_poly_binds :: TopLevelFlag -- See comments on tcPolyBinds + -> RecFlag -> RecFlag + -> TcSigFun -> TcPragFun + -> LHsBinds Name + -> TcM ([LHsBinds TcId], [TcId]) +-- Typechecks the bindings themselves +-- Knows nothing about the scope of the bindings + +tc_poly_binds top_lvl rec_group rec_tc sig_fn prag_fn binds + = let + binder_names = collectHsBindBinders binds + bind_list = bagToList binds + + loc = getLoc (head bind_list) + -- TODO: location a bit awkward, but the mbinds have been + -- dependency analysed and may no longer be adjacent + in + -- SET UP THE MAIN RECOVERY; take advantage of any type sigs + setSrcSpan loc $ + recoverM (recoveryCode binder_names) $ do + + { traceTc (ptext SLIT("------------------------------------------------")) + ; traceTc (ptext SLIT("Bindings for") <+> ppr binder_names) + + -- TYPECHECK THE BINDINGS + ; ((binds', mono_bind_infos), lie_req) + <- getLIE (tcMonoBinds bind_list sig_fn rec_tc) + + -- CHECK FOR UNLIFTED BINDINGS + -- These must be non-recursive etc, and are not generalised + -- They desugar to a case expression in the end + ; zonked_mono_tys <- zonkTcTypes (map getMonoType mono_bind_infos) + ; if any isUnLiftedType zonked_mono_tys then + do { -- Unlifted bindings + checkUnliftedBinds top_lvl rec_group binds' mono_bind_infos + ; extendLIEs lie_req + ; let exports = zipWith mk_export mono_bind_infos zonked_mono_tys + mk_export (name, Nothing, mono_id) mono_ty = ([], mkLocalId name mono_ty, mono_id, []) + mk_export (name, Just sig, mono_id) mono_ty = ([], sig_id sig, mono_id, []) + -- ToDo: prags for unlifted bindings + + ; return ( [unitBag $ L loc $ AbsBinds [] [] exports binds'], + [poly_id | (_, poly_id, _, _) <- exports]) } -- Guaranteed zonked + + else do -- The normal lifted case: GENERALISE + { is_unres <- isUnRestrictedGroup bind_list sig_fn + ; (tyvars_to_gen, dict_binds, dict_ids) + <- addErrCtxt (genCtxt (bndrNames mono_bind_infos)) $ + generalise top_lvl is_unres mono_bind_infos lie_req + + -- FINALISE THE QUANTIFIED TYPE VARIABLES + -- The quantified type variables often include meta type variables + -- we want to freeze them into ordinary type variables, and + -- default their kind (e.g. from OpenTypeKind to TypeKind) + ; tyvars_to_gen' <- mappM zonkQuantifiedTyVar tyvars_to_gen -* The Names in tc_ty_sigs must be a subset of binder_names + -- BUILD THE POLYMORPHIC RESULT IDs + ; exports <- mapM (mkExport prag_fn tyvars_to_gen' (map idType dict_ids)) + mono_bind_infos -* The Ids in tc_ty_sigs don't necessarily have to have the same name - as the Name in the tc_ty_sig + -- ZONK THE poly_ids, because they are used to extend the type + -- environment; see the invariant on TcEnv.tcExtendIdEnv + ; let poly_ids = [poly_id | (_, poly_id, _, _) <- exports] + ; zonked_poly_ids <- mappM zonkId poly_ids -\begin{code} -tcBindWithSigs :: TopLevelFlag - -> RenamedMonoBinds - -> [RenamedSig] - -> RecFlag - -> TcM (TcMonoBinds, [TcId]) - -tcBindWithSigs top_lvl mbind sigs is_rec - = -- TYPECHECK THE SIGNATURES - recoverM (returnM []) ( - mappM tcTySig [sig | sig@(Sig name _ _) <- sigs] - ) `thenM` \ tc_ty_sigs -> + ; traceTc (text "binding:" <+> ppr (zonked_poly_ids `zip` map idType zonked_poly_ids)) - -- SET UP THE MAIN RECOVERY; take advantage of any type sigs - recoverM ( - -- If typechecking the binds fails, then return with each - -- signature-less binder given type (forall a.a), to minimise subsequent - -- error messages - newTyVar liftedTypeKind `thenM` \ alpha_tv -> - let - forall_a_a = mkForAllTy alpha_tv (mkTyVarTy alpha_tv) - binder_names = collectMonoBinders mbind - poly_ids = map mk_dummy binder_names - mk_dummy name = case maybeSig tc_ty_sigs name of - Just sig -> tcSigPolyId sig -- Signature - Nothing -> mkLocalId name forall_a_a -- No signature - in - traceTc (text "tcBindsWithSigs: error recovery" <+> ppr binder_names) `thenM_` - returnM (EmptyMonoBinds, poly_ids) - ) $ - - -- TYPECHECK THE BINDINGS - traceTc (ptext SLIT("--------------------------------------------------------")) `thenM_` - traceTc (ptext SLIT("Bindings for") <+> ppr (collectMonoBinders mbind)) `thenM_` - getLIE (tcMonoBinds mbind tc_ty_sigs is_rec) `thenM` \ ((mbind', bndr_names_w_ids), lie_req) -> - let - (binder_names, mono_ids) = unzip (bagToList bndr_names_w_ids) - tau_tvs = foldr (unionVarSet . tyVarsOfType . idType) emptyVarSet mono_ids - in + ; let abs_bind = L loc $ AbsBinds tyvars_to_gen' + dict_ids exports + (dict_binds `unionBags` binds') - -- GENERALISE - -- (it seems a bit crude to have to do getLIE twice, - -- but I can't see a better way just now) - addSrcLoc (minimum (map getSrcLoc binder_names)) $ - addErrCtxt (genCtxt binder_names) $ - getLIE (generalise binder_names mbind tau_tvs lie_req tc_ty_sigs) - `thenM` \ ((tc_tyvars_to_gen, dict_binds, dict_ids), lie_free) -> - - - -- ZONK THE GENERALISED TYPE VARIABLES TO REAL TyVars - -- This commits any unbound kind variables to boxed kind, by unification - -- It's important that the final quanfified type variables - -- are fully zonked, *including boxity*, because they'll be - -- included in the forall types of the polymorphic Ids. - -- At calls of these Ids we'll instantiate fresh type variables from - -- them, and we use their boxity then. - mappM zonkTcTyVarToTyVar tc_tyvars_to_gen `thenM` \ real_tyvars_to_gen -> - - -- ZONK THE Ids - -- It's important that the dict Ids are zonked, including the boxity set - -- in the previous step, because they are later used to form the type of - -- the polymorphic thing, and forall-types must be zonked so far as - -- their bound variables are concerned - mappM zonkId dict_ids `thenM` \ zonked_dict_ids -> - mappM zonkId mono_ids `thenM` \ zonked_mono_ids -> + ; return ([unitBag abs_bind], zonked_poly_ids) + } } - -- BUILD THE POLYMORPHIC RESULT IDs - let - exports = zipWith mk_export binder_names zonked_mono_ids - poly_ids = [poly_id | (_, poly_id, _) <- exports] - dict_tys = map idType zonked_dict_ids - - inlines = mkNameSet [name | InlineSig True name _ loc <- sigs] - -- Any INLINE sig (regardless of phase control) - -- makes the RHS look small - inline_phases = listToFM [(name, phase) | InlineSig _ name phase _ <- sigs, - not (isAlwaysActive phase)] - -- Set the IdInfo field to control the inline phase - -- AlwaysActive is the default, so don't bother with them - - mk_export binder_name zonked_mono_id - = (tyvars, - attachInlinePhase inline_phases poly_id, - zonked_mono_id) + +-------------- +mkExport :: TcPragFun -> [TyVar] -> [TcType] -> MonoBindInfo + -> TcM ([TyVar], Id, Id, [Prag]) +mkExport prag_fn inferred_tvs dict_tys (poly_name, mb_sig, mono_id) + = case mb_sig of + Nothing -> do { prags <- tcPrags poly_id (prag_fn poly_name) + ; return (inferred_tvs, poly_id, mono_id, prags) } where - (tyvars, poly_id) = - case maybeSig tc_ty_sigs binder_name of - Just (TySigInfo sig_poly_id sig_tyvars _ _ _ _ _) -> - (sig_tyvars, sig_poly_id) - Nothing -> (real_tyvars_to_gen, new_poly_id) - - new_poly_id = mkLocalId binder_name poly_ty - poly_ty = mkForAllTys real_tyvars_to_gen - $ mkFunTys dict_tys - $ idType zonked_mono_id - -- It's important to build a fully-zonked poly_ty, because - -- we'll slurp out its free type variables when extending the - -- local environment (tcExtendLocalValEnv); if it's not zonked - -- it appears to have free tyvars that aren't actually free - -- at all. - in + poly_id = mkLocalId poly_name poly_ty + poly_ty = mkForAllTys inferred_tvs + $ mkFunTys dict_tys + $ idType mono_id + + Just sig -> do { let poly_id = sig_id sig + ; prags <- tcPrags poly_id (prag_fn poly_name) + ; sig_tys <- zonkTcTyVars (sig_tvs sig) + ; let sig_tvs' = map (tcGetTyVar "mkExport") sig_tys + ; return (sig_tvs', poly_id, mono_id, prags) } + -- We zonk the sig_tvs here so that the export triple + -- always has zonked type variables; + -- a convenient invariant + + +------------------------ +type TcPragFun = Name -> [LSig Name] + +mkPragFun :: [LSig Name] -> TcPragFun +mkPragFun sigs = \n -> lookupNameEnv env n `orElse` [] + where + prs = [(fromJust (sigName sig), sig) | sig <- sigs, isPragLSig sig] + env = foldl add emptyNameEnv prs + add env (n,p) = extendNameEnv_Acc (:) singleton env n p + +tcPrags :: Id -> [LSig Name] -> TcM [Prag] +tcPrags poly_id prags = mapM tc_prag prags + where + tc_prag (L loc prag) = setSrcSpan loc $ + addErrCtxt (pragSigCtxt prag) $ + tcPrag poly_id prag - traceTc (text "binding:" <+> ppr ((zonked_dict_ids, dict_binds), - exports, map idType poly_ids)) `thenM_` +pragSigCtxt prag = hang (ptext SLIT("In the pragma")) 2 (ppr prag) + +tcPrag :: TcId -> Sig Name -> TcM Prag +tcPrag poly_id (SpecSig orig_name hs_ty inl) = tcSpecPrag poly_id hs_ty inl +tcPrag poly_id (SpecInstSig hs_ty) = tcSpecPrag poly_id hs_ty defaultInlineSpec +tcPrag poly_id (InlineSig v inl) = return (InlinePrag inl) + + +tcSpecPrag :: TcId -> LHsType Name -> InlineSpec -> TcM Prag +tcSpecPrag poly_id hs_ty inl + = do { spec_ty <- tcHsSigType (FunSigCtxt (idName poly_id)) hs_ty + ; (co_fn, lie) <- getLIE (tcSubExp (idType poly_id) spec_ty) + ; extendLIEs lie + ; let const_dicts = map instToId lie + ; return (SpecPrag (mkHsCoerce co_fn (HsVar poly_id)) spec_ty const_dicts inl) } + +-------------- +-- If typechecking the binds fails, then return with each +-- signature-less binder given type (forall a.a), to minimise +-- subsequent error messages +recoveryCode binder_names + = do { traceTc (text "tcBindsWithSigs: error recovery" <+> ppr binder_names) + ; poly_ids <- mapM mk_dummy binder_names + ; return ([], poly_ids) } + where + mk_dummy name = do { mb_id <- tcLookupLocalId_maybe name + ; case mb_id of + Just id -> return id -- Had signature, was in envt + Nothing -> return (mkLocalId name forall_a_a) } -- No signature + +forall_a_a :: TcType +forall_a_a = mkForAllTy alphaTyVar (mkTyVarTy alphaTyVar) - -- Check for an unlifted, non-overloaded group - -- In that case we must make extra checks - if any (isUnLiftedType . idType) zonked_mono_ids && null zonked_dict_ids - then -- Some bindings are unlifted - checkUnliftedBinds top_lvl is_rec real_tyvars_to_gen mbind `thenM_` - - extendLIEs lie_req `thenM_` - returnM ( - AbsBinds [] [] exports inlines mbind', - -- Do not generate even any x=y bindings - poly_ids - ) - - else -- The normal case - extendLIEs lie_free `thenM_` - returnM ( - AbsBinds real_tyvars_to_gen - zonked_dict_ids - exports - inlines - (dict_binds `andMonoBinds` mbind'), - poly_ids - ) - -attachInlinePhase inline_phases bndr - = case lookupFM inline_phases (idName bndr) of - Just prag -> bndr `setInlinePragma` prag - Nothing -> bndr -- Check that non-overloaded unlifted bindings are -- a) non-recursive, -- b) not top level, --- c) non-polymorphic --- d) not a multiple-binding group (more or less implied by (a)) - -checkUnliftedBinds top_lvl is_rec real_tyvars_to_gen mbind - = ASSERT( not (any ((eqKind unliftedTypeKind) . tyVarKind) real_tyvars_to_gen) ) - -- The instCantBeGeneralised stuff in tcSimplify should have - -- already raised an error if we're trying to generalise an - -- unboxed tyvar (NB: unboxed tyvars are always introduced - -- along with a class constraint) and it's better done there - -- because we have more precise origin information. - -- That's why we just use an ASSERT here. - - checkTc (isNotTopLevel top_lvl) - (unliftedBindErr "Top-level" mbind) `thenM_` - checkTc (isNonRec is_rec) - (unliftedBindErr "Recursive" mbind) `thenM_` - checkTc (single_bind mbind) - (unliftedBindErr "Multiple" mbind) `thenM_` - checkTc (null real_tyvars_to_gen) - (unliftedBindErr "Polymorphic" mbind) - +-- c) not a multiple-binding group (more or less implied by (a)) + +checkUnliftedBinds :: TopLevelFlag -> RecFlag + -> LHsBinds TcId -> [MonoBindInfo] -> TcM () +checkUnliftedBinds top_lvl rec_group mbind infos + = do { checkTc (isNotTopLevel top_lvl) + (unliftedBindErr "Top-level" mbind) + ; checkTc (isNonRec rec_group) + (unliftedBindErr "Recursive" mbind) + ; checkTc (isSingletonBag mbind) + (unliftedBindErr "Multiple" mbind) + ; mapM_ check_sig infos } where - single_bind (PatMonoBind _ _ _) = True - single_bind (FunMonoBind _ _ _ _) = True - single_bind other = False + check_sig (_, Just sig, _) = checkTc (null (sig_tvs sig) && null (sig_theta sig)) + (badUnliftedSig sig) + check_sig other = return () \end{code} -Polymorphic recursion -~~~~~~~~~~~~~~~~~~~~~ -The game plan for polymorphic recursion in the code above is +%************************************************************************ +%* * +\subsection{tcMonoBind} +%* * +%************************************************************************ - * Bind any variable for which we have a type signature - to an Id with a polymorphic type. Then when type-checking - the RHSs we'll make a full polymorphic call. +@tcMonoBinds@ deals with a perhaps-recursive group of HsBinds. +The signatures have been dealt with already. -This fine, but if you aren't a bit careful you end up with a horrendous -amount of partial application and (worse) a huge space leak. For example: +\begin{code} +tcMonoBinds :: [LHsBind Name] + -> TcSigFun + -> RecFlag -- True <=> the binding is recursive for typechecking purposes + -- i.e. the binders are mentioned in their RHSs, and + -- we are not resuced by a type signature + -> TcM (LHsBinds TcId, [MonoBindInfo]) + +tcMonoBinds [L b_loc (FunBind { fun_id = L nm_loc name, fun_infix = inf, + fun_matches = matches, bind_fvs = fvs })] + sig_fn -- Single function binding, + NonRecursive -- binder isn't mentioned in RHS, + | Nothing <- sig_fn name -- ...with no type signature + = -- In this very special case we infer the type of the + -- right hand side first (it may have a higher-rank type) + -- and *then* make the monomorphic Id for the LHS + -- e.g. f = \(x::forall a. a->a) -> + -- We want to infer a higher-rank type for f + setSrcSpan b_loc $ + do { ((co_fn, matches'), rhs_ty) <- tcInfer (tcMatchesFun name matches) + + -- Check for an unboxed tuple type + -- f = (# True, False #) + -- Zonk first just in case it's hidden inside a meta type variable + -- (This shows up as a (more obscure) kind error + -- in the 'otherwise' case of tcMonoBinds.) + ; zonked_rhs_ty <- zonkTcType rhs_ty + ; checkTc (not (isUnboxedTupleType zonked_rhs_ty)) + (unboxedTupleErr name zonked_rhs_ty) + + ; mono_name <- newLocalName name + ; let mono_id = mkLocalId mono_name zonked_rhs_ty + ; return (unitBag (L b_loc (FunBind { fun_id = L nm_loc mono_id, fun_infix = inf, + fun_matches = matches', bind_fvs = fvs, + fun_co_fn = co_fn })), + [(name, Nothing, mono_id)]) } + +tcMonoBinds [L b_loc (FunBind { fun_id = L nm_loc name, fun_infix = inf, + fun_matches = matches, bind_fvs = fvs })] + sig_fn -- Single function binding + non_rec + | Just sig <- sig_fn name -- ...with a type signature + = -- When we have a single function binding, with a type signature + -- we can (a) use genuine, rigid skolem constants for the type variables + -- (b) bring (rigid) scoped type variables into scope + setSrcSpan b_loc $ + do { tc_sig <- tcInstSig True sig + ; mono_name <- newLocalName name + ; let mono_ty = sig_tau tc_sig + mono_id = mkLocalId mono_name mono_ty + rhs_tvs = [ (name, mkTyVarTy tv) + | (name, tv) <- sig_scoped tc_sig `zip` sig_tvs tc_sig ] + + ; (co_fn, matches') <- tcExtendTyVarEnv2 rhs_tvs $ + tcMatchesFun mono_name matches mono_ty + + ; let fun_bind' = FunBind { fun_id = L nm_loc mono_id, + fun_infix = inf, fun_matches = matches', + bind_fvs = placeHolderNames, fun_co_fn = co_fn } + ; return (unitBag (L b_loc fun_bind'), + [(name, Just tc_sig, mono_id)]) } + +tcMonoBinds binds sig_fn non_rec + = do { tc_binds <- mapM (wrapLocM (tcLhs sig_fn)) binds + + -- Bring the monomorphic Ids, into scope for the RHSs + ; let mono_info = getMonoBindInfo tc_binds + rhs_id_env = [(name,mono_id) | (name, Nothing, mono_id) <- mono_info] + -- A monomorphic binding for each term variable that lacks + -- a type sig. (Ones with a sig are already in scope.) + + ; binds' <- tcExtendIdEnv2 rhs_id_env $ + traceTc (text "tcMonoBinds" <+> vcat [ ppr n <+> ppr id <+> ppr (idType id) + | (n,id) <- rhs_id_env]) `thenM_` + mapM (wrapLocM tcRhs) tc_binds + ; return (listToBag binds', mono_info) } + +------------------------ +-- tcLhs typechecks the LHS of the bindings, to construct the environment in which +-- we typecheck the RHSs. Basically what we are doing is this: for each binder: +-- if there's a signature for it, use the instantiated signature type +-- otherwise invent a type variable +-- You see that quite directly in the FunBind case. +-- +-- But there's a complication for pattern bindings: +-- data T = MkT (forall a. a->a) +-- MkT f = e +-- Here we can guess a type variable for the entire LHS (which will be refined to T) +-- but we want to get (f::forall a. a->a) as the RHS environment. +-- The simplest way to do this is to typecheck the pattern, and then look up the +-- bound mono-ids. Then we want to retain the typechecked pattern to avoid re-doing +-- it; hence the TcMonoBind data type in which the LHS is done but the RHS isn't + +data TcMonoBind -- Half completed; LHS done, RHS not done + = TcFunBind MonoBindInfo (Located TcId) Bool (MatchGroup Name) + | TcPatBind [MonoBindInfo] (LPat TcId) (GRHSs Name) TcSigmaType + +type MonoBindInfo = (Name, Maybe TcSigInfo, TcId) + -- Type signature (if any), and + -- the monomorphic bound things + +bndrNames :: [MonoBindInfo] -> [Name] +bndrNames mbi = [n | (n,_,_) <- mbi] + +getMonoType :: MonoBindInfo -> TcTauType +getMonoType (_,_,mono_id) = idType mono_id + +tcLhs :: TcSigFun -> HsBind Name -> TcM TcMonoBind +tcLhs sig_fn (FunBind { fun_id = L nm_loc name, fun_infix = inf, fun_matches = matches }) + = do { mb_sig <- tcInstSig_maybe (sig_fn name) + ; mono_name <- newLocalName name + ; mono_ty <- mk_mono_ty mb_sig + ; let mono_id = mkLocalId mono_name mono_ty + ; return (TcFunBind (name, mb_sig, mono_id) (L nm_loc mono_id) inf matches) } + where + mk_mono_ty (Just sig) = return (sig_tau sig) + mk_mono_ty Nothing = newFlexiTyVarTy argTypeKind - f :: Eq a => [a] -> [a] - f xs = ...f... +tcLhs sig_fn bind@(PatBind { pat_lhs = pat, pat_rhs = grhss }) + = do { mb_sigs <- mapM (tcInstSig_maybe . sig_fn) names -If we don't take care, after typechecking we get + ; let nm_sig_prs = names `zip` mb_sigs + tau_sig_env = mkNameEnv [ (name, sig_tau sig) | (name, Just sig) <- nm_sig_prs] + sig_tau_fn = lookupNameEnv tau_sig_env - f = /\a -> \d::Eq a -> let f' = f a d - in - \ys:[a] -> ...f'... + tc_pat exp_ty = tcPat (LetPat sig_tau_fn) pat exp_ty unitTy $ \ _ -> + mapM lookup_info nm_sig_prs + -- The unitTy is a bit bogus; it's the "result type" for lookup_info. -Notice the the stupid construction of (f a d), which is of course -identical to the function we're executing. In this case, the -polymorphic recursion isn't being used (but that's a very common case). -We'd prefer + -- After typechecking the pattern, look up the binder + -- names, which the pattern has brought into scope. + lookup_info :: (Name, Maybe TcSigInfo) -> TcM MonoBindInfo + lookup_info (name, mb_sig) = do { mono_id <- tcLookupId name + ; return (name, mb_sig, mono_id) } - f = /\a -> \d::Eq a -> letrec - fm = \ys:[a] -> ...fm... - in - fm + ; ((pat', infos), pat_ty) <- addErrCtxt (patMonoBindsCtxt pat grhss) $ + tcInfer tc_pat -This can lead to a massive space leak, from the following top-level defn -(post-typechecking) + ; return (TcPatBind infos pat' grhss pat_ty) } + where + names = collectPatBinders pat - ff :: [Int] -> [Int] - ff = f Int dEqInt -Now (f dEqInt) evaluates to a lambda that has f' as a free variable; but -f' is another thunk which evaluates to the same thing... and you end -up with a chain of identical values all hung onto by the CAF ff. +tcLhs sig_fn other_bind = pprPanic "tcLhs" (ppr other_bind) + -- AbsBind, VarBind impossible - ff = f Int dEqInt +------------------- +tcRhs :: TcMonoBind -> TcM (HsBind TcId) +tcRhs (TcFunBind info fun'@(L _ mono_id) inf matches) + = do { (co_fn, matches') <- tcMatchesFun (idName mono_id) matches + (idType mono_id) + ; return (FunBind { fun_id = fun', fun_infix = inf, fun_matches = matches', + bind_fvs = placeHolderNames, fun_co_fn = co_fn }) } - = let f' = f Int dEqInt in \ys. ...f'... +tcRhs bind@(TcPatBind _ pat' grhss pat_ty) + = do { grhss' <- addErrCtxt (patMonoBindsCtxt pat' grhss) $ + tcGRHSsPat grhss pat_ty + ; return (PatBind { pat_lhs = pat', pat_rhs = grhss', pat_rhs_ty = pat_ty, + bind_fvs = placeHolderNames }) } - = let f' = let f' = f Int dEqInt in \ys. ...f'... - in \ys. ...f'... -Etc. -Solution: when typechecking the RHSs we always have in hand the -*monomorphic* Ids for each binding. So we just need to make sure that -if (Method f a d) shows up in the constraints emerging from (...f...) -we just use the monomorphic Id. We achieve this by adding monomorphic Ids -to the "givens" when simplifying constraints. That's what the "lies_avail" -is doing. +--------------------- +getMonoBindInfo :: [Located TcMonoBind] -> [MonoBindInfo] +getMonoBindInfo tc_binds + = foldr (get_info . unLoc) [] tc_binds + where + get_info (TcFunBind info _ _ _) rest = info : rest + get_info (TcPatBind infos _ _ _) rest = infos ++ rest +\end{code} %************************************************************************ %* * -\subsection{getTyVarsToGen} + Generalisation %* * %************************************************************************ \begin{code} -generalise binder_names mbind tau_tvs lie_req sigs = - - -- check for -fno-monomorphism-restriction - doptM Opt_NoMonomorphismRestriction `thenM` \ no_MR -> - let is_unrestricted | no_MR = True - | otherwise = isUnRestrictedGroup tysig_names mbind - in - - if not is_unrestricted then -- RESTRICTED CASE - -- Check signature contexts are empty - checkTc (all is_mono_sig sigs) - (restrictedBindCtxtErr binder_names) `thenM_` +generalise :: TopLevelFlag -> Bool + -> [MonoBindInfo] -> [Inst] + -> TcM ([TcTyVar], TcDictBinds, [TcId]) +generalise top_lvl is_unrestricted mono_infos lie_req + | not is_unrestricted -- RESTRICTED CASE + = -- Check signature contexts are empty + do { checkTc (all is_mono_sig sigs) + (restrictedBindCtxtErr bndrs) -- Now simplify with exactly that set of tyvars -- We have to squash those Methods - tcSimplifyRestricted doc tau_tvs lie_req `thenM` \ (qtvs, binds) -> + ; (qtvs, binds) <- tcSimplifyRestricted doc top_lvl bndrs + tau_tvs lie_req -- Check that signature type variables are OK - checkSigsTyVars qtvs sigs `thenM` \ final_qtvs -> + ; final_qtvs <- checkSigsTyVars qtvs sigs - returnM (final_qtvs, binds, []) + ; return (final_qtvs, binds, []) } - else if null sigs then -- UNRESTRICTED CASE, NO TYPE SIGS - tcSimplifyInfer doc tau_tvs lie_req + | null sigs -- UNRESTRICTED CASE, NO TYPE SIGS + = tcSimplifyInfer doc tau_tvs lie_req + + | otherwise -- UNRESTRICTED CASE, WITH TYPE SIGS + = do { sig_lie <- unifyCtxts sigs -- sigs is non-empty + ; let -- The "sig_avails" is the stuff available. We get that from + -- the context of the type signature, BUT ALSO the lie_avail + -- so that polymorphic recursion works right (see Note [Polymorphic recursion]) + local_meths = [mkMethInst sig mono_id | (_, Just sig, mono_id) <- mono_infos] + sig_avails = sig_lie ++ local_meths - else -- UNRESTRICTED CASE, WITH TYPE SIGS - -- CHECKING CASE: Unrestricted group, there are type signatures - -- Check signature contexts are identical - checkSigsCtxts sigs `thenM` \ (sig_avails, sig_dicts) -> - -- Check that the needed dicts can be -- expressed in terms of the signature ones - tcSimplifyInferCheck doc tau_tvs sig_avails lie_req `thenM` \ (forall_tvs, dict_binds) -> + ; (forall_tvs, dict_binds) <- tcSimplifyInferCheck doc tau_tvs sig_avails lie_req -- Check that signature type variables are OK - checkSigsTyVars forall_tvs sigs `thenM` \ final_qtvs -> - - returnM (final_qtvs, dict_binds, sig_dicts) + ; final_qtvs <- checkSigsTyVars forall_tvs sigs + ; returnM (final_qtvs, dict_binds, map instToId sig_lie) } where - tysig_names = map (idName . tcSigPolyId) sigs - is_mono_sig (TySigInfo _ _ theta _ _ _ _) = null theta + bndrs = bndrNames mono_infos + sigs = [sig | (_, Just sig, _) <- mono_infos] + tau_tvs = foldr (unionVarSet . exactTyVarsOfType . getMonoType) emptyVarSet mono_infos + -- NB: exactTyVarsOfType; see Note [Silly type synonym] + -- near defn of TcType.exactTyVarsOfType + is_mono_sig sig = null (sig_theta sig) + doc = ptext SLIT("type signature(s) for") <+> pprBinders bndrs + + mkMethInst (TcSigInfo { sig_id = poly_id, sig_tvs = tvs, + sig_theta = theta, sig_loc = loc }) mono_id + = Method mono_id poly_id (mkTyVarTys tvs) theta loc +\end{code} - doc = ptext SLIT("type signature(s) for") <+> pprBinders binder_names +unifyCtxts checks that all the signature contexts are the same +The type signatures on a mutually-recursive group of definitions +must all have the same context (or none). ------------------------ - -- CHECK THAT ALL THE SIGNATURE CONTEXTS ARE UNIFIABLE - -- The type signatures on a mutually-recursive group of definitions - -- must all have the same context (or none). - -- - -- We unify them because, with polymorphic recursion, their types - -- might not otherwise be related. This is a rather subtle issue. - -- ToDo: amplify -checkSigsCtxts sigs@(TySigInfo id1 sig_tvs theta1 _ _ _ src_loc : other_sigs) - = addSrcLoc src_loc $ - mappM_ check_one other_sigs `thenM_` - if null theta1 then - returnM ([], []) -- Non-overloaded type signatures - else - newDicts SignatureOrigin theta1 `thenM` \ sig_dicts -> - let - -- The "sig_avails" is the stuff available. We get that from - -- the context of the type signature, BUT ALSO the lie_avail - -- so that polymorphic recursion works right (see comments at end of fn) - sig_avails = sig_dicts ++ sig_meths - in - returnM (sig_avails, map instToId sig_dicts) - where - sig1_dict_tys = map mkPredTy theta1 - sig_meths = concat [insts | TySigInfo _ _ _ _ _ insts _ <- sigs] +The trick here is that all the signatures should have the same +context, and we want to share type variables for that context, so that +all the right hand sides agree a common vocabulary for their type +constraints + +We unify them because, with polymorphic recursion, their types +might not otherwise be related. This is a rather subtle issue. - check_one sig@(TySigInfo id _ theta _ _ _ _) - = addErrCtxt (sigContextsCtxt id1 id) $ - checkTc (equalLength theta theta1) sigContextsErr `thenM_` - unifyTauTyLists sig1_dict_tys (map mkPredTy theta) +\begin{code} +unifyCtxts :: [TcSigInfo] -> TcM [Inst] +unifyCtxts (sig1 : sigs) -- Argument is always non-empty + = do { mapM unify_ctxt sigs + ; newDictsAtLoc (sig_loc sig1) (sig_theta sig1) } + where + theta1 = sig_theta sig1 + unify_ctxt :: TcSigInfo -> TcM () + unify_ctxt sig@(TcSigInfo { sig_theta = theta }) + = setSrcSpan (instLocSrcSpan (sig_loc sig)) $ + addErrCtxt (sigContextsCtxt sig1 sig) $ + unifyTheta theta1 theta checkSigsTyVars :: [TcTyVar] -> [TcSigInfo] -> TcM [TcTyVar] checkSigsTyVars qtvs sigs - = mappM check_one sigs `thenM` \ sig_tvs_s -> - let - -- Sigh. Make sure that all the tyvars in the type sigs - -- appear in the returned ty var list, which is what we are - -- going to generalise over. Reason: we occasionally get - -- silly types like - -- type T a = () -> () - -- f :: T a - -- f () = () - -- Here, 'a' won't appear in qtvs, so we have to add it - - sig_tvs = foldr (unionVarSet . mkVarSet) emptyVarSet sig_tvs_s - all_tvs = mkVarSet qtvs `unionVarSet` sig_tvs - in - returnM (varSetElems all_tvs) + = do { gbl_tvs <- tcGetGlobalTyVars + ; sig_tvs_s <- mappM (check_sig gbl_tvs) sigs + + ; let -- Sigh. Make sure that all the tyvars in the type sigs + -- appear in the returned ty var list, which is what we are + -- going to generalise over. Reason: we occasionally get + -- silly types like + -- type T a = () -> () + -- f :: T a + -- f () = () + -- Here, 'a' won't appear in qtvs, so we have to add it + sig_tvs = foldl extendVarSetList emptyVarSet sig_tvs_s + all_tvs = varSetElems (extendVarSetList sig_tvs qtvs) + ; returnM all_tvs } where - check_one (TySigInfo id sig_tyvars sig_theta sig_tau _ _ src_loc) - = addSrcLoc src_loc $ - addErrCtxt (ptext SLIT("In the type signature for") - <+> quotes (ppr id)) $ - addErrCtxtM (sigCtxt id sig_tyvars sig_theta sig_tau) $ - checkSigTyVarsWrt (idFreeTyVars id) sig_tyvars -\end{code} + check_sig gbl_tvs (TcSigInfo {sig_id = id, sig_tvs = tvs, + sig_theta = theta, sig_tau = tau}) + = addErrCtxt (ptext SLIT("In the type signature for") <+> quotes (ppr id)) $ + addErrCtxtM (sigCtxt id tvs theta tau) $ + do { tvs' <- checkDistinctTyVars tvs + ; ifM (any (`elemVarSet` gbl_tvs) tvs') + (bleatEscapedTvs gbl_tvs tvs tvs') + ; return tvs' } + +checkDistinctTyVars :: [TcTyVar] -> TcM [TcTyVar] +-- (checkDistinctTyVars tvs) checks that the tvs from one type signature +-- are still all type variables, and all distinct from each other. +-- It returns a zonked set of type variables. +-- For example, if the type sig is +-- f :: forall a b. a -> b -> b +-- we want to check that 'a' and 'b' haven't +-- (a) been unified with a non-tyvar type +-- (b) been unified with each other (all distinct) + +checkDistinctTyVars sig_tvs + = do { zonked_tvs <- mapM zonkSigTyVar sig_tvs + ; foldlM check_dup emptyVarEnv (sig_tvs `zip` zonked_tvs) + ; return zonked_tvs } + where + check_dup :: TyVarEnv TcTyVar -> (TcTyVar, TcTyVar) -> TcM (TyVarEnv TcTyVar) + -- The TyVarEnv maps each zonked type variable back to its + -- corresponding user-written signature type variable + check_dup acc (sig_tv, zonked_tv) + = case lookupVarEnv acc zonked_tv of + Just sig_tv' -> bomb_out sig_tv sig_tv' + + Nothing -> return (extendVarEnv acc zonked_tv sig_tv) + + bomb_out sig_tv1 sig_tv2 + = do { env0 <- tcInitTidyEnv + ; let (env1, tidy_tv1) = tidyOpenTyVar env0 sig_tv1 + (env2, tidy_tv2) = tidyOpenTyVar env1 sig_tv2 + msg = ptext SLIT("Quantified type variable") <+> quotes (ppr tidy_tv1) + <+> ptext SLIT("is unified with another quantified type variable") + <+> quotes (ppr tidy_tv2) + ; failWithTcM (env2, msg) } + where +\end{code} + @getTyVarsToGen@ decides what type variables to generalise over. @@ -589,238 +851,213 @@ So we are careful, and do a complete simplification just to find the constrained tyvars. We don't use any of the results, except to find which tyvars are constrained. -\begin{code} -isUnRestrictedGroup :: [Name] -- Signatures given for these - -> RenamedMonoBinds - -> Bool - -is_elem v vs = isIn "isUnResMono" v vs - -isUnRestrictedGroup sigs (PatMonoBind other _ _) = False -isUnRestrictedGroup sigs (VarMonoBind v _) = v `is_elem` sigs -isUnRestrictedGroup sigs (FunMonoBind v _ matches _) = isUnRestrictedMatch matches || - v `is_elem` sigs -isUnRestrictedGroup sigs (AndMonoBinds mb1 mb2) = isUnRestrictedGroup sigs mb1 && - isUnRestrictedGroup sigs mb2 -isUnRestrictedGroup sigs EmptyMonoBinds = True - -isUnRestrictedMatch (Match [] _ _ : _) = False -- No args => like a pattern binding -isUnRestrictedMatch other = True -- Some args => a function binding -\end{code} +Note [Polymorphic recursion] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The game plan for polymorphic recursion in the code above is + * Bind any variable for which we have a type signature + to an Id with a polymorphic type. Then when type-checking + the RHSs we'll make a full polymorphic call. -%************************************************************************ -%* * -\subsection{tcMonoBind} -%* * -%************************************************************************ +This fine, but if you aren't a bit careful you end up with a horrendous +amount of partial application and (worse) a huge space leak. For example: -@tcMonoBinds@ deals with a single @MonoBind@. -The signatures have been dealt with already. + f :: Eq a => [a] -> [a] + f xs = ...f... + +If we don't take care, after typechecking we get + + f = /\a -> \d::Eq a -> let f' = f a d + in + \ys:[a] -> ...f'... + +Notice the the stupid construction of (f a d), which is of course +identical to the function we're executing. In this case, the +polymorphic recursion isn't being used (but that's a very common case). +This can lead to a massive space leak, from the following top-level defn +(post-typechecking) + + ff :: [Int] -> [Int] + ff = f Int dEqInt + +Now (f dEqInt) evaluates to a lambda that has f' as a free variable; but +f' is another thunk which evaluates to the same thing... and you end +up with a chain of identical values all hung onto by the CAF ff. + + ff = f Int dEqInt + + = let f' = f Int dEqInt in \ys. ...f'... + + = let f' = let f' = f Int dEqInt in \ys. ...f'... + in \ys. ...f'... + +Etc. + +NOTE: a bit of arity anaysis would push the (f a d) inside the (\ys...), +which would make the space leak go away in this case + +Solution: when typechecking the RHSs we always have in hand the +*monomorphic* Ids for each binding. So we just need to make sure that +if (Method f a d) shows up in the constraints emerging from (...f...) +we just use the monomorphic Id. We achieve this by adding monomorphic Ids +to the "givens" when simplifying constraints. That's what the "lies_avail" +is doing. + +Then we get + + f = /\a -> \d::Eq a -> letrec + fm = \ys:[a] -> ...fm... + in + fm -\begin{code} -tcMonoBinds :: RenamedMonoBinds - -> [TcSigInfo] -> RecFlag - -> TcM (TcMonoBinds, - Bag (Name, -- Bound names - TcId)) -- Corresponding monomorphic bound things - -tcMonoBinds mbinds tc_ty_sigs is_rec - -- Three stages: - -- 1. Check the patterns, building up an environment binding - -- the variables in this group (in the recursive case) - -- 2. Extend the environment - -- 3. Check the RHSs - = tc_mb_pats mbinds `thenM` \ (complete_it, xve) -> - tcExtendLocalValEnv2 (bagToList xve) complete_it - where - tc_mb_pats EmptyMonoBinds - = returnM (returnM (EmptyMonoBinds, emptyBag), emptyBag) - - tc_mb_pats (AndMonoBinds mb1 mb2) - = tc_mb_pats mb1 `thenM` \ (complete_it1, xve1) -> - tc_mb_pats mb2 `thenM` \ (complete_it2, xve2) -> - let - complete_it = complete_it1 `thenM` \ (mb1', bs1) -> - complete_it2 `thenM` \ (mb2', bs2) -> - returnM (AndMonoBinds mb1' mb2', bs1 `unionBags` bs2) - in - returnM (complete_it, xve1 `unionBags` xve2) - - tc_mb_pats (FunMonoBind name inf matches locn) - -- Three cases: - -- a) Type sig supplied - -- b) No type sig and recursive - -- c) No type sig and non-recursive - - | Just sig <- maybeSig tc_ty_sigs name - = let -- (a) There is a type signature - -- Use it for the environment extension, and check - -- the RHS has the appropriate type (with outer for-alls stripped off) - mono_id = tcSigMonoId sig - mono_ty = idType mono_id - complete_it = addSrcLoc locn $ - tcMatchesFun name matches (Check mono_ty) `thenM` \ matches' -> - returnM (FunMonoBind mono_id inf matches' locn, - unitBag (name, mono_id)) - in - returnM (complete_it, if isRec is_rec then unitBag (name,tcSigPolyId sig) - else emptyBag) - - | isRec is_rec - = -- (b) No type signature, and recursive - -- So we must use an ordinary H-M type variable - -- which means the variable gets an inferred tau-type - newLocalName name `thenM` \ mono_name -> - newTyVarTy openTypeKind `thenM` \ mono_ty -> - let - mono_id = mkLocalId mono_name mono_ty - complete_it = addSrcLoc locn $ - tcMatchesFun name matches (Check mono_ty) `thenM` \ matches' -> - returnM (FunMonoBind mono_id inf matches' locn, - unitBag (name, mono_id)) - in - returnM (complete_it, unitBag (name, mono_id)) - - | otherwise -- (c) No type signature, and non-recursive - = let -- So we can use a 'hole' type to infer a higher-rank type - complete_it - = addSrcLoc locn $ - newHole `thenM` \ hole -> - tcMatchesFun name matches (Infer hole) `thenM` \ matches' -> - readMutVar hole `thenM` \ fun_ty -> - newLocalName name `thenM` \ mono_name -> - let - mono_id = mkLocalId mono_name fun_ty - in - returnM (FunMonoBind mono_id inf matches' locn, - unitBag (name, mono_id)) - in - returnM (complete_it, emptyBag) - - tc_mb_pats bind@(PatMonoBind pat grhss locn) - = addSrcLoc locn $ - - -- Now typecheck the pattern - -- We do now support binding fresh (not-already-in-scope) scoped - -- type variables in the pattern of a pattern binding. - -- For example, this is now legal: - -- (x::a, y::b) = e - -- The type variables are brought into scope in tc_binds_and_then, - -- so we don't have to do anything here. - - newHole `thenM` \ hole -> - tcPat tc_pat_bndr pat (Infer hole) `thenM` \ (pat', tvs, ids, lie_avail) -> - readMutVar hole `thenM` \ pat_ty -> - - -- Don't know how to deal with pattern-bound existentials yet - checkTc (isEmptyBag tvs && null lie_avail) - (existentialExplode bind) `thenM_` - - let - complete_it = addSrcLoc locn $ - addErrCtxt (patMonoBindsCtxt bind) $ - tcGRHSsPat grhss (Check pat_ty) `thenM` \ grhss' -> - returnM (PatMonoBind pat' grhss' locn, ids) - in - returnM (complete_it, if isRec is_rec then ids else emptyBag) - - -- tc_pat_bndr is used when dealing with a LHS binder in a pattern. - -- If there was a type sig for that Id, we want to make it much - -- as if that type signature had been on the binder as a SigPatIn. - -- We check for a type signature; if there is one, we use the mono_id - -- from the signature. This is how we make sure the tau part of the - -- signature actually matches the type of the LHS; then tc_mb_pats - -- ensures the LHS and RHS have the same type - - tc_pat_bndr name pat_ty - = case maybeSig tc_ty_sigs name of - Nothing -> newLocalName name `thenM` \ bndr_name -> - tcMonoPatBndr bndr_name pat_ty - - Just sig -> addSrcLoc (getSrcLoc name) $ - tcSubPat (idType mono_id) pat_ty `thenM` \ co_fn -> - returnM (co_fn, mono_id) - where - mono_id = tcSigMonoId sig -\end{code} %************************************************************************ %* * -\subsection{SPECIALIZE pragmas} + Signatures %* * %************************************************************************ -@tcSpecSigs@ munches up the specialisation "signatures" that arise through *user* -pragmas. It is convenient for them to appear in the @[RenamedSig]@ -part of a binding because then the same machinery can be used for -moving them into place as is done for type signatures. - -They look like this: - -\begin{verbatim} - f :: Ord a => [a] -> b -> b - {-# SPECIALIZE f :: [Int] -> b -> b #-} -\end{verbatim} - -For this we generate: -\begin{verbatim} - f* = /\ b -> let d1 = ... - in f Int b d1 -\end{verbatim} - -where f* is a SpecPragmaId. The **sole** purpose of SpecPragmaIds is to -retain a right-hand-side that the simplifier will otherwise discard as -dead code... the simplifier has a flag that tells it not to discard -SpecPragmaId bindings. - -In this case the f* retains a call-instance of the overloaded -function, f, (including appropriate dictionaries) so that the -specialiser will subsequently discover that there's a call of @f@ at -Int, and will create a specialisation for @f@. After that, the -binding for @f*@ can be discarded. - -We used to have a form - {-# SPECIALISE f :: = g #-} -which promised that g implemented f at , but we do that with -a RULE now: - {-# SPECIALISE (f:: TcM TcMonoBinds -tcSpecSigs (SpecSig name poly_ty src_loc : sigs) - = -- SPECIALISE f :: forall b. theta => tau = g - addSrcLoc src_loc $ - addErrCtxt (valSpecSigCtxt name poly_ty) $ - - -- Get and instantiate its alleged specialised type - tcHsSigType (FunSigCtxt name) poly_ty `thenM` \ sig_ty -> - - -- Check that f has a more general type, and build a RHS for - -- the spec-pragma-id at the same time - getLIE (tcCheckSigma (HsVar name) sig_ty) `thenM` \ (spec_expr, spec_lie) -> - - -- Squeeze out any Methods (see comments with tcSimplifyToDicts) - tcSimplifyToDicts spec_lie `thenM` \ spec_binds -> - - -- Just specialise "f" by building a SpecPragmaId binding - -- It is the thing that makes sure we don't prematurely - -- dead-code-eliminate the binding we are really interested in. - newLocalName name `thenM` \ spec_name -> - let - spec_bind = VarMonoBind (mkSpecPragmaId spec_name sig_ty) - (mkHsLet spec_binds spec_expr) - in +type TcSigFun = Name -> Maybe (LSig Name) - -- Do the rest and combine - tcSpecSigs sigs `thenM` \ binds_rest -> - returnM (binds_rest `andMonoBinds` spec_bind) +mkSigFun :: [LSig Name] -> TcSigFun +-- Search for a particular type signature +-- Precondition: the sigs are all type sigs +-- Precondition: no duplicates +mkSigFun sigs = lookupNameEnv env + where + env = mkNameEnv [(fromJust (sigName sig), sig) | sig <- sigs] + +--------------- +data TcSigInfo + = TcSigInfo { + sig_id :: TcId, -- *Polymorphic* binder for this value... + + sig_scoped :: [Name], -- Names for any scoped type variables + -- Invariant: correspond 1-1 with an initial + -- segment of sig_tvs (see Note [Scoped]) + + sig_tvs :: [TcTyVar], -- Instantiated type variables + -- See Note [Instantiate sig] + + sig_theta :: TcThetaType, -- Instantiated theta + sig_tau :: TcTauType, -- Instantiated tau + sig_loc :: InstLoc -- The location of the signature + } + +-- Note [Scoped] +-- There may be more instantiated type variables than scoped +-- ones. For example: +-- type T a = forall b. b -> (a,b) +-- f :: forall c. T c +-- Here, the signature for f will have one scoped type variable, c, +-- but two instantiated type variables, c' and b'. +-- +-- We assume that the scoped ones are at the *front* of sig_tvs, +-- and remember the names from the original HsForAllTy in sig_scoped + +-- Note [Instantiate sig] +-- It's vital to instantiate a type signature with fresh variable. +-- For example: +-- type S = forall a. a->a +-- f,g :: S +-- f = ... +-- g = ... +-- Here, we must use distinct type variables when checking f,g's right hand sides. +-- (Instantiation is only necessary because of type synonyms. Otherwise, +-- it's all cool; each signature has distinct type variables from the renamer.) + +instance Outputable TcSigInfo where + ppr (TcSigInfo { sig_id = id, sig_tvs = tyvars, sig_theta = theta, sig_tau = tau}) + = ppr id <+> ptext SLIT("::") <+> ppr tyvars <+> ppr theta <+> ptext SLIT("=>") <+> ppr tau +\end{code} -tcSpecSigs (other_sig : sigs) = tcSpecSigs sigs -tcSpecSigs [] = returnM EmptyMonoBinds +\begin{code} +tcTySig :: LSig Name -> TcM TcId +tcTySig (L span (TypeSig (L _ name) ty)) + = setSrcSpan span $ + do { sigma_ty <- tcHsSigType (FunSigCtxt name) ty + ; return (mkLocalId name sigma_ty) } + +------------------- +tcInstSig_maybe :: Maybe (LSig Name) -> TcM (Maybe TcSigInfo) +-- Instantiate with *meta* type variables; +-- this signature is part of a multi-signature group +tcInstSig_maybe Nothing = return Nothing +tcInstSig_maybe (Just sig) = do { tc_sig <- tcInstSig False sig + ; return (Just tc_sig) } + +tcInstSig :: Bool -> LSig Name -> TcM TcSigInfo +-- Instantiate the signature, with either skolems or meta-type variables +-- depending on the use_skols boolean +-- +-- We always instantiate with freshs uniques, +-- although we keep the same print-name +-- +-- type T = forall a. [a] -> [a] +-- f :: T; +-- f = g where { g :: T; g = } +-- +-- We must not use the same 'a' from the defn of T at both places!! + +tcInstSig use_skols (L loc (TypeSig (L _ name) hs_ty)) + = setSrcSpan loc $ + do { poly_id <- tcLookupId name -- Cannot fail; the poly ids are put into + -- scope when starting the binding group + ; let skol_info = SigSkol (FunSigCtxt name) + inst_tyvars | use_skols = tcInstSkolTyVars skol_info + | otherwise = tcInstSigTyVars skol_info + ; (tvs, theta, tau) <- tcInstType inst_tyvars (idType poly_id) + ; loc <- getInstLoc (SigOrigin skol_info) + ; return (TcSigInfo { sig_id = poly_id, + sig_tvs = tvs, sig_theta = theta, sig_tau = tau, + sig_scoped = scoped_names, sig_loc = loc }) } + -- Note that the scoped_names and the sig_tvs will have + -- different Names. That's quite ok; when we bring the + -- scoped_names into scope, we just bind them to the sig_tvs + where + -- The scoped names are the ones explicitly mentioned + -- in the HsForAll. (There may be more in sigma_ty, because + -- of nested type synonyms. See Note [Scoped] with TcSigInfo.) + -- We also only have scoped type variables when we are instantiating + -- with true skolems + scoped_names = case (use_skols, hs_ty) of + (True, L _ (HsForAllTy Explicit tvs _ _)) -> hsLTyVarNames tvs + other -> [] + +------------------- +isUnRestrictedGroup :: [LHsBind Name] -> TcSigFun -> TcM Bool +isUnRestrictedGroup binds sig_fn + = do { mono_restriction <- doptM Opt_MonomorphismRestriction + ; return (not mono_restriction || all_unrestricted) } + where + all_unrestricted = all (unrestricted . unLoc) binds + has_sig n = isJust (sig_fn n) + + unrestricted (PatBind {}) = False + unrestricted (VarBind { var_id = v }) = has_sig v + unrestricted (FunBind { fun_id = v, fun_matches = matches }) = unrestricted_match matches + || has_sig (unLoc v) + + unrestricted_match (MatchGroup (L _ (Match [] _ _) : _) _) = False + -- No args => like a pattern binding + unrestricted_match other = True + -- Some args => a function binding \end{code} + %************************************************************************ %* * \subsection[TcBinds-errors]{Error contexts and messages} @@ -829,34 +1066,35 @@ tcSpecSigs [] = returnM EmptyMonoBinds \begin{code} -patMonoBindsCtxt bind - = hang (ptext SLIT("In a pattern binding:")) 4 (ppr bind) - ------------------------------------------------ -valSpecSigCtxt v ty - = sep [ptext SLIT("In a SPECIALIZE pragma for a value:"), - nest 4 (ppr v <+> dcolon <+> ppr ty)] +-- This one is called on LHS, when pat and grhss are both Name +-- and on RHS, when pat is TcId and grhss is still Name +patMonoBindsCtxt pat grhss + = hang (ptext SLIT("In a pattern binding:")) 4 (pprPatBind pat grhss) ----------------------------------------------- -sigContextsErr = ptext SLIT("Mismatched contexts") - -sigContextsCtxt s1 s2 +sigContextsCtxt sig1 sig2 = vcat [ptext SLIT("When matching the contexts of the signatures for"), - nest 2 (vcat [ppr s1 <+> dcolon <+> ppr (idType s1), - ppr s2 <+> dcolon <+> ppr (idType s2)]), + nest 2 (vcat [ppr id1 <+> dcolon <+> ppr (idType id1), + ppr id2 <+> dcolon <+> ppr (idType id2)]), ptext SLIT("The signature contexts in a mutually recursive group should all be identical")] + where + id1 = sig_id sig1 + id2 = sig_id sig2 + ----------------------------------------------- unliftedBindErr flavour mbind = hang (text flavour <+> ptext SLIT("bindings for unlifted types aren't allowed:")) 4 (ppr mbind) +badUnliftedSig sig + = hang (ptext SLIT("Illegal polymorphic signature in an unlifted binding")) + 4 (ppr sig) + ----------------------------------------------- -existentialExplode mbinds - = hang (vcat [text "My brain just exploded.", - text "I can't handle pattern bindings for existentially-quantified constructors.", - text "In the binding group"]) - 4 (ppr mbinds) +unboxedTupleErr name ty + = hang (ptext SLIT("Illegal binding of unboxed tuple")) + 4 (ppr name <+> dcolon <+> ppr ty) ----------------------------------------------- restrictedBindCtxtErr binder_names @@ -866,9 +1104,4 @@ restrictedBindCtxtErr binder_names genCtxt binder_names = ptext SLIT("When generalising the type(s) for") <+> pprBinders binder_names - --- Used in error messages --- Use quotes for a single one; they look a bit "busy" for several -pprBinders [bndr] = quotes (ppr bndr) -pprBinders bndrs = pprWithCommas ppr bndrs \end{code}