[commit: template-haskell] overlapping-tyfams: Add type space declarations to branched type family instances. (02ba3a2)

[Richard Eisenberg]

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

On branch  : overlapping-tyfams

http://hackage.haskell.org/trac/ghc/changeset/02ba3a2446d22d41689b61be788a3c29ae4f7230

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

commit 02ba3a2446d22d41689b61be788a3c29ae4f7230
Author: Richard Eisenberg <eir at cis.upenn.edu>
Date:   Tue May 28 15:27:43 2013 +0100

    Add type space declarations to branched type family instances.

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

 Language/Haskell/TH/Lib.hs    |    8 +++++---
 Language/Haskell/TH/Ppr.hs    |    7 +++++--
 Language/Haskell/TH/Syntax.hs |   12 ++++++------
 3 files changed, 16 insertions(+), 11 deletions(-)

diff --git a/Language/Haskell/TH/Lib.hs b/Language/Haskell/TH/Lib.hs
index 71adf66..e9d6baf 100644
--- a/Language/Haskell/TH/Lib.hs
+++ b/Language/Haskell/TH/Lib.hs
@@ -9,6 +9,7 @@ module Language.Haskell.TH.Lib where
 
 import Language.Haskell.TH.Syntax
 import Control.Monad( liftM, liftM2 )
+import qualified Data.Traversable as T
 import Data.Word( Word8 )
 
 ----------------------------------------------------------
@@ -424,11 +425,12 @@ newtypeInstD ctxt tc tys con derivs =
     con1  <- con
     return (NewtypeInstD ctxt1 tc tys1 con1 derivs)
 
-tySynInstD :: Name -> [TySynEqnQ] -> DecQ
-tySynInstD tc eqns = 
+tySynInstD :: Name -> Maybe [TypeQ] -> [TySynEqnQ] -> DecQ
+tySynInstD tc mtys eqns = 
   do 
+    mtys1 <- T.sequenceA (fmap sequence mtys)
     eqns1 <- sequence eqns
-    return (TySynInstD tc eqns1)
+    return (TySynInstD tc mtys1 eqns1)
 
 tySynEqn :: [TypeQ] -> TypeQ -> TySynEqnQ
 tySynEqn lhs rhs =
diff --git a/Language/Haskell/TH/Ppr.hs b/Language/Haskell/TH/Ppr.hs
index 99f0564..f533182 100644
--- a/Language/Haskell/TH/Ppr.hs
+++ b/Language/Haskell/TH/Ppr.hs
@@ -275,17 +275,20 @@ ppr_dec isTop (NewtypeInstD ctxt tc tys c decs)
   where
     maybeInst | isTop     = text "instance"
               | otherwise = empty
-ppr_dec isTop (TySynInstD tc eqns)
+ppr_dec isTop (TySynInstD tc mtys eqns)
   | [TySynEqn tys rhs] <- eqns
+  , Nothing <- mtys
   = ppr_tySyn maybeInst tc (sep (map pprParendType tys)) rhs
   | otherwise
-  = hang (text "type instance where")
+  = hang (text "type instance" <+> ppr_mtys mtys <+> text "where")
          nestDepth (vcat (map ppr_eqn eqns))
   where
     maybeInst | isTop     = text "instance"
               | otherwise = empty
     ppr_eqn (TySynEqn lhs rhs)
       = ppr tc <+> sep (map pprParendType lhs) <+> text "=" <+> ppr rhs
+    ppr_mtys Nothing = empty
+    ppr_mtys (Just tys) = ppr tc <+> sep (map pprParendType tys)
 
 ppr_data :: Doc -> Cxt -> Name -> Doc -> [Con] -> [Name] -> Doc
 ppr_data maybeInst ctxt t argsDoc cs decs
diff --git a/Language/Haskell/TH/Syntax.hs b/Language/Haskell/TH/Syntax.hs
index 62b1999..0d9517b 100644
--- a/Language/Haskell/TH/Syntax.hs
+++ b/Language/Haskell/TH/Syntax.hs
@@ -1170,14 +1170,14 @@ 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 ... = ... } }
-                                  -- @
+  | TySynInstD Name (Maybe [Type]) [TySynEqn]
+                                  -- ^
+                                  -- @{ type instance T ... where
+                                  --    { T ... = ... 
+                                  --    ; T ... = ... } }@
                                   --
                                   --  @type instance T ... = ...@ is used when
-                                  --  the list has length 1
+                                  --  the @Maybe [Type]@ is omitted
   deriving( Show, Eq, Data, Typeable )
 
 -- | One equation of a (branched) type family instance. The arguments are the