From fdce179c03477bb01af9e17933313ff258317a5b Mon Sep 17 00:00:00 2001
From: Geoffrey Mainland <mainland@apeiron.net>
Date: Tue, 4 Jun 2013 16:29:11 +0100
Subject: [PATCH] Add support for Template Haskell state.
---
compiler/typecheck/TcRnMonad.lhs | 6 ++++++
compiler/typecheck/TcRnTypes.lhs | 7 +++++++
compiler/typecheck/TcSplice.lhs | 14 ++++++++++++++
3 files changed, 27 insertions(+)
diff --git a/compiler/typecheck/TcRnMonad.lhs b/compiler/typecheck/TcRnMonad.lhs
index 3ceebab733ed..b4b3f38ea0cd 100644
--- a/compiler/typecheck/TcRnMonad.lhs
+++ b/compiler/typecheck/TcRnMonad.lhs
@@ -53,6 +53,10 @@ import Util
import Data.IORef
import qualified Data.Set as Set
import Control.Monad
+
+#ifdef GHCI
+import qualified Data.Map as Map
+#endif
\end{code}
@@ -95,6 +99,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 ;
@@ -107,6 +112,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 a4be867dc571..c6f03f6cea32 100644
--- a/compiler/typecheck/TcRnTypes.lhs
+++ b/compiler/typecheck/TcRnTypes.lhs
@@ -118,6 +118,10 @@ import Util
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}
@@ -309,6 +313,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 7807f58af725..c8063d90929d 100644
--- a/compiler/typecheck/TcSplice.lhs
+++ b/compiler/typecheck/TcSplice.lhs
@@ -84,6 +84,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# )
@@ -1089,6 +1093,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}
--
GitLab