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"
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 )
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,
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
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,
= 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
| 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
= 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)])
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}
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 '}'])
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
------------------
\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,
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,
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,
| 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]
| 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
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)
| 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}
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) &&&
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
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)
projects / ghc-hetmet.git / blobdiff