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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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
      }