X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fiface%2FIfaceSyn.lhs;h=8ac4eecc87644a8be398ec02f20667ac237b3a32;hb=2a8cdc3aee5997374273e27365f92c161aca8453;hp=bf620950a01c626ca105e08c95be2e1a91fe3b4b;hpb=909d2dd885f5eebaf7c12cf15d5ac153d646566e;p=ghc-hetmet.git diff --git a/compiler/iface/IfaceSyn.lhs b/compiler/iface/IfaceSyn.lhs index bf62095..8ac4eec 100644 --- a/compiler/iface/IfaceSyn.lhs +++ b/compiler/iface/IfaceSyn.lhs @@ -17,7 +17,7 @@ module IfaceSyn ( IfaceDecl(..), IfaceClassOp(..), IfaceConDecl(..), IfaceConDecls(..), IfaceExpr(..), IfaceAlt, IfaceNote(..), IfaceBinding(..), IfaceConAlt(..), IfaceIdInfo(..), - IfaceInfoItem(..), IfaceRule(..), IfaceInst(..), + IfaceInfoItem(..), IfaceRule(..), IfaceInst(..), IfaceFamInst(..), -- Misc visibleIfConDecls, @@ -36,22 +36,17 @@ import CoreSyn 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` @@ -85,9 +80,8 @@ data IfaceDecl -- been compiled with -- different flags to the -- current compilation unit - ifFamInst :: Maybe -- Just _ <=> instance of fam - (IfaceTyCon, -- Family tycon - [IfaceType]) -- Instance types + ifFamInst :: Maybe (IfaceTyCon, [IfaceType]) + -- Just <=> instance of family } | IfaceSyn { ifName :: OccName, -- Type constructor @@ -155,6 +149,12 @@ data IfaceInst -- 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 { ifFamInstFam :: IfaceExtName -- Family tycon + , ifFamInstTys :: [Maybe IfaceTyCon] -- Rough match types + , ifFamInstTyCon :: IfaceTyCon -- Instance decl + } + data IfaceRule = IfaceRule { ifRuleName :: RuleName, @@ -283,9 +283,8 @@ 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 (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 @@ -322,7 +321,7 @@ pprIfaceConDecl tc con_tau = foldr1 IfaceFunTy (arg_tys ++ [tc_app]) tc_app = IfaceTyConApp (IfaceTc (LocalTop tc)) [IfaceTyVar tv | (tv,_) <- univ_tvs] - -- Gruesome, but jsut for debug print + -- Gruesome, but just for debug print instance Outputable IfaceRule where ppr (IfaceRule { ifRuleName = name, ifActivation = act, ifRuleBndrs = bndrs, @@ -337,11 +336,19 @@ instance Outputable IfaceInst where 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)) + <+> ppr cls <+> brackets (pprWithCommas ppr_rough mb_tcs)) 2 (equals <+> ppr dfun_id) - where - ppr_mb Nothing = dot - ppr_mb (Just tc) = ppr tc + +instance Outputable IfaceFamInst where + ppr (IfaceFamInst {ifFamInstFam = fam, ifFamInstTys = mb_tcs, + ifFamInstTyCon = tycon_id}) + = hang (ptext SLIT("family instance") <+> + ppr fam <+> brackets (pprWithCommas ppr_rough mb_tcs)) + 2 (equals <+> ppr tycon_id) + +ppr_rough :: Maybe IfaceTyCon -> SDoc +ppr_rough Nothing = dot +ppr_rough (Just tc) = ppr tc \end{code} @@ -372,21 +379,22 @@ pprIfaceExpr add_par e@(IfaceLam _ _) 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 {"), @@ -462,6 +470,11 @@ data IfaceEq | 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 @@ -717,7 +730,12 @@ eqIfTc IfaceBoolTc IfaceBoolTc = Equal 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} -----------------------------------------------------------