X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fiface%2FIfaceSyn.lhs;h=99501a5b68f0f385de6c4f930908f8f0dfe52c7c;hb=ac10f8408520a30e8437496d320b8b86afda2e8f;hp=5fbf8edf2363ed4a1e690ed8f32fd61d2c9b5362;hpb=7032166d34b8769c8ae6f40d9f1e6d346c3376bd;p=ghc-hetmet.git diff --git a/ghc/compiler/iface/IfaceSyn.lhs b/ghc/compiler/iface/IfaceSyn.lhs index 5fbf8ed..99501a5 100644 --- a/ghc/compiler/iface/IfaceSyn.lhs +++ b/ghc/compiler/iface/IfaceSyn.lhs @@ -23,14 +23,14 @@ module IfaceSyn ( visibleIfConDecls, -- Converting things to IfaceSyn - tyThingToIfaceDecl, dfunToIfaceInst, coreRuleToIfaceRule, + tyThingToIfaceDecl, instanceToIfaceInst, coreRuleToIfaceRule, -- Equality IfaceEq(..), (&&&), bool, eqListBy, eqMaybeBy, eqIfDecl, eqIfInst, eqIfRule, -- Pretty printing - pprIfaceExpr, pprIfaceDecl + pprIfaceExpr, pprIfaceDecl, pprIfaceDeclHead ) where #include "HsVersions.h" @@ -40,29 +40,26 @@ import IfaceType import FunDeps ( pprFundeps ) import NewDemand ( StrictSig, pprIfaceStrictSig ) -import TcType ( deNoteType, mkSigmaTy, tcSplitDFunTy, mkClassPred ) -import Type ( TyThing(..), mkForAllTys, mkFunTys, splitForAllTys, funResultTy, - mkTyVarTys, mkTyConApp, mkTyVarTys, mkPredTy, tidyTopType ) -import InstEnv ( DFunId ) +import TcType ( deNoteType ) +import Type ( TyThing(..), splitForAllTys, funResultTy ) +import InstEnv ( Instance(..), OverlapFlag ) import Id ( Id, idName, idType, idInfo, idArity, isDataConWorkId_maybe, isFCallId_maybe ) import NewDemand ( isTopSig ) import IdInfo ( IdInfo, CafInfo(..), WorkerInfo(..), arityInfo, cafInfo, newStrictnessInfo, workerInfo, unfoldingInfo, inlinePragInfo ) import TyCon ( TyCon, ArgVrcs, AlgTyConRhs(..), isRecursiveTyCon, isForeignTyCon, - isSynTyCon, isNewTyCon, isAlgTyCon, isPrimTyCon, isFunTyCon, - isTupleTyCon, tupleTyConBoxity, - tyConHasGenerics, tyConArgVrcs, tyConTheta, getSynTyConDefn, + isSynTyCon, isAlgTyCon, isPrimTyCon, isFunTyCon, + isTupleTyCon, tupleTyConBoxity, tyConStupidTheta, + tyConHasGenerics, tyConArgVrcs, synTyConRhs, tyConArity, tyConTyVars, algTyConRhs, tyConExtName ) import DataCon ( dataConName, dataConSig, dataConFieldLabels, dataConStrictMarks, - dataConTyCon ) + dataConTyCon, dataConIsInfix, isVanillaDataCon ) import Class ( FunDep, DefMeth, classExtraBigSig, classTyCon ) -import OccName ( OccName, OccEnv, lookupOccEnv, emptyOccEnv, - lookupOccEnv, extendOccEnv, emptyOccEnv, +import OccName ( OccName, OccEnv, emptyOccEnv, + lookupOccEnv, extendOccEnv, parenSymOcc, OccSet, unionOccSets, unitOccSet ) -import Name ( Name, NamedThing(..), getOccName, nameOccName, nameModuleName, isExternalName ) -import NameSet ( NameSet, elemNameSet ) -import Module ( ModuleName ) +import Name ( Name, NamedThing(..), nameOccName, isExternalName ) import CostCentre ( CostCentre, pprCostCentreCore ) import Literal ( Literal ) import ForeignCall ( ForeignCall ) @@ -92,9 +89,9 @@ data IfaceDecl ifType :: IfaceType, ifIdInfo :: IfaceIdInfo } - | IfaceData { ifCtxt :: IfaceContext, -- Context - ifName :: OccName, -- Type constructor + | IfaceData { ifName :: OccName, -- Type constructor ifTyVars :: [IfaceTvBndr], -- Type variables + ifCtxt :: IfaceContext, -- The "stupid theta" ifCons :: IfaceConDecls, -- Includes new/data info ifRec :: RecFlag, -- Recursive or not? ifVrcs :: ArgVrcs, @@ -109,16 +106,16 @@ data IfaceDecl ifSynRhs :: IfaceType -- synonym expansion } - | IfaceClass { ifCtxt :: IfaceContext, -- Context... - ifName :: OccName, -- Name of the class - ifTyVars :: [IfaceTvBndr], -- Type variables - ifFDs :: [FunDep OccName], -- Functional dependencies - ifSigs :: [IfaceClassOp], -- Method signatures - ifRec :: RecFlag, -- Is newtype/datatype associated with the class recursive? - ifVrcs :: ArgVrcs -- ... and what are its argument variances ... + | IfaceClass { ifCtxt :: IfaceContext, -- Context... + ifName :: OccName, -- Name of the class + ifTyVars :: [IfaceTvBndr], -- Type variables + ifFDs :: [FunDep OccName], -- Functional dependencies + ifSigs :: [IfaceClassOp], -- Method signatures + ifRec :: RecFlag, -- Is newtype/datatype associated with the class recursive? + ifVrcs :: ArgVrcs -- ... and what are its argument variances ... } - | IfaceForeign { ifName :: OccName, -- Needs expanding when we move beyond .NET + | IfaceForeign { ifName :: OccName, -- Needs expanding when we move beyond .NET ifExtName :: Maybe FastString } data IfaceClassOp = IfaceClassOp OccName DefMeth IfaceType @@ -137,16 +134,26 @@ visibleIfConDecls (IfDataTyCon cs) = cs visibleIfConDecls (IfNewTyCon c) = [c] data IfaceConDecl - = IfaceConDecl OccName -- Constructor name - [IfaceTvBndr] -- Existental tyvars - IfaceContext -- Existential context - [IfaceType] -- Arg types - [StrictnessMark] -- Empty (meaning all lazy), or 1-1 corresp with arg types - [OccName] -- ...ditto... (field labels) + = IfVanillaCon { + ifConOcc :: OccName, -- Constructor name + ifConInfix :: Bool, -- True <=> declared infix + ifConArgTys :: [IfaceType], -- Arg types + ifConStricts :: [StrictnessMark], -- Empty (meaning all lazy), or 1-1 corresp with arg types + ifConFields :: [OccName] } -- ...ditto... (field labels) + | IfGadtCon { + ifConOcc :: OccName, -- Constructor name + ifConTyVars :: [IfaceTvBndr], -- All tyvars + ifConCtxt :: IfaceContext, -- Non-stupid context + ifConArgTys :: [IfaceType], -- Arg types + ifConResTys :: [IfaceType], -- Result type args + ifConStricts :: [StrictnessMark] } -- Empty (meaning all lazy), or 1-1 corresp with arg types -data IfaceInst = IfaceInst { ifInstHead :: IfaceType, -- Just the instance head type, quantified - -- so that it'll compare alpha-wise - ifDFun :: OccName } -- And the dfun +data IfaceInst + = IfaceInst { ifInstCls :: IfaceExtName, -- See comments with + ifInstTys :: [Maybe IfaceTyCon], -- the defn of Instance + ifDFun :: OccName, -- The dfun + ifOFlag :: OverlapFlag, -- Overlap flag + ifInstOrph :: Maybe OccName } -- See is_orph in defn of Instance -- There's always a separate IfaceDecl for the DFun, which gives -- its IdInfo with its full type and version number. -- The instance declarations taken together have a version number, @@ -158,13 +165,12 @@ data IfaceRule = IfaceRule { ifRuleName :: RuleName, ifActivation :: Activation, - ifRuleBndrs :: [IfaceBndr], -- Tyvars and term vars - ifRuleHead :: IfaceExtName, -- Head of lhs - ifRuleArgs :: [IfaceExpr], -- Args of LHS - ifRuleRhs :: IfaceExpr + ifRuleBndrs :: [IfaceBndr], -- Tyvars and term vars + ifRuleHead :: IfaceExtName, -- Head of lhs + ifRuleArgs :: [IfaceExpr], -- Args of LHS + ifRuleRhs :: IfaceExpr, + ifRuleOrph :: Maybe OccName -- Just like IfaceInst } - | IfaceBuiltinRule IfaceExtName CoreRule -- So that built-in rules can - -- wait in the RulePol data IfaceIdInfo = NoInfo -- When writing interface file without -O @@ -200,7 +206,7 @@ data IfaceExpr | IfaceTuple Boxity [IfaceExpr] -- Saturated; type arguments omitted | IfaceLam IfaceBndr IfaceExpr | IfaceApp IfaceExpr IfaceExpr - | IfaceCase IfaceExpr OccName [IfaceAlt] + | IfaceCase IfaceExpr OccName IfaceType [IfaceAlt] | IfaceLet IfaceBinding IfaceExpr | IfaceNote IfaceNote IfaceExpr | IfaceLit Literal @@ -248,23 +254,24 @@ pprIfaceDecl (IfaceForeign {ifName = tycon}) = hsep [ptext SLIT("foreign import type dotnet"), ppr tycon] pprIfaceDecl (IfaceSyn {ifName = tycon, ifTyVars = tyvars, ifSynRhs = mono_ty, ifVrcs = vrcs}) - = hang (ptext SLIT("type") <+> pp_decl_head [] tycon tyvars) + = hang (ptext SLIT("type") <+> pprIfaceDeclHead [] tycon tyvars) 4 (vcat [equals <+> ppr mono_ty, pprVrcs vrcs]) -pprIfaceDecl (IfaceData {ifCtxt = context, ifName = tycon, ifGeneric = gen, - ifTyVars = tyvars, ifCons = condecls, ifRec = isrec, ifVrcs = vrcs}) - = hang (pp_nd <+> pp_decl_head context tycon tyvars) - 4 (vcat [pprVrcs vrcs, pprRec isrec, pprGen gen, pp_condecls condecls]) +pprIfaceDecl (IfaceData {ifName = tycon, ifGeneric = gen, ifCtxt = context, + ifTyVars = tyvars, ifCons = condecls, + ifRec = isrec, ifVrcs = vrcs}) + = hang (pp_nd <+> pprIfaceDeclHead context tycon tyvars) + 4 (vcat [pprVrcs vrcs, pprRec isrec, pprGen gen, pp_condecls tycon condecls]) where pp_nd = case condecls of IfAbstractTyCon -> ptext SLIT("data") IfDataTyCon _ -> ptext SLIT("data") - IfNewTyCon _ -> ptext SLIT("newtype") + IfNewTyCon _ -> ptext SLIT("newtype") pprIfaceDecl (IfaceClass {ifCtxt = context, ifName = clas, ifTyVars = tyvars, ifFDs = fds, ifSigs = sigs, ifVrcs = vrcs, ifRec = isrec}) - = hang (ptext SLIT("class") <+> pp_decl_head context clas tyvars <+> pprFundeps fds) + = hang (ptext SLIT("class") <+> pprIfaceDeclHead context clas tyvars <+> pprFundeps fds) 4 (vcat [pprVrcs vrcs, pprRec isrec, sep (map ppr sigs)]) @@ -277,37 +284,57 @@ pprGen False = ptext SLIT("Generics: no") instance Outputable IfaceClassOp where ppr (IfaceClassOp n dm ty) = ppr n <+> ppr dm <+> dcolon <+> ppr ty -pp_decl_head :: IfaceContext -> OccName -> [IfaceTvBndr] -> SDoc -pp_decl_head context thing tyvars - = hsep [pprIfaceContext context, ppr thing, pprIfaceTvBndrs tyvars] - -pp_condecls IfAbstractTyCon = ptext SLIT("{- abstract -}") -pp_condecls (IfDataTyCon cs) = equals <+> sep (punctuate (ptext SLIT(" |")) (map ppr cs)) -pp_condecls (IfNewTyCon c) = equals <+> ppr c - -instance Outputable IfaceConDecl where - ppr (IfaceConDecl name ex_tvs ex_ctxt arg_tys strs fields) - = pprIfaceForAllPart ex_tvs ex_ctxt $ - sep [ppr name <+> sep (map pprParendIfaceType arg_tys), +pprIfaceDeclHead :: IfaceContext -> OccName -> [IfaceTvBndr] -> SDoc +pprIfaceDeclHead context thing tyvars + = hsep [pprIfaceContext context, parenSymOcc thing (ppr thing), pprIfaceTvBndrs tyvars] + +pp_condecls tc IfAbstractTyCon = ptext SLIT("{- abstract -}") +pp_condecls tc (IfNewTyCon c) = equals <+> pprIfaceConDecl tc c +pp_condecls tc (IfDataTyCon cs) = equals <+> sep (punctuate (ptext SLIT(" |")) + (map (pprIfaceConDecl tc) cs)) + +pprIfaceConDecl tc (IfVanillaCon { + ifConOcc = name, ifConInfix = is_infix, + ifConArgTys = arg_tys, + ifConStricts = strs, ifConFields = fields }) + = sep [ppr name <+> sep (map pprParendIfaceType arg_tys), + if is_infix then ptext SLIT("Infix") else empty, if null strs then empty else nest 4 (ptext SLIT("Stricts:") <+> hsep (map ppr strs)), if null fields then empty else nest 4 (ptext SLIT("Fields:") <+> hsep (map ppr fields))] +pprIfaceConDecl tc (IfGadtCon { + ifConOcc = name, + ifConTyVars = tvs, ifConCtxt = ctxt, + ifConArgTys = arg_tys, ifConResTys = res_tys, + ifConStricts = strs }) + = sep [ppr name <+> dcolon <+> pprIfaceForAllPart tvs ctxt (ppr con_tau), + if null strs then empty + else nest 4 (ptext SLIT("Stricts:") <+> hsep (map ppr strs))] + where + con_tau = foldr1 IfaceFunTy (arg_tys ++ [tc_app]) + tc_app = IfaceTyConApp (IfaceTc (LocalTop tc)) res_tys + -- Gruesome, but jsut for debug print + instance Outputable IfaceRule where - ppr (IfaceRule name act bndrs fn args rhs) + ppr (IfaceRule { ifRuleName = name, ifActivation = act, ifRuleBndrs = bndrs, + ifRuleHead = fn, ifRuleArgs = args, ifRuleRhs = rhs }) = sep [hsep [doubleQuotes (ftext name), ppr act, ptext SLIT("forall") <+> pprIfaceBndrs bndrs], nest 2 (sep [ppr fn <+> sep (map (pprIfaceExpr parens) args), ptext SLIT("=") <+> ppr rhs]) ] - ppr (IfaceBuiltinRule name rule) - = ptext SLIT("Built-in rule for") <+> ppr name instance Outputable IfaceInst where - ppr (IfaceInst {ifDFun = dfun_id, ifInstHead = ty}) - = hang (ptext SLIT("instance") <+> ppr ty) + ppr (IfaceInst {ifDFun = dfun_id, ifOFlag = flag, + ifInstCls = cls, ifInstTys = mb_tcs}) + = hang (ptext SLIT("instance") <+> ppr flag + <+> ppr cls <+> brackets (pprWithCommas ppr_mb mb_tcs)) 2 (equals <+> ppr dfun_id) + where + ppr_mb Nothing = dot + ppr_mb (Just tc) = ppr tc \end{code} @@ -338,13 +365,17 @@ pprIfaceExpr add_par e@(IfaceLam _ _) collect bs (IfaceLam b e) = collect (b:bs) e collect bs e = (reverse bs, e) -pprIfaceExpr add_par (IfaceCase scrut bndr [(con, bs, rhs)]) - = add_par (sep [ptext SLIT("case") <+> pprIfaceExpr noParens scrut <+> ptext SLIT("of") +-- gaw 2004 +pprIfaceExpr add_par (IfaceCase scrut bndr ty [(con, bs, rhs)]) +-- gaw 2004 + = add_par (sep [ptext SLIT("case") <+> char '@' <+> pprParendIfaceType ty <+> pprIfaceExpr noParens scrut <+> ptext SLIT("of") <+> ppr bndr <+> char '{' <+> ppr_con_bs con bs <+> arrow, pprIfaceExpr noParens rhs <+> char '}']) -pprIfaceExpr add_par (IfaceCase scrut bndr alts) - = add_par (sep [ptext SLIT("case") <+> pprIfaceExpr noParens scrut <+> ptext SLIT("of") +-- gaw 2004 +pprIfaceExpr add_par (IfaceCase scrut bndr ty alts) +-- gaw 2004 + = add_par (sep [ptext SLIT("case") <+> char '@' <+> pprParendIfaceType ty <+> pprIfaceExpr noParens scrut <+> ptext SLIT("of") <+> ppr bndr <+> char '{', nest 2 (sep (map ppr_alt alts)) <+> char '}']) @@ -384,9 +415,10 @@ instance Outputable IfaceNote where ppr (IfaceCoreNote s) = ptext SLIT("__core_note") <+> pprHsString (mkFastString s) instance Outputable IfaceConAlt where - ppr IfaceDefault = text "DEFAULT" - ppr (IfaceLitAlt l) = ppr l - ppr (IfaceDataAlt d) = ppr d + ppr IfaceDefault = text "DEFAULT" + ppr (IfaceLitAlt l) = ppr l + ppr (IfaceDataAlt d) = ppr d + ppr (IfaceTupleAlt b) = panic "ppr IfaceConAlt" -- IfaceTupleAlt is handled by the case-alternative printer ------------------ @@ -411,18 +443,21 @@ ppr_hs_info (HsWorker w a) = ptext SLIT("Worker:") <+> ppr w <+> int a \begin{code} -tyThingToIfaceDecl :: Bool - -> NameSet -- Tycons and classes to export abstractly - -> (Name -> IfaceExtName) -> TyThing -> IfaceDecl -tyThingToIfaceDecl discard_id_info _ ext (AnId id) +tyThingToIfaceDecl :: (Name -> IfaceExtName) -> TyThing -> IfaceDecl +-- Assumption: the thing is already tidied, so that locally-bound names +-- (lambdas, for-alls) already have non-clashing OccNames +-- Reason: Iface stuff uses OccNames, and the conversion here does +-- not do tidying on the way +tyThingToIfaceDecl ext (AnId id) = IfaceId { ifName = getOccName id, ifType = toIfaceType ext (idType id), ifIdInfo = info } where - info | discard_id_info = NoInfo - | otherwise = HasInfo (toIfaceIdInfo ext (idInfo id)) + info = case toIfaceIdInfo ext (idInfo id) of + [] -> NoInfo + items -> HasInfo items -tyThingToIfaceDecl _ _ ext (AClass clas) +tyThingToIfaceDecl ext (AClass clas) = IfaceClass { ifCtxt = toIfaceContext ext sc_theta, ifName = getOccName clas, ifTyVars = toIfaceTvBndrs clas_tyvars, @@ -448,7 +483,7 @@ tyThingToIfaceDecl _ _ ext (AClass clas) toIfaceFD (tvs1, tvs2) = (map getOccName tvs1, map getOccName tvs2) -tyThingToIfaceDecl _ abstract_tcs ext (ATyCon tycon) +tyThingToIfaceDecl ext (ATyCon tycon) | isSynTyCon tycon = IfaceSyn { ifName = getOccName tycon, ifTyVars = toIfaceTvBndrs tyvars, @@ -456,9 +491,9 @@ tyThingToIfaceDecl _ abstract_tcs ext (ATyCon tycon) ifSynRhs = toIfaceType ext syn_ty } | isAlgTyCon tycon - = IfaceData { ifCtxt = toIfaceContext ext (tyConTheta tycon), - ifName = getOccName tycon, + = IfaceData { ifName = getOccName tycon, ifTyVars = toIfaceTvBndrs tyvars, + ifCtxt = toIfaceContext ext (tyConStupidTheta tycon), ifCons = ifaceConDecls (algTyConRhs tycon), ifRec = boolToRecFlag (isRecursiveTyCon tycon), ifVrcs = tyConArgVrcs tycon, @@ -470,75 +505,63 @@ tyThingToIfaceDecl _ abstract_tcs ext (ATyCon tycon) | isPrimTyCon tycon || isFunTyCon tycon -- Needed in GHCi for ':info Int#', for example - = IfaceData { ifCtxt = [], - ifName = getOccName tycon, - ifTyVars = toIfaceTvBndrs (take (tyConArity tycon) alphaTyVars), - ifCons = IfAbstractTyCon, - ifGeneric = False, - ifRec = NonRecursive, - ifVrcs = tyConArgVrcs tycon } + = IfaceData { ifName = getOccName tycon, + ifTyVars = toIfaceTvBndrs (take (tyConArity tycon) alphaTyVars), + ifCtxt = [], + ifCons = IfAbstractTyCon, + ifGeneric = False, + ifRec = NonRecursive, + ifVrcs = tyConArgVrcs tycon } | otherwise = pprPanic "toIfaceDecl" (ppr tycon) where - tyvars = tyConTyVars tycon - (_, syn_ty) = getSynTyConDefn tycon - abstract = getName tycon `elemNameSet` abstract_tcs + tyvars = tyConTyVars tycon + syn_ty = synTyConRhs tycon - ifaceConDecls _ | abstract = IfAbstractTyCon - ifaceConDecls (NewTyCon con _ _) = IfNewTyCon (ifaceConDecl con) - ifaceConDecls (DataTyCon cons _) = IfDataTyCon (map ifaceConDecl cons) - ifaceConDecls AbstractTyCon = pprPanic "ifaceConDecls" (ppr tycon) - -- We're exporting this thing, so it's locally defined and should not be abstract + ifaceConDecls (NewTyCon { data_con = con }) = IfNewTyCon (ifaceConDecl con) + ifaceConDecls (DataTyCon { data_cons = cons }) = IfDataTyCon (map ifaceConDecl cons) + ifaceConDecls AbstractTyCon = IfAbstractTyCon + -- The last case happens when a TyCon has been trimmed during tidying + -- Furthermore, tyThingToIfaceDecl is also used + -- in TcRnDriver for GHCi, when browsing a module, in which case the + -- AbstractTyCon case is perfectly sensible. ifaceConDecl data_con - = IfaceConDecl (getOccName (dataConName data_con)) - (toIfaceTvBndrs ex_tyvars) - (toIfaceContext ext ex_theta) - (map (toIfaceType ext) arg_tys) - strict_marks - (map getOccName field_labels) + | isVanillaDataCon data_con + = IfVanillaCon {ifConOcc = getOccName (dataConName data_con), + ifConInfix = dataConIsInfix data_con, + ifConArgTys = map (toIfaceType ext) arg_tys, + ifConStricts = strict_marks, + ifConFields = map getOccName field_labels } + | otherwise + = IfGadtCon { ifConOcc = getOccName (dataConName data_con), + ifConTyVars = toIfaceTvBndrs tyvars, + ifConCtxt = toIfaceContext ext theta, + ifConArgTys = map (toIfaceType ext) arg_tys, + ifConResTys = map (toIfaceType ext) res_tys, + ifConStricts = strict_marks } where - (_, _, ex_tyvars, ex_theta, arg_tys, _) = dataConSig data_con + (tyvars, theta, arg_tys, _, res_tys) = dataConSig data_con field_labels = dataConFieldLabels data_con strict_marks = dataConStrictMarks data_con - -- This case only happens in the call to ifaceThing in InteractiveUI - -- Otherwise DataCons are filtered out in ifaceThing_acc -tyThingToIfaceDecl _ _ ext (ADataCon dc) - = IfaceId { ifName = getOccName dc, - ifType = toIfaceType ext full_ty, - ifIdInfo = NoInfo } - where - (tvs, stupid_theta, ex_tvs, ex_theta, arg_tys, tycon) = dataConSig dc - - -- The "stupid context" isn't part of the wrapper-Id type - -- (for better or worse -- see note in DataCon.lhs), so we - -- have to make it up here - full_ty = mkSigmaTy (tvs ++ ex_tvs) (stupid_theta ++ ex_theta) - (mkFunTys arg_tys (mkTyConApp tycon (mkTyVarTys tvs))) +tyThingToIfaceDecl ext (ADataCon dc) + = pprPanic "toIfaceDecl" (ppr dc) -- Should be trimmed out earlier + -------------------------- -dfunToIfaceInst :: ModuleName -> DFunId -> IfaceInst -dfunToIfaceInst mod dfun_id - = IfaceInst { ifDFun = getOccName dfun_id, - ifInstHead = toIfaceType (mkLhsNameFn mod) tidy_ty } +instanceToIfaceInst :: (Name -> IfaceExtName) -> Instance -> IfaceInst +instanceToIfaceInst ext_lhs ispec@(Instance { is_dfun = dfun_id, is_flag = oflag, + is_cls = cls, is_tcs = mb_tcs, + is_orph = orph }) + = IfaceInst { ifDFun = getOccName dfun_id, + ifOFlag = oflag, + ifInstCls = ext_lhs cls, + ifInstTys = map do_rough mb_tcs, + ifInstOrph = orph } where - (tvs, _, cls, tys) = tcSplitDFunTy (idType dfun_id) - head_ty = mkForAllTys tvs (mkPredTy (mkClassPred cls tys)) - -- No need to record the instance context; - -- it's in the dfun anyway - - tidy_ty = tidyTopType (deNoteType head_ty) - -- The deNoteType is very important. It removes all type - -- synonyms from the instance type in interface files. - -- That in turn makes sure that when reading in instance decls - -- from interface files that the 'gating' mechanism works properly. - -- Otherwise you could have - -- type Tibble = T Int - -- instance Foo Tibble where ... - -- and this instance decl wouldn't get imported into a module - -- that mentioned T but not Tibble. - + do_rough Nothing = Nothing + do_rough (Just n) = Just (toIfaceTyCon_name ext_lhs n) -------------------------- toIfaceIdInfo :: (Name -> IfaceExtName) -> IdInfo -> [IfaceInfoItem] @@ -581,21 +604,35 @@ toIfaceIdInfo ext id_info | otherwise = Just (HsUnfold inline_prag (toIfaceExpr ext rhs)) -------------------------- -coreRuleToIfaceRule :: ModuleName -> (Name -> IfaceExtName) -> IdCoreRule -> IfaceRule -coreRuleToIfaceRule mod ext (id, BuiltinRule _ _) - = pprTrace "toHsRule: builtin" (ppr id) (bogusIfaceRule (mkIfaceExtName (getName id))) - -coreRuleToIfaceRule mod ext (id, Rule name act bndrs args rhs) - = IfaceRule { ifRuleName = name, ifActivation = act, - ifRuleBndrs = map (toIfaceBndr ext) bndrs, - ifRuleHead = ext (idName id), - ifRuleArgs = map (toIfaceExpr (mkLhsNameFn mod)) args, - -- Use LHS name-fn for the args - ifRuleRhs = toIfaceExpr ext rhs } +coreRuleToIfaceRule :: (Name -> IfaceExtName) -- For the LHS names + -> (Name -> IfaceExtName) -- For the RHS names + -> CoreRule -> IfaceRule +coreRuleToIfaceRule ext_lhs ext_rhs (BuiltinRule { ru_fn = fn}) + = pprTrace "toHsRule: builtin" (ppr fn) $ + bogusIfaceRule (mkIfaceExtName fn) + +coreRuleToIfaceRule ext_lhs ext_rhs + (Rule { ru_name = name, ru_fn = fn, ru_act = act, ru_bndrs = bndrs, + ru_args = args, ru_rhs = rhs, ru_orph = orph }) + = IfaceRule { ifRuleName = name, ifActivation = act, + ifRuleBndrs = map (toIfaceBndr ext_lhs) bndrs, + ifRuleHead = ext_lhs fn, + ifRuleArgs = map do_arg args, + ifRuleRhs = toIfaceExpr ext_rhs rhs, + ifRuleOrph = orph } + where + -- For type args we must remove synonyms from the outermost + -- level. Reason: so that when we read it back in we'll + -- construct the same ru_rough field as we have right now; + -- see tcIfaceRule + do_arg (Type ty) = IfaceType (toIfaceType ext_lhs (deNoteType ty)) + do_arg arg = toIfaceExpr ext_lhs arg bogusIfaceRule :: IfaceExtName -> IfaceRule bogusIfaceRule id_name - = IfaceRule FSLIT("bogus") NeverActive [] id_name [] (IfaceExt id_name) + = IfaceRule { ifRuleName = FSLIT("bogus"), ifActivation = NeverActive, + ifRuleBndrs = [], ifRuleHead = id_name, ifRuleArgs = [], + ifRuleRhs = IfaceExt id_name, ifRuleOrph = Nothing } --------------------- toIfaceExpr :: (Name -> IfaceExtName) -> CoreExpr -> IfaceExpr @@ -604,7 +641,8 @@ toIfaceExpr ext (Lit l) = IfaceLit l toIfaceExpr ext (Type ty) = IfaceType (toIfaceType ext ty) toIfaceExpr ext (Lam x b) = IfaceLam (toIfaceBndr ext x) (toIfaceExpr ext b) toIfaceExpr ext (App f a) = toIfaceApp ext f [a] -toIfaceExpr ext (Case s x as) = IfaceCase (toIfaceExpr ext s) (getOccName x) (map (toIfaceAlt ext) as) +-- gaw 2004 +toIfaceExpr ext (Case s x ty as) = IfaceCase (toIfaceExpr ext s) (getOccName x) (toIfaceType ext ty) (map (toIfaceAlt ext) as) toIfaceExpr ext (Let b e) = IfaceLet (toIfaceBind ext b) (toIfaceExpr ext e) toIfaceExpr ext (Note n e) = IfaceNote (toIfaceNote ext n) (toIfaceExpr ext e) @@ -659,18 +697,6 @@ toIfaceVar ext v | otherwise = IfaceLcl (nameOccName name) where name = idName v - ---------------------- --- mkLhsNameFn ignores versioning info altogether --- Used for the LHS of instance decls and rules, where we --- there's no point in recording version info -mkLhsNameFn :: ModuleName -> Name -> IfaceExtName -mkLhsNameFn this_mod name - | mod == this_mod = LocalTop occ - | otherwise = ExtPkg mod occ - where - mod = nameModuleName name - occ = nameOccName name \end{code} @@ -735,9 +761,12 @@ eqIfDecl d1@(IfaceData {}) d2@(IfaceData {}) ifVrcs d1 == ifVrcs d2 && ifGeneric d1 == ifGeneric d2) &&& eqWith (ifTyVars d1) (ifTyVars d2) (\ env -> - eq_ifContext env (ifCtxt d1) (ifCtxt d2) &&& - eq_hsCD env (ifCons d1) (ifCons d2) + eq_ifContext env (ifCtxt d1) (ifCtxt d2) &&& + eq_hsCD env (ifCons d1) (ifCons d2) ) + -- The type variables of the data type do not scope + -- over the constructors (any more), but they do scope + -- over the stupid context in the IfaceConDecls eqIfDecl d1@(IfaceSyn {}) d2@(IfaceSyn {}) = bool (ifName d1 == ifName d2) &&& @@ -762,31 +791,41 @@ eqWith :: [IfaceTvBndr] -> [IfaceTvBndr] -> (EqEnv -> IfaceEq) -> IfaceEq eqWith = eq_ifTvBndrs emptyEqEnv ----------------------- -eqIfInst d1 d2 = bool (ifDFun d1 == ifDFun d2) &&& - zapEq (ifInstHead d1 `eqIfType` ifInstHead d2) - -- zapEq: for instances, ignore the EqBut part +eqIfInst d1 d2 = bool (ifDFun d1 == ifDFun d2) +-- All other changes are handled via the version info on the dfun -eqIfRule (IfaceRule n1 a1 bs1 f1 es1 rhs1) - (IfaceRule n2 a2 bs2 f2 es2 rhs2) - = bool (n1==n2 && a1==a2) &&& +eqIfRule (IfaceRule n1 a1 bs1 f1 es1 rhs1 o1) + (IfaceRule n2 a2 bs2 f2 es2 rhs2 o2) + = bool (n1==n2 && a1==a2 && o1 == o2) &&& f1 `eqIfExt` f2 &&& eq_ifBndrs emptyEqEnv bs1 bs2 (\env -> zapEq (eqListBy (eq_ifaceExpr env) es1 es2) &&& -- zapEq: for the LHSs, ignore the EqBut part eq_ifaceExpr env rhs1 rhs2) -eqIfRule _ _ = NotEqual -eq_hsCD env (IfDataTyCon c1) (IfDataTyCon c2) = eqListBy (eq_ConDecl env) c1 c2 +eq_hsCD env (IfDataTyCon c1) (IfDataTyCon c2) + = eqListBy (eq_ConDecl env) c1 c2 + eq_hsCD env (IfNewTyCon c1) (IfNewTyCon c2) = eq_ConDecl env c1 c2 eq_hsCD env IfAbstractTyCon IfAbstractTyCon = Equal eq_hsCD env d1 d2 = NotEqual -eq_ConDecl env (IfaceConDecl n1 tvs1 cxt1 args1 ss1 lbls1) - (IfaceConDecl n2 tvs2 cxt2 args2 ss2 lbls2) - = bool (n1 == n2 && ss1 == ss2 && lbls1 == lbls2) &&& - eq_ifTvBndrs env tvs1 tvs2 (\ env -> - eq_ifContext env cxt1 cxt2 &&& - eq_ifTypes env args1 args2) +eq_ConDecl env c1@(IfVanillaCon {}) c2@(IfVanillaCon {}) + = bool (ifConOcc c1 == ifConOcc c2 && + ifConInfix c1 == ifConInfix c2 && + ifConStricts c1 == ifConStricts c2 && + ifConFields c1 == ifConFields c2) &&& + eq_ifTypes env (ifConArgTys c1) (ifConArgTys c2) + +eq_ConDecl env c1@(IfGadtCon {}) c2@(IfGadtCon {}) + = bool (ifConOcc c1 == ifConOcc c2 && + ifConStricts c1 == ifConStricts c2) &&& + eq_ifTvBndrs env (ifConTyVars c1) (ifConTyVars c2) (\ env -> + eq_ifContext env (ifConCtxt c1) (ifConCtxt c2) &&& + eq_ifTypes env (ifConResTys c1) (ifConResTys c2) &&& + eq_ifTypes env (ifConArgTys c1) (ifConArgTys c2)) + +eq_ConDecl env c1 c2 = NotEqual eq_hsFD env (ns1,ms1) (ns2,ms2) = eqListBy (eqIfOcc env) ns1 ns2 &&& eqListBy (eqIfOcc env) ms1 ms2 @@ -821,8 +860,9 @@ eq_ifaceExpr env (IfaceLam b1 body1) (IfaceLam b2 body2) = eq_ifBndr env b1 b2 eq_ifaceExpr env (IfaceApp f1 a1) (IfaceApp f2 a2) = eq_ifaceExpr env f1 f2 &&& eq_ifaceExpr env a1 a2 eq_ifaceExpr env (IfaceNote n1 r1) (IfaceNote n2 r2) = eq_ifaceNote env n1 n2 &&& eq_ifaceExpr env r1 r2 -eq_ifaceExpr env (IfaceCase s1 b1 as1) (IfaceCase s2 b2 as2) +eq_ifaceExpr env (IfaceCase s1 b1 ty1 as1) (IfaceCase s2 b2 ty2 as2) = eq_ifaceExpr env s1 s2 &&& + eq_ifType env ty1 ty2 &&& eq_ifNakedBndr env b1 b2 (\env -> eqListBy (eq_ifaceAlt env) as1 as2) where eq_ifaceAlt env (c1,bs1,r1) (c2,bs2,r2)