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.                   **

11 files changed, 26 insertions, 47 deletions

diff --git a/compiler/hsSyn/HsDecls.lhs b/compiler/hsSyn/HsDecls.lhs
index bd2593f86f..37ab35a606 100644
--- 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 49235d9948..bea0de13f1 100644
--- 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 707de1cbf7..333d8084ce 100644
--- 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 ad4c913df1..5a18da3d92 100644
--- 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 811af49947..cca8ab57d7 100644
--- 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 0ee3e006e1..0dbf6eb6be 100644
--- 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 9ad9518819..cc348bd443 100644
--- 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 b7b4f0b87d..6d90eaa02f 100644
--- 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 98d7fcf24a..1a9a8813e5 100644
--- 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 34022db5eb..50e0f4c419 100644
--- 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 90ac71c8ab..85881b695e 100644
--- 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