Merge branch 'master' of http://darcs.haskell.org/ghc

Conflicts:
	compiler/basicTypes/MkId.lhs
	compiler/iface/IfaceSyn.lhs

3 files changed, 354 insertions, 257 deletions

diff --git a/compiler/hsSyn/Convert.lhs b/compiler/hsSyn/Convert.lhs
index d7ad1132ec..c5a92f8b28 100644
--- a/compiler/hsSyn/Convert.lhs
+++ b/compiler/hsSyn/Convert.lhs
@@ -156,36 +156,39 @@ cvtDec (PragmaD prag)
 cvtDec (TySynD tc tvs rhs)
   = do  { (_, tc', tvs') <- cvt_tycl_hdr [] tc tvs
         ; rhs' <- cvtType rhs
-        ; returnL $ TyClD (TyDecl { tcdLName = tc'
+        ; returnL $ TyClD (SynDecl { tcdLName = tc'
                                   , tcdTyVars = tvs', tcdFVs = placeHolderNames
-                                  , tcdTyDefn = TySynonym rhs' }) }
+                                  , tcdRhs = rhs' }) }
 
 cvtDec (DataD ctxt tc tvs constrs derivs)
   = do  { (ctxt', tc', tvs') <- cvt_tycl_hdr ctxt tc tvs
         ; cons' <- mapM cvtConstr constrs
         ; derivs' <- cvtDerivs derivs
-       ; let defn = TyData { td_ND = DataType, td_cType = Nothing
-                           , td_ctxt = ctxt'
-                           , td_kindSig = Nothing
-                           , td_cons = cons', td_derivs = derivs' }
-        ; returnL $ TyClD (TyDecl { tcdLName = tc', tcdTyVars = tvs'
-                                  , tcdTyDefn = defn, tcdFVs = placeHolderNames }) }
+        ; let defn = HsDataDefn { dd_ND = DataType, dd_cType = Nothing
+                                , dd_ctxt = ctxt'
+                                , dd_kindSig = Nothing
+                                , dd_cons = cons', dd_derivs = derivs' }
+        ; returnL $ TyClD (DataDecl { tcdLName = tc', tcdTyVars = tvs'
+                                    , tcdDataDefn = defn, tcdFVs = placeHolderNames }) }
 
 cvtDec (NewtypeD ctxt tc tvs constr derivs)
   = do  { (ctxt', tc', tvs') <- cvt_tycl_hdr ctxt tc tvs
         ; con' <- cvtConstr constr
         ; derivs' <- cvtDerivs derivs
-        ; let defn = TyData { td_ND = NewType, td_cType = Nothing
-                            , td_ctxt = ctxt'
-                            , td_kindSig = Nothing
-                            , td_cons = [con'], td_derivs = derivs' }
-        ; returnL $ TyClD (TyDecl { tcdLName = tc', tcdTyVars = tvs'
-                                  , tcdTyDefn = defn, tcdFVs = placeHolderNames }) }
+        ; let defn = HsDataDefn { dd_ND = NewType, dd_cType = Nothing
+                                , dd_ctxt = ctxt'
+                                , dd_kindSig = Nothing
+                                , dd_cons = [con'], dd_derivs = derivs' }
+        ; returnL $ TyClD (DataDecl { tcdLName = tc', tcdTyVars = tvs'
+                                    , tcdDataDefn = defn, tcdFVs = placeHolderNames }) }
 
 cvtDec (ClassD ctxt cl tvs fds decs)
   = do  { (cxt', tc', tvs') <- cvt_tycl_hdr ctxt cl tvs
         ; fds'  <- mapM cvt_fundep fds
-        ; (binds', sigs', fams', ats') <- cvt_ci_decs (ptext (sLit "a class declaration")) decs
+        ; (binds', sigs', fams', ats', adts') <- cvt_ci_decs (ptext (sLit "a class declaration")) decs
+        ; unless (null adts')
+            (failWith $ (ptext (sLit "Default data instance declarations are not allowed:"))
+                   $$ (Outputable.ppr adts'))
         ; returnL $ TyClD $
           ClassDecl { tcdCtxt = cxt', tcdLName = tc', tcdTyVars = tvs'
                     , tcdFDs = fds', tcdSigs = sigs', tcdMeths = binds'
@@ -196,12 +199,12 @@ cvtDec (ClassD ctxt cl tvs fds decs)
 
 cvtDec (InstanceD ctxt ty decs)
   = do  { let doc = ptext (sLit "an instance declaration")
-        ; (binds', sigs', fams', ats') <- cvt_ci_decs doc decs
+        ; (binds', sigs', fams', ats', adts') <- cvt_ci_decs doc decs
         ; unless (null fams') (failWith (mkBadDecMsg doc fams'))
         ; ctxt' <- cvtContext ctxt
         ; L loc ty' <- cvtType ty
         ; let inst_ty' = L loc $ mkImplicitHsForAllTy ctxt' $ L loc ty'
-        ; returnL $ InstD (ClsInstD inst_ty' binds' sigs' ats') }
+        ; returnL $ InstD (ClsInstD (ClsInstDecl inst_ty' binds' sigs' ats' adts')) }
 
 cvtDec (ForeignD ford)
   = do { ford' <- cvtForD ford
@@ -210,7 +213,7 @@ cvtDec (ForeignD ford)
 cvtDec (FamilyD flav tc tvs kind)
   = do { (_, tc', tvs') <- cvt_tycl_hdr [] tc tvs
        ; kind' <- cvtMaybeKind kind
-       ; returnL $ TyClD (TyFamily (cvtFamFlavour flav) tc' tvs' kind') }
+       ; returnL $ TyClD (FamDecl (FamilyDecl (cvtFamFlavour flav) tc' tvs' kind')) }
   where
     cvtFamFlavour TypeFam = TypeFamily
     cvtFamFlavour DataFam = DataFamily
@@ -219,50 +222,61 @@ cvtDec (DataInstD ctxt tc tys constrs derivs)
   = do { (ctxt', tc', typats') <- cvt_tyinst_hdr ctxt tc tys
        ; cons' <- mapM cvtConstr constrs
        ; derivs' <- cvtDerivs derivs
-       ; let defn = TyData { td_ND = DataType, td_cType = Nothing
-                           , td_ctxt = ctxt'
-                           , td_kindSig = Nothing
-                           , td_cons = cons', td_derivs = derivs' }
+       ; let defn = HsDataDefn { dd_ND = DataType, dd_cType = Nothing
+                               , dd_ctxt = ctxt'
+                               , dd_kindSig = Nothing
+                               , dd_cons = cons', dd_derivs = derivs' }
 
-       ; returnL $ InstD $ FamInstD
-           { lid_inst = FamInstDecl { fid_tycon = tc', fid_pats = typats'
-                                    , fid_defn = defn, fid_fvs = placeHolderNames } }}
+       ; returnL $ InstD $ DataFamInstD
+           { dfid_inst = DataFamInstDecl { dfid_tycon = tc', dfid_pats = typats'
+                                         , dfid_defn = defn, dfid_fvs = placeHolderNames } }}
 
 cvtDec (NewtypeInstD ctxt tc tys constr derivs)
   = do { (ctxt', tc', typats') <- cvt_tyinst_hdr ctxt tc tys
        ; con' <- cvtConstr constr
        ; derivs' <- cvtDerivs derivs
-       ; let defn = TyData { td_ND = NewType, td_cType = Nothing
-                           , td_ctxt = ctxt'
-                           , td_kindSig = Nothing
-                           , td_cons = [con'], td_derivs = derivs' }
-       ; returnL $ InstD $ FamInstD
-           { lid_inst = FamInstDecl { fid_tycon = tc', fid_pats = typats'
-                                    , fid_defn = defn, fid_fvs = placeHolderNames } } }
-
-cvtDec (TySynInstD tc tys rhs)
-  = do  { (_, tc', tys') <- cvt_tyinst_hdr [] tc tys
+       ; let defn = HsDataDefn { dd_ND = NewType, dd_cType = Nothing
+                               , dd_ctxt = ctxt'
+                               , dd_kindSig = Nothing
+                               , dd_cons = [con'], dd_derivs = derivs' }
+       ; returnL $ InstD $ DataFamInstD
+           { dfid_inst = DataFamInstDecl { dfid_tycon = tc', dfid_pats = typats'
+                                         , dfid_defn = defn, dfid_fvs = placeHolderNames } }}
+
+cvtDec (TySynInstD tc eqns)
+  = do  { tc' <- tconNameL tc
+        ; eqns' <- mapM (cvtTySynEqn tc') eqns
+        ; returnL $ InstD $ TyFamInstD
+            { tfid_inst = TyFamInstDecl { tfid_eqns = eqns'
+                                        , tfid_group = (length eqns' /= 1)
+                                        , tfid_fvs = placeHolderNames } } }
+----------------
+cvtTySynEqn :: Located RdrName -> TySynEqn -> CvtM (LTyFamInstEqn RdrName)
+cvtTySynEqn tc (TySynEqn lhs rhs)
+  = do  { lhs' <- mapM cvtType lhs
         ; rhs' <- cvtType rhs
-        ; returnL $ InstD $ FamInstD
-            { lid_inst = FamInstDecl { fid_tycon = tc', fid_pats = tys'
-                                     , fid_defn = TySynonym rhs', fid_fvs = placeHolderNames } } }
+        ; returnL $ TyFamInstEqn { tfie_tycon = tc
+                                 , tfie_pats = mkHsWithBndrs lhs'
+                                 , tfie_rhs = rhs' } }
 
 ----------------
 cvt_ci_decs :: MsgDoc -> [TH.Dec]
             -> CvtM (LHsBinds RdrName,
                      [LSig RdrName],
-                     [LTyClDecl RdrName],    -- Family decls
-                     [LFamInstDecl RdrName])
+                     [LFamilyDecl RdrName],
+                     [LTyFamInstDecl RdrName],
+                     [LDataFamInstDecl RdrName])
 -- Convert the declarations inside a class or instance decl
 -- ie signatures, bindings, and associated types
 cvt_ci_decs doc decs
   = do  { decs' <- mapM cvtDec decs
-        ; let (ats', bind_sig_decs') = partitionWith is_fam_inst decs'
-        ; let (sigs', prob_binds')   = partitionWith is_sig bind_sig_decs'
+        ; let (ats', bind_sig_decs') = partitionWith is_tyfam_inst decs'
+        ; let (adts', no_ats')       = partitionWith is_datafam_inst bind_sig_decs'
+        ; let (sigs', prob_binds')   = partitionWith is_sig no_ats'
         ; let (binds', prob_fams')   = partitionWith is_bind prob_binds'
         ; let (fams', bads)          = partitionWith is_fam_decl prob_fams'
         ; unless (null bads) (failWith (mkBadDecMsg doc bads))
-        ; return (listToBag binds', sigs', fams', ats') }
+        ; return (listToBag binds', sigs', fams', ats', adts') }
 
 ----------------
 cvt_tycl_hdr :: TH.Cxt -> TH.Name -> [TH.TyVarBndr]
@@ -290,13 +304,17 @@ cvt_tyinst_hdr cxt tc tys
 --              Partitioning declarations
 -------------------------------------------------------------------
 
-is_fam_decl :: LHsDecl RdrName -> Either (LTyClDecl RdrName) (LHsDecl RdrName)
-is_fam_decl (L loc (TyClD d@(TyFamily {}))) = Left (L loc d)
+is_fam_decl :: LHsDecl RdrName -> Either (LFamilyDecl RdrName) (LHsDecl RdrName)
+is_fam_decl (L loc (TyClD (FamDecl { tcdFam = d }))) = Left (L loc d)
 is_fam_decl decl = Right decl
 
-is_fam_inst :: LHsDecl RdrName -> Either (LFamInstDecl RdrName) (LHsDecl RdrName)
-is_fam_inst (L loc (Hs.InstD (FamInstD { lid_inst = d }))) = Left (L loc d)
-is_fam_inst decl                                           = Right decl
+is_tyfam_inst :: LHsDecl RdrName -> Either (LTyFamInstDecl RdrName) (LHsDecl RdrName)
+is_tyfam_inst (L loc (Hs.InstD (TyFamInstD { tfid_inst = d }))) = Left (L loc d)
+is_tyfam_inst decl                                              = Right decl
+
+is_datafam_inst :: LHsDecl RdrName -> Either (LDataFamInstDecl RdrName) (LHsDecl RdrName)
+is_datafam_inst (L loc (Hs.InstD (DataFamInstD { dfid_inst = d }))) = Left (L loc d)
+is_datafam_inst decl                                                = Right decl
 
 is_sig :: LHsDecl RdrName -> Either (LSig RdrName) (LHsDecl RdrName)
 is_sig (L loc (Hs.SigD sig)) = Left (L loc sig)
diff --git a/compiler/hsSyn/HsDecls.lhs b/compiler/hsSyn/HsDecls.lhs
index cd19e4c89b..8ee17a52b4 100644
--- a/compiler/hsSyn/HsDecls.lhs
+++ b/compiler/hsSyn/HsDecls.lhs
@@ -8,20 +8,25 @@
 
 -- | Abstract syntax of global declarations.
 --
--- Definitions for: @TyDecl@ and @ConDecl@, @ClassDecl@,
+-- Definitions for: @SynDecl@ and @ConDecl@, @ClassDecl@,
 -- @InstDecl@, @DefaultDecl@ and @ForeignDecl@.
 module HsDecls (
   -- * Toplevel declarations
-  HsDecl(..), LHsDecl, HsTyDefn(..),
+  HsDecl(..), LHsDecl, HsDataDefn(..),
   -- ** Class or type declarations
   TyClDecl(..), LTyClDecl, TyClGroup,
-  isClassDecl, isDataDecl, isSynDecl, isFamilyDecl,
-  isHsDataDefn, isHsSynDefn, tcdName, famInstDeclName,
-  countTyClDecls, pprTyDefnFlavour, pprTyClDeclFlavour,
+  isClassDecl, isDataDecl, isSynDecl, isFamilyDecl, tcdName,
+  tyFamInstDeclName, tyFamInstDeclLName,
+  countTyClDecls, pprTyClDeclFlavour,
+  tyClDeclLName, tyClDeclTyVars,
+  FamilyDecl(..), LFamilyDecl,
 
   -- ** Instance declarations
   InstDecl(..), LInstDecl, NewOrData(..), FamilyFlavour(..),
-  FamInstDecl(..), LFamInstDecl, instDeclFamInsts,
+  TyFamInstDecl(..), LTyFamInstDecl, instDeclDataFamInsts,
+  DataFamInstDecl(..), LDataFamInstDecl, pprDataFamInstFlavour,
+  TyFamInstEqn(..), LTyFamInstEqn,
+  LClsInstDecl, ClsInstDecl(..),
 
   -- ** Standalone deriving declarations
   DerivDecl(..), LDerivDecl,
@@ -275,7 +280,7 @@ instance OutputableBndr name => Outputable (SpliceDecl name) where
 
 %************************************************************************
 %*                                                                      *
-\subsection[TyDecl]{@data@, @newtype@ or @type@ (synonym) type declaration}
+\subsection[SynDecl]{@data@, @newtype@ or @type@ (synonym) type declaration}
 %*                                                                      *
 %************************************************************************
 
@@ -426,24 +431,26 @@ data TyClDecl name
     }
 
   | -- | @type/data family T :: *->*@
-    TyFamily {  tcdFlavour :: FamilyFlavour,             -- type or data
-                tcdLName   :: Located name,              -- type constructor
-                tcdTyVars  :: LHsTyVarBndrs name,        -- type variables
-                tcdKindSig :: Maybe (LHsKind name)       -- result kind
-    }
-
+    FamDecl { tcdFam :: FamilyDecl name }
 
-  | -- | @type/data declaration
-    TyDecl { tcdLName  :: Located name            -- ^ Type constructor
+  | -- | @type@ declaration
+    SynDecl { tcdLName  :: Located name            -- ^ Type constructor
            , tcdTyVars :: LHsTyVarBndrs name      -- ^ Type variables; for an associated type
                                                   --   these include outer binders
+           , tcdRhs    :: LHsType name            -- ^ RHS of type declaration
+           , tcdFVs    :: NameSet }
+
+  | -- | @data@ declaration
+    DataDecl { tcdLName    :: Located name        -- ^ Type constructor
+             , tcdTyVars   :: LHsTyVarBndrs name  -- ^ Type variables; for an assoicated type
+                                                  --   these include outer binders
                                                   -- Eg  class T a where
                                                   --       type F a :: *
                                                   --       type F a = a -> a
                                                   -- Here the type decl for 'f' includes 'a' 
                                                   -- in its tcdTyVars
-           , tcdTyDefn :: HsTyDefn name
-           , tcdFVs    :: NameSet }
+             , tcdDataDefn :: HsDataDefn name
+             , tcdFVs      :: NameSet }
 
   | ClassDecl { tcdCtxt    :: LHsContext name,          -- ^ Context...
                 tcdLName   :: Located name,             -- ^ Name of the class
@@ -451,102 +458,42 @@ data TyClDecl name
                 tcdFDs     :: [Located (FunDep name)],  -- ^ Functional deps
                 tcdSigs    :: [LSig name],              -- ^ Methods' signatures
                 tcdMeths   :: LHsBinds name,            -- ^ Default methods
-                tcdATs     :: [LTyClDecl name],         -- ^ Associated types; ie
-                                                        --   only 'TyFamily'
-                tcdATDefs  :: [LFamInstDecl name],      -- ^ Associated type defaults; ie
-                                                        --   only 'TySynonym'
+                tcdATs     :: [LFamilyDecl name],       -- ^ Associated types; ie
+                tcdATDefs  :: [LTyFamInstDecl name],    -- ^ Associated type defaults
                 tcdDocs    :: [LDocDecl],               -- ^ Haddock docs
                 tcdFVs     :: NameSet
     }
   deriving (Data, Typeable)
 
-
-data HsTyDefn name   -- The payload of a type synonym or data type defn
-                     -- Used *both* for vanialla type/data declarations,
-                     --       *and* for type/data family instances
-  = TySynonym { td_synRhs :: LHsType name }   -- ^ Synonym expansion
-
-  | -- | Declares a data type or newtype, giving its construcors
-    -- @
-    --  data/newtype T a = <constrs>
-    --  data/newtype instance T [a] = <constrs>
-    -- @
-    TyData { td_ND     :: NewOrData,
-             td_ctxt   :: LHsContext name,           -- ^ Context
-             td_cType  :: Maybe CType,
-             td_kindSig:: Maybe (LHsKind name),
-                     -- ^ Optional kind signature.
-                     --
-                     -- @(Just k)@ for a GADT-style @data@, 
-                     -- or @data instance@ decl, with explicit kind sig
-                     --
-                     -- Always @Nothing@ for H98-syntax decls
-
-             td_cons   :: [LConDecl name],
-                     -- ^ Data constructors
-                     --
-                     -- For @data T a = T1 | T2 a@
-                     --   the 'LConDecl's all have 'ResTyH98'.
-                     -- For @data T a where { T1 :: T a }@
-                     --   the 'LConDecls' all have 'ResTyGADT'.
-
-             td_derivs :: Maybe [LHsType name]
-                     -- ^ Derivings; @Nothing@ => not specified,
-                     --              @Just []@ => derive exactly what is asked
-                     --
-                     -- These "types" must be of form
-                     -- @
-                     --      forall ab. C ty1 ty2
-                     -- @
-                     -- Typically the foralls and ty args are empty, but they
-                     -- are non-empty for the newtype-deriving case
-    }
-    deriving( Data, Typeable )
-
-data NewOrData
-  = NewType                     -- ^ @newtype Blah ...@
-  | DataType                    -- ^ @data Blah ...@
-  deriving( Eq, Data, Typeable )                -- Needed because Demand derives Eq
+type LFamilyDecl name = Located (FamilyDecl name)
+data FamilyDecl name = FamilyDecl
+  { fdFlavour :: FamilyFlavour              -- type or data
+  , fdLName   :: Located name               -- type constructor
+  , fdTyVars  :: LHsTyVarBndrs name         -- type variables
+  , fdKindSig :: Maybe (LHsKind name) }     -- result kind
+  deriving( Data, Typeable )
 
 data FamilyFlavour
-  = TypeFamily                  -- ^ @type family ...@
-  | DataFamily                  -- ^ @data family ...@
-  deriving (Data, Typeable)
-\end{code}
-
-Note [tcdTypats and HsTyPats] 
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-We use TyData and TySynonym both for vanilla data/type declarations
-     type T a = Int
-AND for data/type family instance declarations
-     type instance F [a] = (a,Int)
-
-tcdTyPats = HsTyDefn tvs
-   This is a vanilla data type or type synonym
-   tvs are the quantified type variables
+  = TypeFamily
+  | DataFamily
+  deriving( Data, Typeable )
 
+\end{code}
 
 ------------------------------
 Simple classifiers
 
 \begin{code}
-isHsDataDefn, isHsSynDefn :: HsTyDefn name -> Bool
-isHsDataDefn (TyData {}) = True
-isHsDataDefn _           = False
-
-isHsSynDefn (TySynonym {}) = True
-isHsSynDefn _              = False
-
 -- | @True@ <=> argument is a @data@\/@newtype@
 -- declaration.
 isDataDecl :: TyClDecl name -> Bool
-isDataDecl (TyDecl { tcdTyDefn = defn }) = isHsDataDefn defn
-isDataDecl _other                        = False
+isDataDecl (DataDecl {}) = True
+isDataDecl _other        = False
 
 -- | type or type instance declaration
 isSynDecl :: TyClDecl name -> Bool
-isSynDecl (TyDecl { tcdTyDefn = defn }) = isHsSynDefn defn
-isSynDecl _other                        = False
+isSynDecl (SynDecl {})   = True
+isSynDecl _other        = False
 
 -- | type class
 isClassDecl :: TyClDecl name -> Bool
@@ -555,18 +502,36 @@ isClassDecl _              = False
 
 -- | type family declaration
 isFamilyDecl :: TyClDecl name -> Bool
-isFamilyDecl (TyFamily {}) = True
+isFamilyDecl (FamDecl {})  = True
 isFamilyDecl _other        = False
 \end{code}
 
 Dealing with names
 
 \begin{code}
-famInstDeclName :: LFamInstDecl a -> a
-famInstDeclName (L _ (FamInstDecl { fid_tycon = L _ name })) = name
+tyFamInstDeclName :: OutputableBndr name
+                  => TyFamInstDecl name -> name
+tyFamInstDeclName = unLoc . tyFamInstDeclLName
+
+tyFamInstDeclLName :: OutputableBndr name
+                   => TyFamInstDecl name -> Located name
+tyFamInstDeclLName (TyFamInstDecl { tfid_eqns =
+                     (L _ (TyFamInstEqn { tfie_tycon = ln })) : _ })
+  -- there may be more than one equation, but grab the name from the first
+  = ln
+tyFamInstDeclLName decl = pprPanic "tyFamInstDeclLName" (ppr decl)
+
+tyClDeclLName :: TyClDecl name -> Located name
+tyClDeclLName (FamDecl { tcdFam = FamilyDecl { fdLName = ln } }) = ln
+tyClDeclLName decl = tcdLName decl
 
 tcdName :: TyClDecl name -> name
-tcdName decl = unLoc (tcdLName decl)
+tcdName = unLoc . tyClDeclLName
+
+tyClDeclTyVars :: OutputableBndr name => TyClDecl name -> LHsTyVarBndrs name
+tyClDeclTyVars decl@(ForeignType {}) = pprPanic "tyClDeclTyVars" (ppr decl)
+tyClDeclTyVars (FamDecl { tcdFam = FamilyDecl { fdTyVars = tvs } }) = tvs
+tyClDeclTyVars d = tcdTyVars d
 \end{code}
 
 \begin{code}
@@ -579,11 +544,11 @@ countTyClDecls decls
     count isNewTy        decls,  -- ...instances
     count isFamilyDecl   decls)
  where
-   isDataTy TyDecl{ tcdTyDefn = TyData { td_ND = DataType } } = True
-   isDataTy _                                                 = False
+   isDataTy DataDecl{ tcdDataDefn = HsDataDefn { dd_ND = DataType } } = True
+   isDataTy _                                                       = False
    
-   isNewTy TyDecl{ tcdTyDefn = TyData { td_ND = NewType } } = True
-   isNewTy _                                                = False
+   isNewTy DataDecl{ tcdDataDefn = HsDataDefn { dd_ND = NewType } } = True
+   isNewTy _                                                      = False
 \end{code}
 
 \begin{code}
@@ -593,20 +558,14 @@ instance OutputableBndr name
     ppr (ForeignType {tcdLName = ltycon})
         = hsep [ptext (sLit "foreign import type dotnet"), ppr ltycon]
 
-    ppr (TyFamily {tcdFlavour = flavour, tcdLName = ltycon, 
-                   tcdTyVars = tyvars, tcdKindSig = mb_kind})
-      = pp_flavour <+> pp_vanilla_decl_head ltycon tyvars [] <+> pp_kind
-        where
-          pp_flavour = case flavour of
-                         TypeFamily -> ptext (sLit "type family")
-                         DataFamily -> ptext (sLit "data family")
+    ppr (FamDecl { tcdFam = decl }) = ppr decl
+    ppr (SynDecl { tcdLName = ltycon, tcdTyVars = tyvars, tcdRhs = rhs })
+      = hang (ptext (sLit "type") <+>
+              pp_vanilla_decl_head ltycon tyvars [] <+> equals)
+          4 (ppr rhs) 
 
-          pp_kind = case mb_kind of
-                      Nothing   -> empty
-                      Just kind -> dcolon <+> ppr kind
-
-    ppr (TyDecl { tcdLName = ltycon, tcdTyVars = tyvars, tcdTyDefn = defn })
-      = pp_ty_defn (pp_vanilla_decl_head ltycon tyvars) defn
+    ppr (DataDecl { tcdLName = ltycon, tcdTyVars = tyvars, tcdDataDefn = defn })
+      = pp_data_defn (pp_vanilla_decl_head ltycon tyvars) defn
 
     ppr (ClassDecl {tcdCtxt = context, tcdLName = lclas, tcdTyVars = tyvars, 
                     tcdFDs  = fds,
@@ -625,6 +584,19 @@ instance OutputableBndr name
                      <+> pp_vanilla_decl_head lclas tyvars (unLoc context)
                      <+> pprFundeps (map unLoc fds)
 
+instance (OutputableBndr name) => Outputable (FamilyDecl name) where
+  ppr (FamilyDecl { fdFlavour = flavour, fdLName = ltycon, 
+                    fdTyVars = tyvars, fdKindSig = mb_kind})
+      = ppr flavour <+> pp_vanilla_decl_head ltycon tyvars [] <+> pp_kind
+        where
+          pp_kind = case mb_kind of
+                      Nothing   -> empty
+                      Just kind -> dcolon <+> ppr kind
+
+instance Outputable FamilyFlavour where
+  ppr TypeFamily = ptext (sLit "type family")
+  ppr DataFamily = ptext (sLit "data family")
+
 pp_vanilla_decl_head :: OutputableBndr name
    => Located name
    -> LHsTyVarBndrs name
@@ -633,66 +605,24 @@ pp_vanilla_decl_head :: OutputableBndr name
 pp_vanilla_decl_head thing tyvars context
  = hsep [pprHsContext context, pprPrefixOcc (unLoc thing), ppr tyvars]
 
-pp_fam_inst_head :: OutputableBndr name
+pp_fam_inst_lhs :: OutputableBndr name
    => Located name
    -> HsWithBndrs [LHsType name]
    -> HsContext name
    -> SDoc
-pp_fam_inst_head thing (HsWB { hswb_cts = typats }) context -- explicit type patterns
-   = hsep [ ptext (sLit "instance"), pprHsContext context, pprPrefixOcc (unLoc thing)
+pp_fam_inst_lhs thing (HsWB { hswb_cts = typats }) context -- explicit type patterns
+   = hsep [ pprHsContext context, pprPrefixOcc (unLoc thing)
           , hsep (map (pprParendHsType.unLoc) typats)]
 
-pp_condecls :: OutputableBndr name => [LConDecl name] -> SDoc
-pp_condecls cs@(L _ ConDecl{ con_res = ResTyGADT _ } : _) -- In GADT syntax
-  = hang (ptext (sLit "where")) 2 (vcat (map ppr cs))
-pp_condecls cs                    -- In H98 syntax
-  = equals <+> sep (punctuate (ptext (sLit " |")) (map ppr cs))
-
-pp_ty_defn :: OutputableBndr name 
-           => (HsContext name -> SDoc)   -- Printing the header
-           -> HsTyDefn name
-           -> SDoc 
-
-pp_ty_defn pp_hdr (TySynonym { td_synRhs = rhs })
-  = hang (ptext (sLit "type") <+> pp_hdr [] <+> equals)
-       4 (ppr rhs)
-
-pp_ty_defn pp_hdr (TyData { td_ND = new_or_data, td_ctxt = L _ context
-                          , td_kindSig = mb_sig 
-                          , td_cons = condecls, td_derivs = derivings })
-  | null condecls
-  = ppr new_or_data <+> pp_hdr context <+> pp_sig
-
-  | otherwise
-  = hang (ppr new_or_data <+> pp_hdr context <+> pp_sig)
-       2 (pp_condecls condecls $$ pp_derivings)
-  where
-    pp_sig = case mb_sig of
-               Nothing   -> empty
-               Just kind -> dcolon <+> ppr kind
-    pp_derivings = case derivings of
-                     Nothing -> empty
-                     Just ds -> hsep [ptext (sLit "deriving"), parens (interpp'SP ds)]
-
-instance OutputableBndr name => Outputable (HsTyDefn name) where
-   ppr d = pp_ty_defn (\_ -> ptext (sLit "Naked HsTyDefn")) d
-
-instance Outputable NewOrData where
-  ppr NewType  = ptext (sLit "newtype")
-  ppr DataType = ptext (sLit "data")
-
-pprTyDefnFlavour :: HsTyDefn a -> SDoc
-pprTyDefnFlavour (TyData { td_ND = nd }) = ppr nd
-pprTyDefnFlavour (TySynonym {})          = ptext (sLit "type")
-
 pprTyClDeclFlavour :: TyClDecl a -> SDoc
-pprTyClDeclFlavour (ClassDecl {})                = ptext (sLit "class")
-pprTyClDeclFlavour (TyFamily {})                 = ptext (sLit "family")
-pprTyClDeclFlavour (TyDecl { tcdTyDefn = defn }) = pprTyDefnFlavour defn
-pprTyClDeclFlavour (ForeignType {})              = ptext (sLit "foreign type")
+pprTyClDeclFlavour (ClassDecl {})  = ptext (sLit "class")
+pprTyClDeclFlavour (FamDecl {})    = ptext (sLit "family")
+pprTyClDeclFlavour (SynDecl {})    = ptext (sLit "type")
+pprTyClDeclFlavour (DataDecl { tcdDataDefn = (HsDataDefn { dd_ND = nd }) })
+  = ppr nd
+pprTyClDeclFlavour (ForeignType {}) = ptext (sLit "foreign type")
 \end{code}
 
-
 %************************************************************************
 %*                                                                      *
 \subsection[ConDecl]{A data-constructor declaration}
@@ -700,6 +630,52 @@ pprTyClDeclFlavour (ForeignType {})              = ptext (sLit "foreign type")
 %************************************************************************
 
 \begin{code}
+
+data HsDataDefn name   -- The payload of a data type defn
+                       -- Used *both* for vanilla data declarations,
+                       --       *and* for data family instances
+  = -- | Declares a data type or newtype, giving its construcors
+    -- @
+    --  data/newtype T a = <constrs>
+    --  data/newtype instance T [a] = <constrs>
+    -- @
+    HsDataDefn { dd_ND     :: NewOrData,
+                 dd_ctxt   :: LHsContext name,           -- ^ Context
+                 dd_cType  :: Maybe CType,
+                 dd_kindSig:: Maybe (LHsKind name),
+                     -- ^ Optional kind signature.
+                     --
+                     -- @(Just k)@ for a GADT-style @data@, 
+                     -- or @data instance@ decl, with explicit kind sig
+                     --
+                     -- Always @Nothing@ for H98-syntax decls
+
+                 dd_cons   :: [LConDecl name],
+                     -- ^ Data constructors
+                     --
+                     -- For @data T a = T1 | T2 a@
+                     --   the 'LConDecl's all have 'ResTyH98'.
+                     -- For @data T a where { T1 :: T a }@
+                     --   the 'LConDecls' all have 'ResTyGADT'.
+
+                 dd_derivs :: Maybe [LHsType name]
+                     -- ^ Derivings; @Nothing@ => not specified,
+                     --              @Just []@ => derive exactly what is asked
+                     --
+                     -- These "types" must be of form
+                     -- @
+                     --      forall ab. C ty1 ty2
+                     -- @
+                     -- Typically the foralls and ty args are empty, but they
+                     -- are non-empty for the newtype-deriving case
+    }
+    deriving( Data, Typeable )
+
+data NewOrData
+  = NewType                     -- ^ @newtype Blah ...@
+  | DataType                    -- ^ @data Blah ...@
+  deriving( Eq, Data, Typeable )                -- Needed because Demand derives Eq
+
 type LConDecl name = Located (ConDecl name)
 
 -- data T b = forall a. Eq a => MkT a b
@@ -774,6 +750,40 @@ instance Outputable ty => Outputable (ResType ty) where
 
 
 \begin{code}
+pp_data_defn :: OutputableBndr name
+                  => (HsContext name -> SDoc)   -- Printing the header
+                  -> HsDataDefn name
+                  -> SDoc 
+pp_data_defn pp_hdr (HsDataDefn { dd_ND = new_or_data, dd_ctxt = L _ context
+                              , dd_kindSig = mb_sig 
+                              , dd_cons = condecls, dd_derivs = derivings })
+  | null condecls
+  = ppr new_or_data <+> pp_hdr context <+> pp_sig
+
+  | otherwise
+  = hang (ppr new_or_data <+> pp_hdr context <+> pp_sig)
+       2 (pp_condecls condecls $$ pp_derivings)
+  where
+    pp_sig = case mb_sig of
+               Nothing   -> empty
+               Just kind -> dcolon <+> ppr kind
+    pp_derivings = case derivings of
+                     Nothing -> empty
+                     Just ds -> hsep [ptext (sLit "deriving"), parens (interpp'SP ds)]
+
+instance OutputableBndr name => Outputable (HsDataDefn name) where
+   ppr d = pp_data_defn (\_ -> ptext (sLit "Naked HsDataDefn")) d
+
+instance Outputable NewOrData where
+  ppr NewType  = ptext (sLit "newtype")
+  ppr DataType = ptext (sLit "data")
+
+pp_condecls :: OutputableBndr name => [LConDecl name] -> SDoc
+pp_condecls cs@(L _ ConDecl{ con_res = ResTyGADT _ } : _) -- In GADT syntax
+  = hang (ptext (sLit "where")) 2 (vcat (map ppr cs))
+pp_condecls cs                    -- In H98 syntax
+  = equals <+> sep (punctuate (ptext (sLit " |")) (map ppr cs))
+
 instance (OutputableBndr name) => Outputable (ConDecl name) where
     ppr = pprConDecl
 
@@ -813,36 +823,69 @@ pprConDecl decl@(ConDecl { con_details = InfixCon ty1 ty2, con_res = ResTyGADT {
 %************************************************************************
 
 \begin{code}
-type LFamInstDecl name = Located (FamInstDecl name)
-data FamInstDecl name 
-  = FamInstDecl
-       { fid_tycon :: Located name
-       , fid_pats  :: HsWithBndrs [LHsType name]  -- ^ Type patterns (with kind and type bndrs)
-                                                  -- See Note [Family instance declaration binders]
-       , fid_defn  :: HsTyDefn name               -- Type or data family instance
-       , fid_fvs   :: NameSet  } 
+-- see note [Family instance equation groups]
+type LTyFamInstEqn name = Located (TyFamInstEqn name)
+
+-- | one equation in a family instance declaration
+data TyFamInstEqn name   
+  = TyFamInstEqn
+       { tfie_tycon :: Located name
+       , tfie_pats  :: HsWithBndrs [LHsType name]
+            -- ^ Type patterns (with kind and type bndrs)
+            -- See Note [Family instance declaration binders]
+       , tfie_rhs   :: LHsType name }         
+  deriving( Typeable, Data )
+
+type LTyFamInstDecl name = Located (TyFamInstDecl name)
+data TyFamInstDecl name 
+  = TyFamInstDecl
+       { tfid_eqns     :: [LTyFamInstEqn name] -- ^ list of (possibly-overlapping) eqns 
+       , tfid_group :: Bool                  -- was this declared with the "where" syntax?
+       , tfid_fvs      :: NameSet }          -- the group is type-checked as one,
+                                             -- so one NameSet will do
+               -- INVARIANT: tfid_group == False --> length tfid_eqns == 1
+  deriving( Typeable, Data )
+
+type LDataFamInstDecl name = Located (DataFamInstDecl name)
+data DataFamInstDecl name
+  = DataFamInstDecl
+       { dfid_tycon :: Located name
+       , dfid_pats  :: HsWithBndrs [LHsType name]   -- lhs
+            -- ^ Type patterns (with kind and type bndrs)
+            -- See Note [Family instance declaration binders]
+       , dfid_defn  :: HsDataDefn  name             -- rhs
+       , dfid_fvs   :: NameSet }                    -- free vars for dependency analysis
   deriving( Typeable, Data )
 
 type LInstDecl name = Located (InstDecl name)
 data InstDecl name  -- Both class and family instances
   = ClsInstD    
+      { cid_inst  :: ClsInstDecl name }
+  | DataFamInstD              -- data family instance
+      { dfid_inst :: DataFamInstDecl name }
+  | TyFamInstD              -- type family instance
+      { tfid_inst :: TyFamInstDecl name }
+  deriving (Data, Typeable)
+
+type LClsInstDecl name = Located (ClsInstDecl name)
+data ClsInstDecl name
+  = ClsInstDecl
       { cid_poly_ty :: LHsType name    -- Context => Class Instance-type
                                        -- Using a polytype means that the renamer conveniently
                                        -- figures out the quantified type variables for us.
       , cid_binds :: LHsBinds name
       , cid_sigs  :: [LSig name]                -- User-supplied pragmatic info
-      , cid_fam_insts :: [LFamInstDecl name]    -- Family instances for associated types
+      , cid_tyfam_insts :: [LTyFamInstDecl name]  -- type family instances
+      , cid_datafam_insts :: [LDataFamInstDecl name] -- data family instances
       }
-
-  | FamInstD              -- type/data family instance
-      { lid_inst :: FamInstDecl name }
   deriving (Data, Typeable)
+
 \end{code}
 
 Note [Family instance declaration binders]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-A FamInstDecl is a data/type family instance declaration
-the fid_pats field is LHS patterns, and the tvs of the HsBSig
+A {Ty|Data}FamInstDecl is a data/type family instance declaration
+the pats field is LHS patterns, and the tvs of the HsBSig
 tvs are fv(pat_tys), *including* ones that are already in scope
 
    Eg   class C s t where
@@ -858,36 +901,69 @@ tvs are fv(pat_tys), *including* ones that are already in scope
    so that we can compare the type patter in the 'instance' decl and
    in the associated 'type' decl
 
-\begin{code}
-instance (OutputableBndr name) => Outputable (FamInstDecl name) where
-  ppr (FamInstDecl { fid_tycon = tycon
-                   , fid_pats = pats
-                   , fid_defn = defn })
-    = pp_ty_defn (pp_fam_inst_head tycon pats) defn
+Note [Family instance equation groups]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+A TyFamInstDecl contains a list of FamInstEqn's, one for each
+equation defined in the instance group. For a standalone
+instance declaration, this list contains exactly one element.
+It is not possible for this list to have 0 elements --
+'type instance where' without anything else is not allowed.
 
-instance (OutputableBndr name) => Outputable (InstDecl name) where
-    ppr (ClsInstD { cid_poly_ty = inst_ty, cid_binds = binds
-                  , cid_sigs = sigs, cid_fam_insts = ats })
+\begin{code}
+instance (OutputableBndr name) => Outputable (TyFamInstDecl name) where
+  ppr (TyFamInstDecl { tfid_group = False, tfid_eqns = [lEqn] })
+    = let eqn = unLoc lEqn in
+        ptext (sLit "type instance") <+> (ppr eqn)
+  ppr (TyFamInstDecl { tfid_eqns = eqns })
+    = hang (ptext (sLit "type instance where"))
+        2 (vcat (map ppr eqns))
+
+instance (OutputableBndr name) => Outputable (TyFamInstEqn name) where
+  ppr (TyFamInstEqn { tfie_tycon = tycon
+                    , tfie_pats  = pats
+                    , tfie_rhs   = rhs })
+    = (pp_fam_inst_lhs tycon pats []) <+> equals <+> (ppr rhs)
+
+instance (OutputableBndr name) => Outputable (DataFamInstDecl name) where
+  ppr (DataFamInstDecl { dfid_tycon = tycon
+                       , dfid_pats  = pats
+                       , dfid_defn  = defn })
+    = pp_data_defn ((ptext (sLit "instance") <+>) . (pp_fam_inst_lhs tycon pats)) defn
+
+pprDataFamInstFlavour :: DataFamInstDecl name -> SDoc
+pprDataFamInstFlavour (DataFamInstDecl { dfid_defn = (HsDataDefn { dd_ND = nd }) })
+  = ppr nd
+
+instance (OutputableBndr name) => Outputable (ClsInstDecl name) where
+    ppr (ClsInstDecl { cid_poly_ty = inst_ty, cid_binds = binds
+                     , cid_sigs = sigs, cid_tyfam_insts = ats
+                     , cid_datafam_insts = adts })
       | null sigs && null ats && isEmptyBag binds  -- No "where" part
       = top_matter
 
       | otherwise       -- Laid out
       = vcat [ top_matter <+> ptext (sLit "where")
              , nest 2 $ pprDeclList (map ppr ats ++
+                                     map ppr adts ++
                                      pprLHsBindsForUser binds sigs) ]
       where
         top_matter = ptext (sLit "instance") <+> ppr inst_ty
 
-    ppr (FamInstD { lid_inst = decl }) = ppr decl
+instance (OutputableBndr name) => Outputable (InstDecl name) where
+    ppr (ClsInstD     { cid_inst  = decl }) = ppr decl
+    ppr (TyFamInstD   { tfid_inst = decl }) = ppr decl
+    ppr (DataFamInstD { dfid_inst = decl }) = ppr decl
 
--- Extract the declarations of associated types from an instance
+-- Extract the declarations of associated data types from an instance
 
-instDeclFamInsts :: [LInstDecl name] -> [FamInstDecl name]
-instDeclFamInsts inst_decls 
+instDeclDataFamInsts :: [LInstDecl name] -> [DataFamInstDecl name]
+instDeclDataFamInsts inst_decls 
   = concatMap do_one inst_decls
   where
-    do_one (L _ (ClsInstD { cid_fam_insts = fam_insts })) = map unLoc fam_insts
-    do_one (L _ (FamInstD { lid_inst = fam_inst }))       = [fam_inst]
+    do_one (L _ (ClsInstD { cid_inst = ClsInstDecl { cid_datafam_insts = fam_insts } }))
+      = map unLoc fam_insts
+    do_one (L _ (DataFamInstD { dfid_inst = fam_inst }))      = [fam_inst]
+    do_one (L _ (TyFamInstD {}))                              = []
 \end{code}
 
 %************************************************************************
diff --git a/compiler/hsSyn/HsUtils.lhs b/compiler/hsSyn/HsUtils.lhs
index 087ecd2985..e1005b6281 100644
--- a/compiler/hsSyn/HsUtils.lhs
+++ b/compiler/hsSyn/HsUtils.lhs
@@ -68,7 +68,7 @@ module HsUtils(
   collectLStmtBinders, collectStmtBinders,
 
   hsLTyClDeclBinders, hsTyClDeclBinders, hsTyClDeclsBinders, 
-  hsForeignDeclsBinders, hsGroupBinders, hsFamInstBinders,
+  hsForeignDeclsBinders, hsGroupBinders, hsDataFamInstBinders,
   
   -- Collecting implicit binders
   lStmtsImplicits, hsValBindsImplicits, lPatImplicits
@@ -639,32 +639,35 @@ hsLTyClDeclBinders (L _ d) = hsTyClDeclBinders d
 
 -------------------
 hsTyClDeclBinders :: Eq name => TyClDecl name -> [Located name]
-hsTyClDeclBinders (TyFamily    {tcdLName = name}) = [name]
+hsTyClDeclBinders (FamDecl { tcdFam = FamilyDecl { fdLName = name} }) = [name]
 hsTyClDeclBinders (ForeignType {tcdLName = name}) = [name]
+hsTyClDeclBinders (SynDecl     {tcdLName = name}) = [name]
 
 hsTyClDeclBinders (ClassDecl { tcdLName = cls_name, tcdSigs = sigs
-                             , tcdATs = ats, tcdATDefs = fam_insts })
+                             , tcdATs = ats })
   = cls_name : 
-    concatMap hsLTyClDeclBinders ats ++ 
-    concatMap (hsFamInstBinders . unLoc) fam_insts ++
+    map (fdLName . unLoc) ats ++ 
     [n | L _ (TypeSig ns _) <- sigs, n <- ns]
 
-hsTyClDeclBinders (TyDecl { tcdLName = name, tcdTyDefn = defn }) 
-  = name : hsTyDefnBinders defn
+hsTyClDeclBinders (DataDecl { tcdLName = name, tcdDataDefn = defn }) 
+  = name : hsDataDefnBinders defn
 
 -------------------
 hsInstDeclBinders :: Eq name => InstDecl name -> [Located name]
-hsInstDeclBinders (ClsInstD { cid_fam_insts = fis }) = concatMap (hsFamInstBinders . unLoc) fis
-hsInstDeclBinders (FamInstD { lid_inst = fi }) = hsFamInstBinders fi
+hsInstDeclBinders (ClsInstD { cid_inst = ClsInstDecl { cid_datafam_insts = dfis } })
+  = concatMap (hsDataFamInstBinders . unLoc) dfis
+hsInstDeclBinders (DataFamInstD { dfid_inst = fi }) = hsDataFamInstBinders fi
+hsInstDeclBinders (TyFamInstD {}) = []
 
 -------------------
-hsFamInstBinders :: Eq name => FamInstDecl name -> [Located name]
-hsFamInstBinders (FamInstDecl { fid_defn = defn }) = hsTyDefnBinders defn
+hsDataFamInstBinders :: Eq name => DataFamInstDecl name -> [Located name]
+hsDataFamInstBinders (DataFamInstDecl { dfid_defn = defn })
+  = hsDataDefnBinders defn
+  -- There can't be repeated symbols because only data instances have binders
 
 -------------------
-hsTyDefnBinders :: Eq name => HsTyDefn name -> [Located name]
-hsTyDefnBinders (TySynonym {})              = []
-hsTyDefnBinders (TyData { td_cons = cons }) = hsConDeclsBinders cons
+hsDataDefnBinders :: Eq name => HsDataDefn name -> [Located name]
+hsDataDefnBinders (HsDataDefn { dd_cons = cons }) = hsConDeclsBinders cons
   -- See Note [Binders in family instances]
 
 -------------------