Commit 5e1fda81 authored by gmainland's avatar gmainland
Browse files

Add support for Template Haskell state.

parent 2d1b4a71
......@@ -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,
......
......@@ -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
......
......@@ -7,6 +7,7 @@ TcSplice: Template Haskell splices
\begin{code}
{-# LANGUAGE ScopedTypeVariables #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module TcSplice( tcSpliceType, tcSpliceExpr, tcSpliceDecls, tcBracket,
tcTopSpliceExpr,
......@@ -86,6 +87,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# )
......@@ -1094,6 +1099,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}
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment