Merge New Template Haskell branch.

4 files changed, 67 insertions, 3 deletions

diff --git a/libraries/template-haskell/Language/Haskell/TH.hs b/libraries/template-haskell/Language/Haskell/TH.hs
index 7133b61795..ed07f387c5 100644
--- a/libraries/template-haskell/Language/Haskell/TH.hs
+++ b/libraries/template-haskell/Language/Haskell/TH.hs
@@ -33,6 +33,9 @@ module Language.Haskell.TH(
         -- *** Roles lookup
         reifyRoles,
 
+	-- * Typed expressions
+	TExp, unType,
+
 	-- * Names
 	Name, NameSpace,	-- Abstract
 	-- ** Constructing names
diff --git a/libraries/template-haskell/Language/Haskell/TH/Lib.hs b/libraries/template-haskell/Language/Haskell/TH/Lib.hs
index 2480ff35a0..38a86d5ed7 100644
--- a/libraries/template-haskell/Language/Haskell/TH/Lib.hs
+++ b/libraries/template-haskell/Language/Haskell/TH/Lib.hs
@@ -20,6 +20,7 @@ type InfoQ          = Q Info
 type PatQ           = Q Pat
 type FieldPatQ      = Q FieldPat
 type ExpQ           = Q Exp
+type TExpQ a        = Q (TExp a)
 type DecQ           = Q Dec
 type DecsQ          = Q [Dec]
 type ConQ           = Q Con
diff --git a/libraries/template-haskell/Language/Haskell/TH/Ppr.hs b/libraries/template-haskell/Language/Haskell/TH/Ppr.hs
index ce9fe15859..9bec103752 100644
--- a/libraries/template-haskell/Language/Haskell/TH/Ppr.hs
+++ b/libraries/template-haskell/Language/Haskell/TH/Ppr.hs
@@ -136,12 +136,22 @@ pprExp i (MultiIfE alts)
         []            -> [text "if {}"]
         (alt : alts') -> text "if" <+> pprGuarded arrow alt
                          : map (nest 3 . pprGuarded arrow) alts'
-pprExp i (LetE ds e) = parensIf (i > noPrec) $ text "let" <+> ppr ds
-                                            $$ text " in" <+> ppr e
+pprExp i (LetE ds_ e) = parensIf (i > noPrec) $ text "let" <+> pprDecs ds_
+                                             $$ text " in" <+> ppr e
+  where
+    pprDecs []  = empty
+    pprDecs [d] = ppr d
+    pprDecs ds  = braces $ sep $ punctuate semi $ map ppr ds
+
 pprExp i (CaseE e ms)
  = parensIf (i > noPrec) $ text "case" <+> ppr e <+> text "of"
                         $$ nest nestDepth (ppr ms)
-pprExp i (DoE ss) = parensIf (i > noPrec) $ text "do" <+> ppr ss
+pprExp i (DoE ss_) = parensIf (i > noPrec) $ text "do" <+> pprStms ss_
+  where
+    pprStms []  = empty
+    pprStms [s] = ppr s
+    pprStms ss  = braces $ sep $ punctuate semi $ map ppr ss
+    
 pprExp _ (CompE []) = text "<<Empty CompExp>>"
 -- This will probably break with fixity declarations - would need a ';'
 pprExp _ (CompE ss) = text "[" <> ppr s
diff --git a/libraries/template-haskell/Language/Haskell/TH/Syntax.hs b/libraries/template-haskell/Language/Haskell/TH/Syntax.hs
index 234225ec86..11a35c1a91 100644
--- a/libraries/template-haskell/Language/Haskell/TH/Syntax.hs
+++ b/libraries/template-haskell/Language/Haskell/TH/Syntax.hs
@@ -62,6 +62,14 @@ class (Monad m, Applicative m) => Quasi m where
 
   qAddDependentFile :: FilePath -> m ()
 
+  qAddTopDecls :: [Dec] -> m ()
+
+  qAddModFinalizer :: Q () -> m ()
+
+  qGetQ :: Typeable a => m (Maybe a)
+
+  qPutQ :: Typeable a => a -> m ()
+
 -----------------------------------------------------
 --	The IO instance of Quasi
 --
@@ -88,6 +96,10 @@ instance Quasi IO where
   qLocation    	      = badIO "currentLocation"
   qRecover _ _ 	      = badIO "recover" -- Maybe we could fix this?
   qAddDependentFile _ = badIO "addDependentFile"
+  qAddTopDecls _      = badIO "addTopDecls"
+  qAddModFinalizer _  = badIO "addModFinalizer"
+  qGetQ               = badIO "getQ"
+  qPutQ _             = badIO "putQ"
 
   qRunIO m = m
 
@@ -136,6 +148,22 @@ instance Applicative Q where
   pure x = Q (pure x)
   Q f <*> Q x = Q (f <*> x)
 
+-----------------------------------------------------
+--
+--		The TExp type
+--
+-----------------------------------------------------
+
+newtype TExp a = TExp { unType :: Exp }
+
+unTypeQ :: Q (TExp a) -> Q Exp
+unTypeQ m = do { TExp e <- m
+               ; return e }
+
+unsafeTExpCoerce :: Q Exp -> Q (TExp a)
+unsafeTExpCoerce m = do { e <- m
+                        ; return (TExp e) }
+
 ----------------------------------------------------
 -- Packaged versions for the programmer, hiding the Quasi-ness
 
@@ -322,6 +350,24 @@ runIO m = Q (qRunIO m)
 addDependentFile :: FilePath -> Q ()
 addDependentFile fp = Q (qAddDependentFile fp)
 
+-- | Add additional top-level declarations. The added declarations will be type
+-- checked along with the current declaration group.
+addTopDecls :: [Dec] -> Q ()
+addTopDecls ds = Q (qAddTopDecls ds)
+
+-- | Add a finalizer that will run in the Q monad after the current module has
+-- been type checked. This only makes sense when run within a top-level splice.
+addModFinalizer :: Q () -> Q ()
+addModFinalizer act = Q (qAddModFinalizer (unQ act))
+
+-- | Get state from the Q monad.
+getQ :: Typeable a => Q (Maybe a)
+getQ = Q qGetQ
+
+-- | Replace the state in the Q monad.
+putQ :: Typeable a => a -> Q ()
+putQ x = Q (qPutQ x)
+
 instance Quasi Q where
   qNewName  	    = newName
   qReport   	    = report
@@ -333,6 +379,10 @@ instance Quasi Q where
   qLocation 	    = location
   qRunIO    	    = runIO
   qAddDependentFile = addDependentFile
+  qAddTopDecls      = addTopDecls
+  qAddModFinalizer  = addModFinalizer
+  qGetQ             = getQ
+  qPutQ             = putQ
 
 
 ----------------------------------------------------