IfaceDecl(..), IfaceClassOp(..), IfaceConDecl(..), IfaceConDecls(..),
IfaceExpr(..), IfaceAlt, IfaceNote(..),
IfaceBinding(..), IfaceConAlt(..), IfaceIdInfo(..),
- IfaceInfoItem(..), IfaceRule(..), IfaceInst(..),
+ IfaceInfoItem(..), IfaceRule(..), IfaceInst(..), IfaceFamInst(..),
-- Misc
- visibleIfConDecls,
+ visibleIfConDecls, extractIfFamInsts,
-- Equality
IfaceEq(..), (&&&), bool, eqListBy, eqMaybeBy,
import IfaceType
import NewDemand ( StrictSig, pprIfaceStrictSig )
-import TcType ( deNoteType )
import Class ( FunDep, DefMeth, pprFundeps )
import OccName ( OccName, parenSymOcc, occNameFS,
- OccSet, unionOccSets, unitOccSet )
+ OccSet, unionOccSets, unitOccSet, occSetElts )
import UniqFM ( UniqFM, emptyUFM, addToUFM, lookupUFM )
-import Name ( Name, NamedThing(..), nameOccName, isExternalName )
import CostCentre ( CostCentre, pprCostCentreCore )
import Literal ( Literal )
import ForeignCall ( ForeignCall )
import BasicTypes ( Arity, Activation(..), StrictnessMark, OverlapFlag,
- RecFlag(..), Boxity(..),
- isAlwaysActive, tupleParens )
+ RecFlag(..), Boxity(..), tupleParens )
import Outputable
import FastString
-import Maybes ( catMaybes )
-import Util ( lengthIs )
infixl 3 &&&
infix 4 `eqIfExt`, `eqIfIdInfo`, `eqIfType`
ifType :: IfaceType,
ifIdInfo :: IfaceIdInfo }
- | IfaceData { 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?
- ifGadtSyntax :: Bool, -- True <=> declared using GADT syntax
- ifGeneric :: Bool -- True <=> generic converter functions available
- } -- We need this for imported data decls, since the
- -- imported modules may have been compiled with
- -- different flags to the current compilation unit
-
- | IfaceSyn { ifName :: OccName, -- Type constructor
- ifTyVars :: [IfaceTvBndr], -- Type variables
- ifSynRhs :: IfaceType -- synonym expansion
+ ifGadtSyntax :: Bool, -- True <=> declared using
+ -- GADT syntax
+ ifGeneric :: Bool, -- True <=> generic converter
+ -- functions available
+ -- We need this for imported
+ -- data decls, since the
+ -- imported modules may have
+ -- been compiled with
+ -- different flags to the
+ -- current compilation unit
+ ifFamInst :: Maybe IfaceFamInst
+ -- Just <=> instance of family
+ }
+
+ | IfaceSyn { ifName :: OccName, -- Type constructor
+ ifTyVars :: [IfaceTvBndr], -- Type variables
+ ifOpenSyn :: Bool, -- Is an open family?
+ ifSynRhs :: IfaceType -- Type for an ordinary
+ -- synonym and kind for an
+ -- open family
}
| IfaceClass { ifCtxt :: IfaceContext, -- Context...
ifName :: OccName, -- Name of the class
ifTyVars :: [IfaceTvBndr], -- Type variables
ifFDs :: [FunDep FastString], -- Functional dependencies
+ ifATs :: [IfaceDecl], -- Associated type families
ifSigs :: [IfaceClassOp], -- Method signatures
ifRec :: RecFlag -- Is newtype/datatype associated with the class recursive?
}
data IfaceConDecls
= IfAbstractTyCon -- No info
+ | IfOpenDataTyCon -- Open data family
+ | IfOpenNewTyCon -- Open newtype family
| IfDataTyCon [IfaceConDecl] -- data type decls
| IfNewTyCon IfaceConDecl -- newtype decls
visibleIfConDecls :: IfaceConDecls -> [IfaceConDecl]
visibleIfConDecls IfAbstractTyCon = []
+visibleIfConDecls IfOpenDataTyCon = []
+visibleIfConDecls IfOpenNewTyCon = []
visibleIfConDecls (IfDataTyCon cs) = cs
visibleIfConDecls (IfNewTyCon c) = [c]
ifConCtxt :: IfaceContext, -- Non-stupid context
ifConArgTys :: [IfaceType], -- Arg types
ifConFields :: [OccName], -- ...ditto... (field labels)
- ifConStricts :: [StrictnessMark] } -- Empty (meaning all lazy), or 1-1 corresp with arg types
-
+ ifConStricts :: [StrictnessMark]} -- Empty (meaning all lazy),
+ -- or 1-1 corresp with arg tys
+
data IfaceInst
= IfaceInst { ifInstCls :: IfaceExtName, -- See comments with
ifInstTys :: [Maybe IfaceTyCon], -- the defn of Instance
-- If this instance decl is *used*, we'll record a usage on the dfun;
-- and if the head does not change it won't be used if it wasn't before
+data IfaceFamInst
+ = IfaceFamInst { ifFamInstTyCon :: IfaceTyCon -- Family tycon
+ , ifFamInstTys :: [IfaceType] -- Instance types
+ }
+
+extractIfFamInsts :: [IfaceDecl] -> [(IfaceFamInst, IfaceDecl)]
+extractIfFamInsts decls =
+ [(famInst, decl) | decl@IfaceData {ifFamInst = Just famInst} <- decls]
+ -- !!!TODO: we also need a similar case for synonyms
+
data IfaceRule
= IfaceRule {
ifRuleName :: RuleName,
| IfaceCoreNote String
type IfaceAlt = (IfaceConAlt, [FastString], IfaceExpr)
- -- Note: OccName, not IfaceBndr (and same with the case binder)
+ -- Note: FastString, not IfaceBndr (and same with the case binder)
-- We reconstruct the kind/type of the thing from the context
-- thus saving bulk in interface files
pprIfaceDecl (IfaceForeign {ifName = tycon})
= hsep [ptext SLIT("foreign import type dotnet"), ppr tycon]
-pprIfaceDecl (IfaceSyn {ifName = tycon, ifTyVars = tyvars, ifSynRhs = mono_ty})
+pprIfaceDecl (IfaceSyn {ifName = tycon, ifTyVars = tyvars,
+ ifOpenSyn = False, ifSynRhs = mono_ty})
= hang (ptext SLIT("type") <+> pprIfaceDeclHead [] tycon tyvars)
4 (equals <+> ppr mono_ty)
+pprIfaceDecl (IfaceSyn {ifName = tycon, ifTyVars = tyvars,
+ ifOpenSyn = True, ifSynRhs = mono_ty})
+ = hang (ptext SLIT("type family") <+> pprIfaceDeclHead [] tycon tyvars)
+ 4 (dcolon <+> ppr mono_ty)
+
pprIfaceDecl (IfaceData {ifName = tycon, ifGeneric = gen, ifCtxt = context,
ifTyVars = tyvars, ifCons = condecls,
- ifRec = isrec})
+ ifRec = isrec, ifFamInst = mbFamInst})
= hang (pp_nd <+> pprIfaceDeclHead context tycon tyvars)
- 4 (vcat [pprRec isrec, pprGen gen, pp_condecls tycon condecls])
+ 4 (vcat [pprRec isrec, pprGen gen, pp_condecls tycon condecls,
+ pprFamily mbFamInst])
where
pp_nd = case condecls of
IfAbstractTyCon -> ptext SLIT("data")
+ IfOpenDataTyCon -> ptext SLIT("data family")
IfDataTyCon _ -> ptext SLIT("data")
IfNewTyCon _ -> ptext SLIT("newtype")
+ IfOpenNewTyCon -> ptext SLIT("newtype family")
pprIfaceDecl (IfaceClass {ifCtxt = context, ifName = clas, ifTyVars = tyvars,
- ifFDs = fds, ifSigs = sigs, ifRec = isrec})
+ ifFDs = fds, ifATs = ats, ifSigs = sigs,
+ ifRec = isrec})
= hang (ptext SLIT("class") <+> pprIfaceDeclHead context clas tyvars <+> pprFundeps fds)
4 (vcat [pprRec isrec,
- sep (map ppr sigs)])
+ sep (map ppr ats),
+ sep (map ppr sigs)])
pprRec isrec = ptext SLIT("RecFlag") <+> ppr isrec
pprGen True = ptext SLIT("Generics: yes")
pprGen False = ptext SLIT("Generics: no")
+pprFamily Nothing = ptext SLIT("FamilyInstance: none")
+pprFamily (Just famInst) = ptext SLIT("FamilyInstance:") <+> ppr famInst
+
instance Outputable IfaceClassOp where
ppr (IfaceClassOp n dm ty) = ppr n <+> ppr dm <+> dcolon <+> ppr ty
pprIfaceDeclHead :: IfaceContext -> OccName -> [IfaceTvBndr] -> SDoc
-pprIfaceDeclHead context thing tyvars
- = hsep [pprIfaceContext context, parenSymOcc thing (ppr thing), pprIfaceTvBndrs tyvars]
+pprIfaceDeclHead context thing tyvars
+ = hsep [pprIfaceContext context, parenSymOcc thing (ppr thing),
+ pprIfaceTvBndrs tyvars]
pp_condecls tc IfAbstractTyCon = ptext SLIT("{- abstract -}")
+pp_condecls tc IfOpenNewTyCon = empty
pp_condecls tc (IfNewTyCon c) = equals <+> pprIfaceConDecl tc c
+pp_condecls tc IfOpenDataTyCon = empty
pp_condecls tc (IfDataTyCon cs) = equals <+> sep (punctuate (ptext SLIT(" |"))
(map (pprIfaceConDecl tc) cs))
where
ppr_mb Nothing = dot
ppr_mb (Just tc) = ppr tc
+
+instance Outputable IfaceFamInst where
+ ppr (IfaceFamInst {ifFamInstTyCon = tycon, ifFamInstTys = tys})
+ = ppr tycon <+> hsep (map ppr tys)
\end{code}
collect bs (IfaceLam b e) = collect (b:bs) e
collect bs e = (reverse bs, e)
--- 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")
+ = 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 '}'])
--- 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")
+ = 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 '}'])
-pprIfaceExpr add_par (IfaceCast expr co) = add_par (ptext SLIT("cast") <+> ppr expr <+> ppr co)
+pprIfaceExpr add_par (IfaceCast expr co)
+ = sep [pprIfaceExpr parens expr,
+ nest 2 (ptext SLIT("`cast`")),
+ pprParendIfaceType co]
pprIfaceExpr add_par (IfaceLet (IfaceNonRec b rhs) body)
= add_par (sep [ptext SLIT("let {"),
| NotEqual -- Definitely different
| EqBut OccSet -- The same provided these local things have not changed
+instance Outputable IfaceEq where
+ ppr Equal = ptext SLIT("Equal")
+ ppr NotEqual = ptext SLIT("NotEqual")
+ ppr (EqBut occset) = ptext SLIT("EqBut") <+> ppr (occSetElts occset)
+
bool :: Bool -> IfaceEq
bool True = Equal
bool False = NotEqual
ifRec d1 == ifRec d2 &&
ifGadtSyntax d1 == ifGadtSyntax d2 &&
ifGeneric d1 == ifGeneric d2) &&&
+ ifFamInst d1 `eqIfTc_fam` ifFamInst d2 &&&
eqWith (ifTyVars d1) (ifTyVars d2) (\ env ->
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
+ where
+ Nothing `eqIfTc_fam` Nothing = Equal
+ (Just (IfaceFamInst fam1 tys1))
+ `eqIfTc_fam` (Just (IfaceFamInst fam2 tys2)) =
+ fam1 `eqIfTc` fam2 &&& eqListBy eqIfType tys1 tys2
+ _ `eqIfTc_fam` _ = NotEqual
eqIfDecl d1@(IfaceSyn {}) d2@(IfaceSyn {})
= bool (ifName d1 == ifName d2) &&&
eqWith (ifTyVars d1) (ifTyVars d2) (\ env ->
eq_ifContext env (ifCtxt d1) (ifCtxt d2) &&&
eqListBy (eq_hsFD env) (ifFDs d1) (ifFDs d2) &&&
+ eqListBy eqIfDecl (ifATs d1) (ifATs d2) &&&
eqListBy (eq_cls_sig env) (ifSigs d1) (ifSigs d2)
)
eq_hsCD env (IfNewTyCon c1) (IfNewTyCon c2) = eq_ConDecl env c1 c2
eq_hsCD env IfAbstractTyCon IfAbstractTyCon = Equal
+eq_hsCD env IfOpenDataTyCon IfOpenDataTyCon = Equal
+eq_hsCD env IfOpenNewTyCon IfOpenNewTyCon = Equal
eq_hsCD env d1 d2 = NotEqual
eq_ConDecl env c1 c2
eqIfTc IfaceListTc IfaceListTc = Equal
eqIfTc IfacePArrTc IfacePArrTc = Equal
eqIfTc (IfaceTupTc bx1 ar1) (IfaceTupTc bx2 ar2) = bool (bx1==bx2 && ar1==ar2)
-eqIfTc _ _ = NotEqual
+eqIfTc IfaceLiftedTypeKindTc IfaceLiftedTypeKindTc = Equal
+eqIfTc IfaceOpenTypeKindTc IfaceOpenTypeKindTc = Equal
+eqIfTc IfaceUnliftedTypeKindTc IfaceUnliftedTypeKindTc = Equal
+eqIfTc IfaceUbxTupleKindTc IfaceUbxTupleKindTc = Equal
+eqIfTc IfaceArgTypeKindTc IfaceArgTypeKindTc = Equal
+eqIfTc _ _ = NotEqual
\end{code}
-----------------------------------------------------------
eqIfOcc :: EqEnv -> FastString -> FastString -> IfaceEq
eqIfOcc env n1 n2 = case lookupUFM env n1 of
Just n1 -> bool (n1 == n2)
- Nothing -> bool (n1 == n2)
+ Nothing -> bool (show n1 == show n2)
extendEqEnv :: EqEnv -> FastString -> FastString -> EqEnv
extendEqEnv env n1 n2 | n1 == n2 = env
projects / ghc-hetmet.git / blobdiff