Refactor type families in Template Haskell

Fixes #10902.

Test Plan: validate

Reviewers: goldfire, austin, hvr, jstolarek, bgamari

Reviewed By: jstolarek, bgamari

Subscribers: hvr, thomie

Differential Revision: https://phabricator.haskell.org/D1570

GHC Trac Issues: #10902

5 files changed, 38 insertions, 24 deletions

diff --git a/libraries/template-haskell/Language/Haskell/TH.hs b/libraries/template-haskell/Language/Haskell/TH.hs
index 49038816e7..61f142670e 100644
--- a/libraries/template-haskell/Language/Haskell/TH.hs
+++ b/libraries/template-haskell/Language/Haskell/TH.hs
@@ -65,7 +65,7 @@ module Language.Haskell.TH(
         Dec(..), Con(..), Clause(..),
         Strict(..), Foreign(..), Callconv(..), Safety(..), Pragma(..),
         Inline(..), RuleMatch(..), Phases(..), RuleBndr(..), AnnTarget(..),
-        FunDep(..), FamFlavour(..), TySynEqn(..),
+        FunDep(..), FamFlavour(..), TySynEqn(..), TypeFamilyHead(..),
         Fixity(..), FixityDirection(..), defaultFixity, maxPrecedence,
     -- ** Expressions
         Exp(..), Match(..), Body(..), Guard(..), Stmt(..), Range(..), Lit(..),
diff --git a/libraries/template-haskell/Language/Haskell/TH/Lib.hs b/libraries/template-haskell/Language/Haskell/TH/Lib.hs
index f38f36fb6f..c0873df075 100644
--- a/libraries/template-haskell/Language/Haskell/TH/Lib.hs
+++ b/libraries/template-haskell/Language/Haskell/TH/Lib.hs
@@ -452,13 +452,13 @@ dataFamilyD tc tvs kind
 openTypeFamilyD :: Name -> [TyVarBndr] -> FamilyResultSig
                 -> Maybe InjectivityAnn -> DecQ
 openTypeFamilyD tc tvs res inj
-    = return $ OpenTypeFamilyD tc tvs res inj
+    = return $ OpenTypeFamilyD (TypeFamilyHead tc tvs res inj)
 
 closedTypeFamilyD :: Name -> [TyVarBndr] -> FamilyResultSig
                   -> Maybe InjectivityAnn -> [TySynEqnQ] -> DecQ
 closedTypeFamilyD tc tvs result injectivity eqns =
   do eqns1 <- sequence eqns
-     return (ClosedTypeFamilyD tc tvs result injectivity eqns1)
+     return (ClosedTypeFamilyD (TypeFamilyHead tc tvs result injectivity) eqns1)
 
 -- These were deprecated in GHC 7.12 with a plan to remove them in 7.14. If you
 -- remove this check please also:
@@ -476,13 +476,14 @@ closedTypeFamilyD tc tvs result injectivity eqns =
 familyNoKindD :: FamFlavour -> Name -> [TyVarBndr] -> DecQ
 familyNoKindD flav tc tvs =
     case flav of
-      TypeFam -> return $ OpenTypeFamilyD tc tvs NoSig Nothing
+      TypeFam -> return $ OpenTypeFamilyD (TypeFamilyHead tc tvs NoSig Nothing)
       DataFam -> return $ DataFamilyD tc tvs Nothing
 
 familyKindD :: FamFlavour -> Name -> [TyVarBndr] -> Kind -> DecQ
 familyKindD flav tc tvs k =
     case flav of
-      TypeFam -> return $ OpenTypeFamilyD tc tvs (KindSig k) Nothing
+      TypeFam ->
+        return $ OpenTypeFamilyD (TypeFamilyHead tc tvs (KindSig k) Nothing)
       DataFam -> return $ DataFamilyD tc tvs (Just k)
 
 {-# DEPRECATED closedTypeFamilyNoKindD, closedTypeFamilyKindD
@@ -490,12 +491,13 @@ familyKindD flav tc tvs k =
 closedTypeFamilyNoKindD :: Name -> [TyVarBndr] -> [TySynEqnQ] -> DecQ
 closedTypeFamilyNoKindD tc tvs eqns =
  do eqns1 <- sequence eqns
-    return (ClosedTypeFamilyD tc tvs NoSig Nothing eqns1)
+    return (ClosedTypeFamilyD (TypeFamilyHead tc tvs NoSig Nothing) eqns1)
 
 closedTypeFamilyKindD :: Name -> [TyVarBndr] -> Kind -> [TySynEqnQ] -> DecQ
 closedTypeFamilyKindD tc tvs kind eqns =
  do eqns1 <- sequence eqns
-    return (ClosedTypeFamilyD tc tvs (KindSig kind) Nothing eqns1)
+    return (ClosedTypeFamilyD (TypeFamilyHead tc tvs (KindSig kind) Nothing)
+            eqns1)
 
 roleAnnotD :: Name -> [Role] -> DecQ
 roleAnnotD name roles = return $ RoleAnnotD name roles
diff --git a/libraries/template-haskell/Language/Haskell/TH/Ppr.hs b/libraries/template-haskell/Language/Haskell/TH/Ppr.hs
index 223137332f..14800adddd 100644
--- a/libraries/template-haskell/Language/Haskell/TH/Ppr.hs
+++ b/libraries/template-haskell/Language/Haskell/TH/Ppr.hs
@@ -318,21 +318,15 @@ ppr_dec isTop (TySynInstD tc (TySynEqn tys rhs))
   where
     maybeInst | isTop     = text "instance"
               | otherwise = empty
-ppr_dec isTop (OpenTypeFamilyD tc tvs res inj)
-  = text "type" <+> maybeFamily <+> ppr tc <+> hsep (map ppr tvs) <+>
-    ppr res <+> maybeInj
+ppr_dec isTop (OpenTypeFamilyD tfhead)
+  = text "type" <+> maybeFamily <+> ppr_tf_head tfhead
   where
     maybeFamily | isTop     = text "family"
                 | otherwise = empty
-    maybeInj | (Just inj') <- inj = ppr inj'
-             | otherwise          = empty
-ppr_dec _ (ClosedTypeFamilyD tc tvs res inj eqns)
-  = hang (hsep [ text "type family", ppr tc, hsep (map ppr tvs), ppr res
-               , maybeInj, text "where" ])
+ppr_dec _ (ClosedTypeFamilyD tfhead@(TypeFamilyHead tc _ _ _) eqns)
+  = hang (text "type family" <+> ppr_tf_head tfhead <+> text "where")
       nestDepth (vcat (map ppr_eqn eqns))
   where
-    maybeInj | (Just inj') <- inj = ppr inj'
-             | otherwise          = empty
     ppr_eqn (TySynEqn lhs rhs)
       = ppr tc <+> sep (map pprParendType lhs) <+> text "=" <+> ppr rhs
 
@@ -377,6 +371,13 @@ ppr_tySyn :: Doc -> Name -> Doc -> Type -> Doc
 ppr_tySyn maybeInst t argsDoc rhs
   = text "type" <+> maybeInst <+> ppr t <+> argsDoc <+> text "=" <+> ppr rhs
 
+ppr_tf_head :: TypeFamilyHead -> Doc
+ppr_tf_head (TypeFamilyHead tc tvs res inj)
+  = ppr tc <+> hsep (map ppr tvs) <+> ppr res <+> maybeInj
+  where
+    maybeInj | (Just inj') <- inj = ppr inj'
+             | otherwise          = empty
+
 ------------------------------
 instance Ppr FunDep where
     ppr (FunDep xs ys) = hsep (map ppr xs) <+> text "->" <+> hsep (map ppr ys)
diff --git a/libraries/template-haskell/Language/Haskell/TH/Syntax.hs b/libraries/template-haskell/Language/Haskell/TH/Syntax.hs
index ca6219ea91..e375740806 100644
--- a/libraries/template-haskell/Language/Haskell/TH/Syntax.hs
+++ b/libraries/template-haskell/Language/Haskell/TH/Syntax.hs
@@ -1487,15 +1487,10 @@ data Dec
   | TySynInstD Name TySynEqn      -- ^ @{ type instance ... }@
 
   -- | open type families (may also appear in [Dec] of 'ClassD' and 'InstanceD')
-  | OpenTypeFamilyD Name
-         [TyVarBndr] FamilyResultSig
-         (Maybe InjectivityAnn)
+  | OpenTypeFamilyD TypeFamilyHead
          -- ^ @{ type family T a b c = (r :: *) | r -> a b }@
 
-  | ClosedTypeFamilyD Name
-      [TyVarBndr] FamilyResultSig
-      (Maybe InjectivityAnn)
-      [TySynEqn]
+  | ClosedTypeFamilyD TypeFamilyHead [TySynEqn]
        -- ^ @{ type family F a b = (r :: *) | r -> a where ... }@
 
   | RoleAnnotD Name [Role]        -- ^ @{ type role T nominal representational }@
@@ -1503,6 +1498,15 @@ data Dec
   | DefaultSigD Name Type         -- ^ @{ default size :: Data a => a -> Int }@
   deriving( Show, Eq, Ord, Data, Typeable, Generic )
 
+-- | Common elements of 'OpenTypeFamilyD' and 'ClosedTypeFamilyD'.
+-- By analogy with with "head" for type classes and type class instances as
+-- defined in /Type classes: an exploration of the design space/, the
+-- @TypeFamilyHead@ is defined to be the elements of the declaration between
+-- @type family@ and @where@.
+data TypeFamilyHead =
+  TypeFamilyHead Name [TyVarBndr] FamilyResultSig (Maybe InjectivityAnn)
+  deriving( Show, Eq, Ord, Data, Typeable, Generic )
+
 -- | One equation of a type family instance or closed type family. The
 -- arguments are the left-hand-side type patterns and the right-hand-side
 -- result.
diff --git a/libraries/template-haskell/changelog.md b/libraries/template-haskell/changelog.md
index 8e09a75b18..33419b34ec 100644
--- a/libraries/template-haskell/changelog.md
+++ b/libraries/template-haskell/changelog.md
@@ -18,6 +18,13 @@
 
   * Add `Show` instances for `NameFlavour` and `NameSpace`
 
+  * Remove `FamilyD` and `FamFlavour`.  Add `DataFamilyD` and `OpenTypeFamilyD`
+    as the representation of data families and open type families
+    respectively. (#6018)
+
+  * Add `TypeFamilyHead` for common elements of `OpenTypeFamilyD` and
+    `ClosedTypeFamilyD` (#10902)
+
   * TODO: document API changes and important bugfixes