[commit: template-haskell] overlapping-tyfams, master: Update to support closed type families. (e4f742d)

[Richard Eisenberg]

Repository : ssh://darcs.haskell.org//srv/darcs/packages/template-haskell

On branches: overlapping-tyfams,master

http://hackage.haskell.org/trac/ghc/changeset/e4f742d5f70eefb1e0a7542762f34e7a50f6fcef

>---------------------------------------------------------------

commit e4f742d5f70eefb1e0a7542762f34e7a50f6fcef
Author: Richard Eisenberg <eir at cis.upenn.edu>
Date:   Fri Jun 21 14:01:36 2013 +0100

    Update to support closed type families.

>---------------------------------------------------------------

 Language/Haskell/TH/Lib.hs    |   18 +++++++++++++++---
 Language/Haskell/TH/Ppr.hs    |   14 +++++++++-----
 Language/Haskell/TH/Syntax.hs |   21 ++++++++++-----------
 3 files changed, 34 insertions(+), 19 deletions(-)

diff --git a/Language/Haskell/TH/Lib.hs b/Language/Haskell/TH/Lib.hs
index 71adf66..e29463b 100644
--- a/Language/Haskell/TH/Lib.hs
+++ b/Language/Haskell/TH/Lib.hs
@@ -424,11 +424,23 @@ newtypeInstD ctxt tc tys con derivs =
     con1  <- con
     return (NewtypeInstD ctxt1 tc tys1 con1 derivs)
 
-tySynInstD :: Name -> [TySynEqnQ] -> DecQ
-tySynInstD tc eqns = 
+tySynInstD :: Name -> TySynEqnQ -> DecQ
+tySynInstD tc eqn = 
+  do 
+    eqn1 <- eqn
+    return (TySynInstD tc eqn1)
+
+closedTypeFamilyNoKindD :: Name -> [TyVarBndr] -> [TySynEqnQ] -> DecQ
+closedTypeFamilyNoKindD tc tvs eqns =
+  do
+    eqns1 <- sequence eqns
+    return (ClosedTypeFamilyD tc tvs Nothing eqns1)
+
+closedTypeFamilyKindD :: Name -> [TyVarBndr] -> Kind -> [TySynEqnQ] -> DecQ
+closedTypeFamilyKindD tc tvs kind eqns =
   do 
     eqns1 <- sequence eqns
-    return (TySynInstD tc eqns1)
+    return (ClosedTypeFamilyD tc tvs (Just kind) eqns1)
 
 tySynEqn :: [TypeQ] -> TypeQ -> TySynEqnQ
 tySynEqn lhs rhs =
diff --git a/Language/Haskell/TH/Ppr.hs b/Language/Haskell/TH/Ppr.hs
index 99f0564..8bd3b84 100644
--- a/Language/Haskell/TH/Ppr.hs
+++ b/Language/Haskell/TH/Ppr.hs
@@ -275,18 +275,22 @@ ppr_dec isTop (NewtypeInstD ctxt tc tys c decs)
   where
     maybeInst | isTop     = text "instance"
               | otherwise = empty
-ppr_dec isTop (TySynInstD tc eqns)
-  | [TySynEqn tys rhs] <- eqns
+ppr_dec isTop (TySynInstD tc (TySynEqn tys rhs))
   = ppr_tySyn maybeInst tc (sep (map pprParendType tys)) rhs
-  | otherwise
-  = hang (text "type instance where")
-         nestDepth (vcat (map ppr_eqn eqns))
   where
     maybeInst | isTop     = text "instance"
               | otherwise = empty
+ppr_dec _ (ClosedTypeFamilyD tc tvs mkind eqns)
+  = hang (hsep [ text "type family", ppr tc, hsep (map ppr tvs), maybeKind
+               , text "where" ])
+      nestDepth (vcat (map ppr_eqn eqns))
+  where
+    maybeKind | (Just k') <- mkind = text "::" <+> ppr k'
+              | otherwise          = empty
     ppr_eqn (TySynEqn lhs rhs)
       = ppr tc <+> sep (map pprParendType lhs) <+> text "=" <+> ppr rhs
 
+
 ppr_data :: Doc -> Cxt -> Name -> Doc -> [Con] -> [Name] -> Doc
 ppr_data maybeInst ctxt t argsDoc cs decs
   = sep [text "data" <+> maybeInst
diff --git a/Language/Haskell/TH/Syntax.hs b/Language/Haskell/TH/Syntax.hs
index 62b1999..7a8a3f8 100644
--- a/Language/Haskell/TH/Syntax.hs
+++ b/Language/Haskell/TH/Syntax.hs
@@ -862,7 +862,8 @@ data Info
   | TyConI 
         Dec
 
-  -- | A type or data family, with a list of its visible instances
+  -- | A type or data family, with a list of its visible instances. A closed
+  -- type family is returned with 0 instances.
   | FamilyI 
         Dec
         [InstanceDec]
@@ -1170,18 +1171,16 @@ data Dec
   | NewtypeInstD Cxt Name [Type]
          Con [Name]               -- ^ @{ newtype instance Cxt x => T [x] = A (B x)
                                   --       deriving (Z,W)}@
-  | TySynInstD Name [TySynEqn]    -- ^
-                                  -- @
-                                  -- { type instance where { T ... = ... 
-                                  --                       ; T ... = ... } }
-                                  -- @
-                                  --
-                                  --  @type instance T ... = ...@ is used when
-                                  --  the list has length 1
+  | TySynInstD Name TySynEqn      -- ^ @{ type instance ... }@
+
+  | ClosedTypeFamilyD Name
+      [TyVarBndr] (Maybe Kind)
+      [TySynEqn]                  -- ^ @{ type family F a b :: * where ... }@
   deriving( Show, Eq, Data, Typeable )
 
--- | One equation of a (branched) type family instance. The arguments are the
--- left-hand-side type patterns and the right-hand-side result.
+-- | 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.
 data TySynEqn = TySynEqn [Type] Type
   deriving( Show, Eq, Data, Typeable )