X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fiface%2FIfaceSyn.lhs;h=f6a5cadba66ddc0658efa765148fc9cc187080e7;hb=e04f49034968322349e0f3f608e1b5a856fd6521;hp=ad4c913df16364291e52ca378b277351c1613cb7;hpb=d33c0b24a0306cc57161b7ed7ff2510d0b017b11;p=ghc-hetmet.git diff --git a/compiler/iface/IfaceSyn.lhs b/compiler/iface/IfaceSyn.lhs index ad4c913..f6a5cad 100644 --- a/compiler/iface/IfaceSyn.lhs +++ b/compiler/iface/IfaceSyn.lhs @@ -39,6 +39,7 @@ import ForeignCall import BasicTypes import Outputable import FastString +import Module import Data.List import Data.Maybe @@ -77,14 +78,21 @@ data IfaceDecl -- current compilation unit ifFamInst :: Maybe (IfaceTyCon, [IfaceType]) -- Just <=> instance of family + -- Invariant: + -- ifCons /= IfOpenDataTyCon + -- for family instances } | IfaceSyn { ifName :: OccName, -- Type constructor ifTyVars :: [IfaceTvBndr], -- Type variables ifOpenSyn :: Bool, -- Is an open family? - ifSynRhs :: IfaceType -- Type for an ordinary + ifSynRhs :: IfaceType, -- Type for an ordinary -- synonym and kind for an -- open family + ifFamInst :: Maybe (IfaceTyCon, [IfaceType]) + -- Just <=> instance of family + -- Invariant: ifOpenSyn == False + -- for family instances } | IfaceClass { ifCtxt :: IfaceContext, -- Context... @@ -108,14 +116,12 @@ 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] @@ -203,6 +209,7 @@ data IfaceExpr | IfaceCast IfaceExpr IfaceCoercion | IfaceLit Literal | IfaceFCall ForeignCall IfaceType + | IfaceTick Module Int data IfaceNote = IfaceSCC CostCentre | IfaceInlineMe @@ -393,9 +400,10 @@ pprIfaceDecl (IfaceForeign {ifName = tycon}) = hsep [ptext SLIT("foreign import type dotnet"), ppr tycon] pprIfaceDecl (IfaceSyn {ifName = tycon, ifTyVars = tyvars, - ifOpenSyn = False, ifSynRhs = mono_ty}) + ifOpenSyn = False, ifSynRhs = mono_ty, + ifFamInst = mbFamInst}) = hang (ptext SLIT("type") <+> pprIfaceDeclHead [] tycon tyvars) - 4 (equals <+> ppr mono_ty) + 4 (vcat [equals <+> ppr mono_ty, pprFamily mbFamInst]) pprIfaceDecl (IfaceSyn {ifName = tycon, ifTyVars = tyvars, ifOpenSyn = True, ifSynRhs = mono_ty}) @@ -414,7 +422,6 @@ pprIfaceDecl (IfaceData {ifName = tycon, ifGeneric = gen, ifCtxt = context, 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, ifATs = ats, ifSigs = sigs, @@ -440,7 +447,6 @@ pprIfaceDeclHead context thing tyvars 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(" |")) @@ -516,6 +522,7 @@ pprIfaceExpr add_par (IfaceLcl v) = ppr v pprIfaceExpr add_par (IfaceExt v) = ppr v pprIfaceExpr add_par (IfaceLit l) = ppr l pprIfaceExpr add_par (IfaceFCall cc ty) = braces (ppr cc <+> ppr ty) +pprIfaceExpr add_par (IfaceTick m ix) = braces (text "tick" <+> ppr m <+> ppr ix) pprIfaceExpr add_par (IfaceType ty) = char '@' <+> pprParendIfaceType ty pprIfaceExpr add_par app@(IfaceApp _ _) = add_par (pprIfaceApp app []) @@ -716,14 +723,10 @@ 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 (fam1, tys1)) `eqIfTc_fam` (Just (fam2, tys2)) = - fam1 `eqIfTc` fam2 &&& eqListBy eqIfType tys1 tys2 - _ `eqIfTc_fam` _ = NotEqual eqIfDecl d1@(IfaceSyn {}) d2@(IfaceSyn {}) = bool (ifName d1 == ifName d2) &&& + ifFamInst d1 `eqIfTc_fam` ifFamInst d2 &&& eqWith (ifTyVars d1) (ifTyVars d2) (\ env -> eq_ifType env (ifSynRhs d1) (ifSynRhs d2) ) @@ -744,6 +747,15 @@ eqIfDecl _ _ = NotEqual -- default case eqWith :: [IfaceTvBndr] -> [IfaceTvBndr] -> (EqEnv -> IfaceEq) -> IfaceEq eqWith = eq_ifTvBndrs emptyEqEnv +eqIfTc_fam :: Maybe (IfaceTyCon, [IfaceType]) + -> Maybe (IfaceTyCon, [IfaceType]) + -> IfaceEq +Nothing `eqIfTc_fam` Nothing = Equal +(Just (fam1, tys1)) `eqIfTc_fam` (Just (fam2, tys2)) = + fam1 `eqIfTc` fam2 &&& eqListBy eqIfType tys1 tys2 +_ `eqIfTc_fam` _ = NotEqual + + ----------------------- eqIfInst d1 d2 = bool (ifDFun d1 == ifDFun d2 && ifOFlag d1 == ifOFlag d2) -- All other changes are handled via the version info on the dfun @@ -766,7 +778,6 @@ 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 @@ -807,6 +818,7 @@ eq_ifaceExpr env (IfaceLcl v1) (IfaceLcl v2) = eqIfOcc env v1 v2 eq_ifaceExpr env (IfaceExt v1) (IfaceExt v2) = eqIfExt v1 v2 eq_ifaceExpr env (IfaceLit l1) (IfaceLit l2) = bool (l1 == l2) eq_ifaceExpr env (IfaceFCall c1 ty1) (IfaceFCall c2 ty2) = bool (c1==c2) &&& eq_ifType env ty1 ty2 +eq_ifaceExpr env (IfaceTick m1 ix1) (IfaceTick m2 ix2) = bool (m1==m2) &&& bool (ix1 == ix2) eq_ifaceExpr env (IfaceType ty1) (IfaceType ty2) = eq_ifType env ty1 ty2 eq_ifaceExpr env (IfaceTuple n1 as1) (IfaceTuple n2 as2) = bool (n1==n2) &&& eqListBy (eq_ifaceExpr env) as1 as2 eq_ifaceExpr env (IfaceLam b1 body1) (IfaceLam b2 body2) = eq_ifBndr env b1 b2 (\env -> eq_ifaceExpr env body1 body2)