X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fiface%2FIfaceSyn.lhs;h=4ebebe09ff297a36c329f27439b178d89d8b1e73;hb=17434e5beb213f1e8971d1ce8ffbf40a0848bb3a;hp=330a6fc605812fa22134ae08b519222d0b743fe8;hpb=35bdec7ae3bc2d0d2d2821bd9145d3b53f0e44e8;p=ghc-hetmet.git diff --git a/compiler/iface/IfaceSyn.lhs b/compiler/iface/IfaceSyn.lhs index 330a6fc..4ebebe0 100644 --- a/compiler/iface/IfaceSyn.lhs +++ b/compiler/iface/IfaceSyn.lhs @@ -17,10 +17,10 @@ module IfaceSyn ( 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, @@ -39,7 +39,7 @@ 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 ) @@ -70,26 +70,38 @@ data IfaceDecl 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? } @@ -104,11 +116,15 @@ data IfaceClassOp = IfaceClassOp OccName DefMeth IfaceType 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] @@ -122,8 +138,9 @@ data IfaceConDecl 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 @@ -137,6 +154,16 @@ 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 { 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, @@ -229,40 +256,57 @@ pprIfaceDecl (IfaceId {ifName = var, ifType = ty, ifIdInfo = info}) 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)) @@ -306,6 +350,10 @@ instance Outputable IfaceInst where 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} @@ -336,21 +384,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 {"), @@ -426,6 +475,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 @@ -509,6 +563,7 @@ eqIfDecl d1@(IfaceData {}) d2@(IfaceData {}) 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) @@ -516,6 +571,12 @@ eqIfDecl d1@(IfaceData {}) d2@(IfaceData {}) -- 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) &&& @@ -529,6 +590,7 @@ eqIfDecl d1@(IfaceClass {}) d2@(IfaceClass {}) 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) ) @@ -556,6 +618,8 @@ eq_hsCD env (IfDataTyCon c1) (IfDataTyCon c2) 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 @@ -672,7 +736,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} ----------------------------------------------------------- @@ -686,7 +755,7 @@ type EqEnv = UniqFM FastString -- Tracks the mapping from L-variables to R-varia 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