From: Manuel M T Chakravarty Date: Tue, 15 May 2007 08:14:21 +0000 (+0000) Subject: Iface representation of synonym family instances X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=8e325220e14e05e83fef46a195e7f05fe2d49433 Iface representation of synonym family instances ** This patch changes the interface file format. All libraries etc ** ** need to be compiled from scratch. ** --- diff --git a/compiler/iface/BinIface.hs b/compiler/iface/BinIface.hs index bea0de1..0ffd37d 100644 --- a/compiler/iface/BinIface.hs +++ b/compiler/iface/BinIface.hs @@ -1062,12 +1062,13 @@ instance Binary IfaceDecl where put_ bh a6 put_ bh a7 put_ bh a8 - put_ bh (IfaceSyn aq ar as at) = do + put_ bh (IfaceSyn a1 a2 a3 a4 a5) = do putByte bh 3 - put_ bh (occNameFS aq) - put_ bh ar - put_ bh as - put_ bh at + put_ bh (occNameFS a1) + put_ bh a2 + put_ bh a3 + put_ bh a4 + put_ bh a5 put_ bh (IfaceClass a1 a2 a3 a4 a5 a6 a7) = do putByte bh 4 put_ bh a1 @@ -1098,12 +1099,13 @@ instance Binary IfaceDecl where occ <- return $! mkOccNameFS tcName a1 return (IfaceData occ a2 a3 a4 a5 a6 a7 a8) 3 -> do - aq <- get bh - ar <- get bh - as <- get bh - at <- get bh - occ <- return $! mkOccNameFS tcName aq - return (IfaceSyn occ ar as at) + a1 <- get bh + a2 <- get bh + a3 <- get bh + a4 <- get bh + a5 <- get bh + occ <- return $! mkOccNameFS tcName a1 + return (IfaceSyn occ a2 a3 a4 a5) _ -> do a1 <- get bh a2 <- get bh diff --git a/compiler/iface/IfaceSyn.lhs b/compiler/iface/IfaceSyn.lhs index 5a18da3..1e9e00f 100644 --- a/compiler/iface/IfaceSyn.lhs +++ b/compiler/iface/IfaceSyn.lhs @@ -77,14 +77,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... @@ -391,9 +398,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}) @@ -712,14 +720,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) ) @@ -740,6 +744,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 diff --git a/compiler/iface/MkIface.lhs b/compiler/iface/MkIface.lhs index cca8ab5..4dd3c82 100644 --- a/compiler/iface/MkIface.lhs +++ b/compiler/iface/MkIface.lhs @@ -1070,10 +1070,12 @@ tyThingToIfaceDecl (AClass clas) tyThingToIfaceDecl (ATyCon tycon) | isSynTyCon tycon - = IfaceSyn { ifName = getOccName tycon, - ifTyVars = toIfaceTvBndrs tyvars, + = IfaceSyn { ifName = getOccName tycon, + ifTyVars = toIfaceTvBndrs tyvars, ifOpenSyn = syn_isOpen, - ifSynRhs = toIfaceType syn_tyki } + ifSynRhs = toIfaceType syn_tyki, + ifFamInst = famInstToIface (tyConFamInst_maybe tycon) + } | isAlgTyCon tycon = IfaceData { ifName = getOccName tycon, diff --git a/compiler/iface/TcIface.lhs b/compiler/iface/TcIface.lhs index 0dbf6eb..c887e02 100644 --- a/compiler/iface/TcIface.lhs +++ b/compiler/iface/TcIface.lhs @@ -383,14 +383,21 @@ tcIfaceDecl ignore_prags tcIfaceDecl ignore_prags (IfaceSyn {ifName = occ_name, ifTyVars = tv_bndrs, - ifOpenSyn = isOpen, ifSynRhs = rdr_rhs_ty}) + ifOpenSyn = isOpen, ifSynRhs = rdr_rhs_ty, + ifFamInst = mb_family}) = bindIfaceTyVars tv_bndrs $ \ tyvars -> do { tc_name <- lookupIfaceTop occ_name ; rhs_tyki <- tcIfaceType rdr_rhs_ty ; let rhs = if isOpen then OpenSynTyCon rhs_tyki Nothing else SynonymTyCon rhs_tyki - -- !!!TODO: read mb_family info from iface and pass as last argument - ; tycon <- buildSynTyCon tc_name tyvars rhs Nothing + ; famInst <- case mb_family of + Nothing -> return Nothing + Just (fam, tys) -> + do { famTyCon <- tcIfaceTyCon fam + ; insttys <- mapM tcIfaceType tys + ; return $ Just (famTyCon, insttys) + } + ; tycon <- buildSynTyCon tc_name tyvars rhs famInst ; return $ ATyCon tycon }