[commit: ghc] th-new: Add support for Template Haskell state. (6f4cba0)

[Geoffrey Mainland]

Repository : http://darcs.haskell.org/ghc.git/

On branch  : th-new

https://github.com/ghc/ghc/commit/6f4cba0f37e5340c5adfd20fd91333feaeb1cd71

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

commit 6f4cba0f37e5340c5adfd20fd91333feaeb1cd71
Author: Geoffrey Mainland <mainland at apeiron.net>
Date:   Tue Jun 4 16:29:11 2013 +0100

    Add support for Template Haskell state.

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

 compiler/typecheck/TcRnMonad.lhs |  6 ++++++
 compiler/typecheck/TcRnTypes.lhs |  7 +++++++
 compiler/typecheck/TcSplice.lhs  | 15 +++++++++++++++
 3 files changed, 28 insertions(+)

diff --git a/compiler/typecheck/TcRnMonad.lhs b/compiler/typecheck/TcRnMonad.lhs
index 97c7e73..00eb697 100644
--- a/compiler/typecheck/TcRnMonad.lhs
+++ b/compiler/typecheck/TcRnMonad.lhs
@@ -53,6 +53,10 @@ import Control.Exception
 import Data.IORef
 import qualified Data.Set as Set
 import Control.Monad
+
+#ifdef GHCI
+import qualified Data.Map as Map
+#endif
 \end{code}
 
 
@@ -94,6 +98,7 @@ initTc hsc_env hsc_src keep_rn_syntax mod do_this
         th_topdecls_var      <- newIORef [] ;
         th_topnames_var      <- newIORef emptyNameSet ;
         th_modfinalizers_var <- newIORef [] ;
+        th_state_var         <- newIORef Map.empty ;
 #endif /* GHCI */
         let {
              maybe_rn_syntax :: forall a. a -> Maybe a ;
@@ -106,6 +111,7 @@ initTc hsc_env hsc_src keep_rn_syntax mod do_this
                 tcg_th_topdecls      = th_topdecls_var,
                 tcg_th_topnames      = th_topnames_var,
                 tcg_th_modfinalizers = th_modfinalizers_var,
+                tcg_th_state         = th_state_var,
 #endif /* GHCI */
 
                 tcg_mod            = mod,
diff --git a/compiler/typecheck/TcRnTypes.lhs b/compiler/typecheck/TcRnTypes.lhs
index 46ded17..acf6edd 100644
--- a/compiler/typecheck/TcRnTypes.lhs
+++ b/compiler/typecheck/TcRnTypes.lhs
@@ -116,6 +116,10 @@ import FastString
 import Data.Set (Set)
 
 #ifdef GHCI
+import Data.Map      ( Map )
+import Data.Dynamic  ( Dynamic )
+import Data.Typeable ( TypeRep )
+
 import qualified Language.Haskell.TH as TH
 #endif
 \end{code}
@@ -303,6 +307,9 @@ data TcGblEnv
 
         tcg_th_modfinalizers :: TcRef [TH.Q ()],
         -- ^ Template Haskell module finalizers
+
+        tcg_th_state :: TcRef (Map TypeRep Dynamic),
+        -- ^ Template Haskell state
 #endif /* GHCI */
 
         tcg_ev_binds  :: Bag EvBind,        -- Top-level evidence bindings
diff --git a/compiler/typecheck/TcSplice.lhs b/compiler/typecheck/TcSplice.lhs
index a2359bc..ee56d28 100644
--- a/compiler/typecheck/TcSplice.lhs
+++ b/compiler/typecheck/TcSplice.lhs
@@ -7,6 +7,7 @@ TcSplice: Template Haskell splices
 
 
 \begin{code}
+{-# LANGUAGE ScopedTypeVariables #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 module TcSplice( tcSpliceType, tcSpliceExpr, tcSpliceDecls, tcBracket,
                  tcTopSpliceExpr,
@@ -85,6 +86,10 @@ import qualified Language.Haskell.TH.Syntax as TH
 #ifdef GHCI
 -- Because GHC.Desugar might not be in the base library of the bootstrapping compiler
 import GHC.Desugar      ( AnnotationWrapper(..) )
+
+import qualified Data.Map as Map
+import Data.Dynamic  ( fromDynamic, toDyn )
+import Data.Typeable ( typeOf )
 #endif
 
 import GHC.Exts         ( unsafeCoerce# )
@@ -1090,6 +1095,16 @@ instance TH.Quasi (IOEnv (Env TcGblEnv TcLclEnv)) where
   qAddModFinalizer fin = do
       th_modfinalizers_var <- fmap tcg_th_modfinalizers getGblEnv
       updTcRef th_modfinalizers_var (\fins -> fin:fins)
+
+  qGetQ = do
+      th_state_var <- fmap tcg_th_state getGblEnv
+      th_state <- readTcRef th_state_var
+      let x = Map.lookup (typeOf x) th_state >>= fromDynamic
+      return x
+
+  qPutQ x = do
+      th_state_var <- fmap tcg_th_state getGblEnv
+      updTcRef th_state_var (\m -> Map.insert (typeOf x) (toDyn x) m)
 \end{code}