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`
-- been compiled with
-- different flags to the
-- current compilation unit
- ifFamInst :: Maybe -- Just _ <=> instance of fam
- (IfaceTyCon, -- Family tycon
- [IfaceType]) -- Instance types
+ ifFamInst :: Maybe IfaceFamInst
+ -- Just <=> instance of family
}
| IfaceSyn { ifName :: OccName, -- Type constructor
-- 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,
pprGen True = ptext SLIT("Generics: yes")
pprGen False = ptext SLIT("Generics: no")
-pprFamily Nothing = ptext SLIT("FamilyInstance: none")
-pprFamily (Just (fam, tys)) = ptext SLIT("FamilyInstance:") <+>
- ppr fam <+> hsep (map ppr tys)
+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
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
-- over the constructors (any more), but they do scope
-- over the stupid context in the IfaceConDecls
where
- Nothing `eqIfTc_fam` Nothing = Equal
- (Just (fam1, tys1)) `eqIfTc_fam` (Just (fam2, tys2)) =
+ 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
+ _ `eqIfTc_fam` _ = NotEqual
eqIfDecl d1@(IfaceSyn {}) d2@(IfaceSyn {})
= bool (ifName d1 == ifName d2) &&&
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