diff --git a/compiler/typecheck/TcRnMonad.lhs b/compiler/typecheck/TcRnMonad.lhs index 3ceebab733ede1d10122b321cdfabc38d7c6e4eb..b4b3f38ea0cd6cca80994e492d54f6c1c5b6bdd5 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 a4be867dc571177309ef351ce862cd513eca08f5..c6f03f6cea32fe56e471531f8003dfe47337bcf3 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 7807f58af725c7aeb31a484462ab169a635f796a..c8063d90929d7c3a9e8996218ffc8e34215b2a2c 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}