Remove the distinction between data and newtype families

- This patch removes "newtype family" declarations.
- "newtype instance" declarations can now be instances of data families
- This also fixes bug #1331

  ** This patch changes the interface format.  All libraries and all of **
  ** Stage 2 & 3 need to be re-compiled from scratch.                   **

diff --git a/compiler/hsSyn/HsDecls.lhs b/compiler/hsSyn/HsDecls.lhs
index bd2593f..37ab35a 100644 (file)
--- a/compiler/hsSyn/HsDecls.lhs
+++ b/compiler/hsSyn/HsDecls.lhs
@@ -440,7 +440,7 @@ data NewOrData
 
 data FamilyFlavour
   = TypeFamily                 -- "type family ..."
-  | DataFamily NewOrData       -- "newtype family ..." or "data family ..."
+  | DataFamily                 -- "data family ..."
 \end{code}
 
 Simple classifiers
@@ -536,9 +536,8 @@ instance OutputableBndr name
       = pp_flavour <+> pp_decl_head [] ltycon tyvars Nothing <+> pp_kind
         where
          pp_flavour = case flavour of
-                        TypeFamily          -> ptext SLIT("type family")
-                        DataFamily NewType  -> ptext SLIT("newtype family")
-                        DataFamily DataType -> ptext SLIT("data family")
+                        TypeFamily -> ptext SLIT("type family")
+                        DataFamily -> ptext SLIT("data family")
 
           pp_kind = case mb_kind of
                      Nothing   -> empty

diff --git a/compiler/iface/BinIface.hs b/compiler/iface/BinIface.hs
index 49235d9..bea0de1 100644 (file)
--- a/compiler/iface/BinIface.hs
+++ b/compiler/iface/BinIface.hs
@@ -1152,18 +1152,16 @@ instance Binary OverlapFlag where
 instance Binary IfaceConDecls where
     put_ bh IfAbstractTyCon = putByte bh 0
     put_ bh IfOpenDataTyCon = putByte bh 1
-    put_ bh IfOpenNewTyCon = putByte bh 2
-    put_ bh (IfDataTyCon cs) = do { putByte bh 3
+    put_ bh (IfDataTyCon cs) = do { putByte bh 2
                                  ; put_ bh cs }
-    put_ bh (IfNewTyCon c)  = do { putByte bh 4
+    put_ bh (IfNewTyCon c)  = do { putByte bh 3
                                  ; put_ bh c }
     get bh = do
            h <- getByte bh
            case h of
              0 -> return IfAbstractTyCon
              1 -> return IfOpenDataTyCon
-             2 -> return IfOpenNewTyCon
-             3 -> do cs <- get bh
+             2 -> do cs <- get bh
                      return (IfDataTyCon cs)
              _ -> do aa <- get bh
                      return (IfNewTyCon aa)

diff --git a/compiler/iface/BuildTyCl.lhs b/compiler/iface/BuildTyCl.lhs
index 707de1c..333d808 100644 (file)
--- a/compiler/iface/BuildTyCl.lhs
+++ b/compiler/iface/BuildTyCl.lhs
@@ -7,7 +7,7 @@
 module BuildTyCl (
        buildSynTyCon, buildAlgTyCon, buildDataCon,
        buildClass,
-       mkAbstractTyConRhs, mkOpenDataTyConRhs, mkOpenNewTyConRhs,
+       mkAbstractTyConRhs, mkOpenDataTyConRhs, 
        mkNewTyConRhs, mkDataTyConRhs 
     ) where
 
@@ -115,10 +115,7 @@ mkAbstractTyConRhs :: AlgTyConRhs
 mkAbstractTyConRhs = AbstractTyCon
 
 mkOpenDataTyConRhs :: AlgTyConRhs
-mkOpenDataTyConRhs = OpenTyCon Nothing False
-
-mkOpenNewTyConRhs :: AlgTyConRhs
-mkOpenNewTyConRhs = OpenTyCon Nothing True
+mkOpenDataTyConRhs = OpenTyCon Nothing
 
 mkDataTyConRhs :: [DataCon] -> AlgTyConRhs
 mkDataTyConRhs cons

diff --git a/compiler/iface/IfaceSyn.lhs b/compiler/iface/IfaceSyn.lhs
index ad4c913..5a18da3 100644 (file)
--- a/compiler/iface/IfaceSyn.lhs
+++ b/compiler/iface/IfaceSyn.lhs
@@ -108,14 +108,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]
 
@@ -414,7 +412,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 +437,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(" |"))
@@ -766,7 +762,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

diff --git a/compiler/iface/MkIface.lhs b/compiler/iface/MkIface.lhs
index 811af49..cca8ab5 100644 (file)
--- a/compiler/iface/MkIface.lhs
+++ b/compiler/iface/MkIface.lhs
@@ -1100,8 +1100,7 @@ tyThingToIfaceDecl (ATyCon tycon)
       IfNewTyCon  (ifaceConDecl con)
     ifaceConDecls (DataTyCon { data_cons = cons })  = 
       IfDataTyCon (map ifaceConDecl cons)
-    ifaceConDecls OpenTyCon { otIsNewtype = False } = IfOpenDataTyCon
-    ifaceConDecls OpenTyCon { otIsNewtype = True  } = IfOpenNewTyCon
+    ifaceConDecls OpenTyCon {}                      = IfOpenDataTyCon
     ifaceConDecls AbstractTyCon                            = IfAbstractTyCon
        -- The last case happens when a TyCon has been trimmed during tidying
        -- Furthermore, tyThingToIfaceDecl is also used

diff --git a/compiler/iface/TcIface.lhs b/compiler/iface/TcIface.lhs
index 0ee3e00..0dbf6eb 100644 (file)
--- a/compiler/iface/TcIface.lhs
+++ b/compiler/iface/TcIface.lhs
@@ -447,7 +447,6 @@ tcIfaceDataCons tycon_name tycon tc_tyvars if_cons
   = case if_cons of
        IfAbstractTyCon  -> return mkAbstractTyConRhs
        IfOpenDataTyCon  -> return mkOpenDataTyConRhs
-       IfOpenNewTyCon   -> return mkOpenNewTyConRhs
        IfDataTyCon cons -> do  { data_cons <- mappM tc_con_decl cons
                                ; return (mkDataTyConRhs data_cons) }
        IfNewTyCon con   -> do  { data_con <- tc_con_decl con

diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp
index 9ad9518..cc348bd 100644 (file)
--- a/compiler/parser/Parser.y.pp
+++ b/compiler/parser/Parser.y.pp
@@ -618,7 +618,7 @@ ty_decl :: { LTyClDecl RdrName }
                              (unLoc $3) (reverse (unLoc $5)) (unLoc $6)) } }
 
           -- data/newtype family
-        | data_or_newtype 'family' tycl_hdr opt_kind_sig
+        | 'data' 'family' tycl_hdr opt_kind_sig
                {% do { let {(ctxt, tc, tvs, tparms) = unLoc $3}
                       ; checkTyVars tparms            -- no type pattern
                      ; unless (null (unLoc ctxt)) $  -- and no context
@@ -626,8 +626,7 @@ ty_decl :: { LTyClDecl RdrName }
                            "A family declaration cannot have a context"
                      ; return $
                          L (comb3 $1 $2 $4)
-                           (TyFamily (DataFamily (unLoc $1)) tc tvs 
-                                     (unLoc $4)) } }
+                           (TyFamily DataFamily tc tvs (unLoc $4)) } }
 
           -- data/newtype instance declaration
        | data_or_newtype 'instance' tycl_hdr constrs deriving
@@ -682,7 +681,7 @@ at_decl_cls :: { LTyClDecl RdrName }
                       } }
 
           -- data/newtype family declaration
-        | data_or_newtype tycl_hdr opt_kind_sig
+        | 'data' tycl_hdr opt_kind_sig
                {% do { let {(ctxt, tc, tvs, tparms) = unLoc $2}
                       ; checkTyVars tparms            -- no type pattern
                      ; unless (null (unLoc ctxt)) $  -- and no context
@@ -690,8 +689,7 @@ at_decl_cls :: { LTyClDecl RdrName }
                            "A family declaration cannot have a context"
                      ; return $
                          L (comb3 $1 $2 $3)
-                           (TyFamily (DataFamily (unLoc $1)) tc tvs
-                                     (unLoc $3)) 
+                           (TyFamily DataFamily tc tvs (unLoc $3)) 
                       } }
 
 -- Associate type instances

diff --git a/compiler/rename/RnSource.lhs b/compiler/rename/RnSource.lhs
index b7b4f0b..6d90eaa 100644 (file)
--- a/compiler/rename/RnSource.lhs
+++ b/compiler/rename/RnSource.lhs
@@ -797,8 +797,8 @@ rnFamily (tydecl@TyFamily {tcdFlavour = flavour,
                    emptyFVs) 
          } }
       where
-        isDataFlavour (DataFamily _) = True
-       isDataFlavour _              = False
+        isDataFlavour DataFamily = True
+       isDataFlavour _          = False
 
 family_doc tycon = text "In the family declaration for" <+> quotes (ppr tycon)
 needOneIdx = text "Type family declarations requires at least one type index"

diff --git a/compiler/typecheck/TcDeriv.lhs b/compiler/typecheck/TcDeriv.lhs
index 98d7fcf..1a9a881 100644 (file)
--- a/compiler/typecheck/TcDeriv.lhs
+++ b/compiler/typecheck/TcDeriv.lhs
@@ -399,7 +399,10 @@ mkEqnHelp orig tvs cls cls_tys tc_app
 
        ; gla_exts <- doptM Opt_GlasgowExts
        ; overlap_flag <- getOverlapFlag
-       ; if isDataTyCon tycon then
+
+          -- Be careful to test rep_tc here: in the case of families, we want
+          -- to check the instance tycon, not the family tycon
+       ; if isDataTyCon rep_tc then
                mkDataTypeEqn orig gla_exts full_tvs cls cls_tys 
                              tycon full_tc_args rep_tc rep_tc_args
          else

diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs
index 34022db..50e0f4c 100644 (file)
--- a/compiler/typecheck/TcTyClsDecls.lhs
+++ b/compiler/typecheck/TcTyClsDecls.lhs
@@ -280,8 +280,7 @@ tcFamInstDecl1 (decl@TyData {tcdND = new_or_data, tcdLName = L loc tc_name,
                             tcdCons = cons})
   = kcIdxTyPats decl $ \k_tvs k_typats resKind family ->
     do { -- check that the family declaration is for the right kind
-        unless (new_or_data == NewType  && isNewTyCon  family ||
-                new_or_data == DataType && isDataTyCon family) $
+        unless (isAlgTyCon family) $
           addErr (wrongKindOfFamily family)
 
        ; -- (1) kind check the data declaration as usual
@@ -630,10 +629,10 @@ tcTyClDecl1 _calc_isrec
 
   -- "newtype family" or "data family" declaration
 tcTyClDecl1 _calc_isrec 
-  (TyFamily {tcdFlavour = DataFamily new_or_data, 
+  (TyFamily {tcdFlavour = DataFamily, 
             tcdLName = L _ tc_name, tcdTyVars = tvs, tcdKind = mb_kind})
   = tcTyVarBndrs tvs  $ \ tvs' -> do 
-  { traceTc (text "data/newtype family: " <+> ppr tc_name) 
+  { traceTc (text "data family: " <+> ppr tc_name) 
   ; extra_tvs <- tcDataKindSig mb_kind
   ; let final_tvs = tvs' ++ extra_tvs    -- we may not need these
 
@@ -643,10 +642,7 @@ tcTyClDecl1 _calc_isrec
   ; checkTc idx_tys $ badFamInstDecl tc_name
 
   ; tycon <- buildAlgTyCon tc_name final_tvs [] 
-              (case new_or_data of
-                 DataType -> mkOpenDataTyConRhs
-                 NewType  -> mkOpenNewTyConRhs)
-              Recursive False True Nothing
+              mkOpenDataTyConRhs Recursive False True Nothing
   ; return [ATyCon tycon]
   }
 
@@ -1194,9 +1190,8 @@ wrongKindOfFamily family =
   ptext SLIT("Wrong category of family instance; declaration was for a") <+>
   kindOfFamily
   where
-    kindOfFamily | isSynTyCon  family = ptext SLIT("type synonym")
-                | isDataTyCon family = ptext SLIT("data type")
-                | isNewTyCon  family = ptext SLIT("newtype")
+    kindOfFamily | isSynTyCon family = ptext SLIT("type synonym")
+                | isAlgTyCon family = ptext SLIT("data type")
                 | otherwise = pprPanic "wrongKindOfFamily" (ppr family)
 
 emptyConDeclsErr tycon

diff --git a/compiler/types/TyCon.lhs b/compiler/types/TyCon.lhs
index 90ac71c..85881b6 100644 (file)
--- a/compiler/types/TyCon.lhs
+++ b/compiler/types/TyCon.lhs
@@ -213,16 +213,13 @@ data AlgTyConRhs
 
   | OpenTyCon {
 
-      otArgPoss   :: Maybe [Int],  
+      otArgPoss   :: Maybe [Int]
        -- Nothing <=> top-level indexed type family
        -- Just ns <=> associated (not toplevel) family
        --   In the latter case, for each tyvar in the AT decl, 'ns' gives the
        --   position of that tyvar in the class argument list (starting from 0).
        --   NB: Length is less than tyConArity iff higher kind signature.
        
-      otIsNewtype :: Bool           
-        -- is a newtype (rather than data type)?
-
     }
 
   | DataTyCon {
@@ -633,7 +630,6 @@ isDataTyCon other = False
 isNewTyCon :: TyCon -> Bool
 isNewTyCon (AlgTyCon {algTcRhs = rhs}) = 
   case rhs of
-    OpenTyCon {} -> otIsNewtype rhs
     NewTyCon {}  -> True
     _           -> False
 isNewTyCon other                      = False