Commit 567dbd9b authored by Facundo Domínguez's avatar Facundo Domínguez

Have addModFinalizer expose the local type environment.

Summary:
This annotates the splice point with 'HsSpliced ref e' where 'e' is the
result of the splice. 'ref' is a reference that the typechecker will fill with
the local type environment.

The finalizer then reads the ref and uses the local type environment, which
causes 'reify' to find local variables when run in the finalizer.

Test Plan: ./validate

Reviewers: simonpj, simonmar, bgamari, austin, goldfire

Reviewed By: goldfire

Subscribers: simonmar, thomie, mboes

Differential Revision: https://phabricator.haskell.org/D2286

GHC Trac Issues: #11832
parent f560a03c
......@@ -1071,6 +1071,7 @@ repSplice :: HsSplice Name -> DsM (Core a)
repSplice (HsTypedSplice n _) = rep_splice n
repSplice (HsUntypedSplice n _) = rep_splice n
repSplice (HsQuasiQuote n _ _ _) = rep_splice n
repSplice e@(HsSpliced _ _) = pprPanic "repSplice" (ppr e)
rep_splice :: Name -> DsM (Core a)
rep_splice splice_name
......
......@@ -45,8 +45,14 @@ import Type
-- libraries:
import Data.Data hiding (Fixity(..))
import qualified Data.Data as Data (Fixity(..))
import Data.Maybe (isNothing)
#ifdef GHCI
import GHCi.RemoteTypes ( ForeignRef )
import qualified Language.Haskell.TH as TH (Q)
#endif
{-
************************************************************************
* *
......@@ -1926,12 +1932,55 @@ data HsSplice id
SrcSpan -- The span of the enclosed string
FastString -- The enclosed string
| HsSpliced -- See Note [Delaying modFinalizers in untyped splices] in
-- RnSplice.
-- This is the result of splicing a splice. It is produced by
-- the renamer and consumed by the typechecker. It lives only
-- between the two.
ThModFinalizers -- TH finalizers produced by the splice.
(HsSplicedThing id) -- The result of splicing
deriving Typeable
deriving instance (DataId id) => Data (HsSplice id)
isTypedSplice :: HsSplice id -> Bool
isTypedSplice (HsTypedSplice {}) = True
isTypedSplice _ = False -- Quasi-quotes are untyped splices
-- | Finalizers produced by a splice with
-- 'Language.Haskell.TH.Syntax.addModFinalizer'
--
-- See Note [Delaying modFinalizers in untyped splices] in RnSplice. For how
-- this is used.
--
#ifdef GHCI
newtype ThModFinalizers = ThModFinalizers [ForeignRef (TH.Q ())]
#else
data ThModFinalizers = ThModFinalizers
#endif
-- A Data instance which ignores the argument of 'ThModFinalizers'.
#ifdef GHCI
instance Data ThModFinalizers where
gunfold _ z _ = z $ ThModFinalizers []
toConstr a = mkConstr (dataTypeOf a) "ThModFinalizers" [] Data.Prefix
dataTypeOf a = mkDataType "HsExpr.ThModFinalizers" [toConstr a]
#else
instance Data ThModFinalizers where
gunfold _ z _ = z ThModFinalizers
toConstr a = mkConstr (dataTypeOf a) "ThModFinalizers" [] Data.Prefix
dataTypeOf a = mkDataType "HsExpr.ThModFinalizers" [toConstr a]
#endif
-- | Values that can result from running a splice.
data HsSplicedThing id
= HsSplicedExpr (HsExpr id)
| HsSplicedTy (HsType id)
| HsSplicedPat (Pat id)
deriving Typeable
deriving instance (DataId id) => Data (HsSplicedThing id)
-- See Note [Pending Splices]
type SplicePointName = Name
......@@ -2015,6 +2064,11 @@ splices. In contrast, when pretty printing the output of the type checker, we
sense, although I hate to add another constructor to HsExpr.
-}
instance OutputableBndrId id => Outputable (HsSplicedThing id) where
ppr (HsSplicedExpr e) = ppr_expr e
ppr (HsSplicedTy t) = ppr t
ppr (HsSplicedPat p) = ppr p
instance (OutputableBndrId id) => Outputable (HsSplice id) where
ppr s = pprSplice s
......@@ -2026,6 +2080,7 @@ pprSplice :: (OutputableBndrId id) => HsSplice id -> SDoc
pprSplice (HsTypedSplice n e) = ppr_splice (text "$$") n e
pprSplice (HsUntypedSplice n e) = ppr_splice (text "$") n e
pprSplice (HsQuasiQuote n q _ s) = ppr_quasi n q s
pprSplice (HsSpliced _ thing) = ppr thing
ppr_quasi :: OutputableBndr id => id -> id -> FastString -> SDoc
ppr_quasi n quoter quote = ifPprDebug (brackets (ppr n)) <>
......
......@@ -446,6 +446,10 @@ rnPatAndThen mk (TuplePat pats boxed _)
; pats' <- rnLPatsAndThen mk pats
; return (TuplePat pats' boxed []) }
-- If a splice has been run already, just rename the result.
rnPatAndThen mk (SplicePat (HsSpliced mfs (HsSplicedPat pat)))
= SplicePat . HsSpliced mfs . HsSplicedPat <$> rnPatAndThen mk pat
rnPatAndThen mk (SplicePat splice)
= do { eith <- liftCpsFV $ rnSplicePat splice
; case eith of -- See Note [rnSplicePat] in RnSplice
......
This diff is collapsed.
......@@ -1031,6 +1031,7 @@ collectAnonWildCards lty = go lty
`mappend` go ty
HsQualTy { hst_ctxt = L _ ctxt
, hst_body = ty } -> gos ctxt `mappend` go ty
HsSpliceTy (HsSpliced _ (HsSplicedTy ty)) _ -> go $ L noSrcSpan ty
-- HsQuasiQuoteTy, HsSpliceTy, HsCoreTy, HsTyLit
_ -> mempty
......
......@@ -981,6 +981,14 @@ tcExpr (PArrSeq _ _) _
************************************************************************
-}
-- HsSpliced is an annotation produced by 'RnSplice.rnSpliceExpr'.
-- Here we get rid of it and add the finalizers to the global environment.
--
-- See Note [Delaying modFinalizers in untyped splices] in RnSplice.
tcExpr (HsSpliceE (HsSpliced mod_finalizers (HsSplicedExpr expr)))
res_ty
= do addModFinalizersWithLclEnv mod_finalizers
tcExpr expr res_ty
tcExpr (HsSpliceE splice) res_ty
= tcSpliceExpr splice res_ty
tcExpr (HsBracket brack) res_ty
......
......@@ -501,6 +501,18 @@ tc_hs_type _ ty@(HsRecTy _) _
-- signatures) should have been removed by now
= failWithTc (text "Record syntax is illegal here:" <+> ppr ty)
-- HsSpliced is an annotation produced by 'RnSplice.rnSpliceType'.
-- Here we get rid of it and add the finalizers to the global environment
-- while capturing the local environment.
--
-- See Note [Delaying modFinalizers in untyped splices].
tc_hs_type mode (HsSpliceTy (HsSpliced mod_finalizers (HsSplicedTy ty))
_
)
exp_kind
= do addModFinalizersWithLclEnv mod_finalizers
tc_hs_type mode ty exp_kind
-- This should never happen; type splices are expanded by the renamer
tc_hs_type _ ty@(HsSpliceTy {}) _exp_kind
= failWithTc (text "Unexpected type splice:" <+> ppr ty)
......
......@@ -583,6 +583,15 @@ tc_pat penv (NPlusKPat (L nm_loc name) (L loc lit) _ ge minus _) pat_ty thing_in
ge' minus'' pat_ty
; return (pat', res) }
-- HsSpliced is an annotation produced by 'RnSplice.rnSplicePat'.
-- Here we get rid of it and add the finalizers to the global environment.
--
-- See Note [Delaying modFinalizers in untyped splices] in RnSplice.
tc_pat penv (SplicePat (HsSpliced mod_finalizers (HsSplicedPat pat)))
pat_ty thing_inside
= do addModFinalizersWithLclEnv mod_finalizers
tc_pat penv pat pat_ty thing_inside
tc_pat _ _other_pat _ _ = panic "tc_pat" -- ConPatOut, SigPatOut
----------------
......
......@@ -106,6 +106,7 @@ module TcRnMonad(
-- * Template Haskell context
recordThUse, recordThSpliceUse, recordTopLevelSpliceLoc,
getTopLevelSpliceLocs, keepAlive, getStage, getStageAndBindLevel, setStage,
addModFinalizersWithLclEnv,
-- * Safe Haskell context
recordUnsafeInfer, finalSafeMode, fixSafeInstances,
......@@ -174,6 +175,7 @@ import Data.Set ( Set )
import qualified Data.Set as Set
#ifdef GHCI
import {-# SOURCE #-} TcSplice ( runRemoteModFinalizers )
import qualified Data.Map as Map
#endif
......@@ -1529,6 +1531,21 @@ getStageAndBindLevel name
setStage :: ThStage -> TcM a -> TcRn a
setStage s = updLclEnv (\ env -> env { tcl_th_ctxt = s })
#ifdef GHCI
-- | Adds the given modFinalizers to the global environment and set them to use
-- the current local environment.
addModFinalizersWithLclEnv :: ThModFinalizers -> TcM ()
addModFinalizersWithLclEnv mod_finalizers
= do lcl_env <- getLclEnv
th_modfinalizers_var <- fmap tcg_th_modfinalizers getGblEnv
updTcRef th_modfinalizers_var $ \fins ->
setLclEnv lcl_env (runRemoteModFinalizers mod_finalizers)
: fins
#else
addModFinalizersWithLclEnv :: ThModFinalizers -> TcM ()
addModFinalizersWithLclEnv ThModFinalizers = return ()
#endif
{-
************************************************************************
* *
......
......@@ -502,8 +502,11 @@ data TcGblEnv
tcg_th_topnames :: TcRef NameSet,
-- ^ Exact names bound in top-level declarations in tcg_th_topdecls
tcg_th_modfinalizers :: TcRef [TH.Q ()],
-- ^ Template Haskell module finalizers
tcg_th_modfinalizers :: TcRef [TcM ()],
-- ^ Template Haskell module finalizers.
--
-- They are computations in the @TcM@ monad rather than @Q@ because we
-- set them to use particular local environments.
tcg_th_state :: TcRef (Map TypeRep Dynamic),
tcg_th_remote_state :: TcRef (Maybe (ForeignRef (IORef QState))),
......@@ -788,6 +791,25 @@ data ThStage -- See Note [Template Haskell state diagram] in TcSplice
-- the result replaces the splice
-- Binding level = 0
#ifdef GHCI
| RunSplice (TcRef [ForeignRef (TH.Q ())])
-- Set when running a splice, i.e. NOT when renaming or typechecking the
-- Haskell code for the splice. See Note [RunSplice ThLevel].
--
-- Contains a list of mod finalizers collected while executing the splice.
--
-- 'addModFinalizer' inserts finalizers here, and from here they are taken
-- to construct an @HsSpliced@ annotation for untyped splices. See Note
-- [Delaying modFinalizers in untyped splices] in "RnSplice".
--
-- For typed splices, the typechecker takes finalizers from here and
-- inserts them in the list of finalizers in the global environment.
--
-- See Note [Collecting modFinalizers in typed splices] in "TcSplice".
#else
| RunSplice ()
#endif
| Comp -- Ordinary Haskell code
-- Binding level = 1
......@@ -811,9 +833,10 @@ topAnnStage = Splice Untyped
topSpliceStage = Splice Untyped
instance Outputable ThStage where
ppr (Splice _) = text "Splice"
ppr Comp = text "Comp"
ppr (Brack s _) = text "Brack" <> parens (ppr s)
ppr (Splice _) = text "Splice"
ppr (RunSplice _) = text "RunSplice"
ppr Comp = text "Comp"
ppr (Brack s _) = text "Brack" <> parens (ppr s)
type ThLevel = Int
-- NB: see Note [Template Haskell levels] in TcSplice
......@@ -827,9 +850,25 @@ impLevel = 0 -- Imported things; they can be used inside a top level splice
outerLevel = 1 -- Things defined outside brackets
thLevel :: ThStage -> ThLevel
thLevel (Splice _) = 0
thLevel Comp = 1
thLevel (Brack s _) = thLevel s + 1
thLevel (Splice _) = 0
thLevel (RunSplice _) =
-- See Note [RunSplice ThLevel].
panic "thLevel: called when running a splice"
thLevel Comp = 1
thLevel (Brack s _) = thLevel s + 1
{- Node [RunSplice ThLevel]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The 'RunSplice' stage is set when executing a splice, and only when running a
splice. In particular it is not set when the splice is renamed or typechecked.
'RunSplice' is needed to provide a reference where 'addModFinalizer' can insert
the finalizer (see Note [Delaying modFinalizers in untyped splices]), and
'addModFinalizer' runs when doing Q things. Therefore, It doesn't make sense to
set 'RunSplice' when renaming or typechecking the splice, where 'Splice', 'Brak'
or 'Comp' are used instead.
-}
---------------------------
-- Arrow-notation context
......
......@@ -29,7 +29,7 @@ module TcSplice(
-- called only in stage2 (ie GHCI is on)
runMetaE, runMetaP, runMetaT, runMetaD, runQuasi,
tcTopSpliceExpr, lookupThName_maybe,
defaultRunMeta, runMeta',
defaultRunMeta, runMeta', runRemoteModFinalizers,
finishTH
#endif
) where
......@@ -446,12 +446,28 @@ tcSpliceExpr splice@(HsTypedSplice name expr) res_ty
setSrcSpan (getLoc expr) $ do
{ stage <- getStage
; case stage of
Splice {} -> tcTopSplice expr res_ty
Comp -> tcTopSplice expr res_ty
Brack pop_stage pend -> tcNestedSplice pop_stage pend name expr res_ty }
Splice {} -> tcTopSplice expr res_ty
Brack pop_stage pend -> tcNestedSplice pop_stage pend name expr res_ty
RunSplice _ ->
-- See Note [RunSplice ThLevel] in "TcRnTypes".
pprPanic ("tcSpliceExpr: attempted to typecheck a splice when " ++
"running another splice") (ppr splice)
Comp -> tcTopSplice expr res_ty
}
tcSpliceExpr splice _
= pprPanic "tcSpliceExpr" (ppr splice)
{- Note [Collecting modFinalizers in typed splices]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'qAddModFinalizer' of the @Quasi TcM@ instance adds finalizers in the local
environment (see Note [Delaying modFinalizers in untyped splices] in
"RnSplice"). Thus after executing the splice, we move the finalizers to the
finalizer list in the global environment and set them to use the current local
environment (with 'addModFinalizersWithLclEnv').
-}
tcNestedSplice :: ThStage -> PendingStuff -> Name
-> LHsExpr Name -> ExpRhoType -> TcM (HsExpr Id)
-- See Note [How brackets and nested splices are handled]
......@@ -482,8 +498,13 @@ tcTopSplice expr res_ty
; zonked_q_expr <- tcTopSpliceExpr Typed $
tcMonoExpr expr (mkCheckExpType meta_exp_ty)
-- See Note [Collecting modFinalizers in typed splices].
; modfinalizers_ref <- newTcRef []
-- Run the expression
; expr2 <- runMetaE zonked_q_expr
; expr2 <- setStage (RunSplice modfinalizers_ref) $
runMetaE zonked_q_expr
; mod_finalizers <- readTcRef modfinalizers_ref
; addModFinalizersWithLclEnv $ ThModFinalizers mod_finalizers
; traceSplice (SpliceInfo { spliceDescription = "expression"
, spliceIsDecl = False
, spliceSource = Just expr
......@@ -618,6 +639,29 @@ seqSerialized (Serialized the_type bytes) = the_type `seq` bytes `seqList` ()
runQuasi :: TH.Q a -> TcM a
runQuasi act = TH.runQ act
runRemoteModFinalizers :: ThModFinalizers -> TcM ()
runRemoteModFinalizers (ThModFinalizers finRefs) = do
dflags <- getDynFlags
let withForeignRefs [] f = f []
withForeignRefs (x : xs) f = withForeignRef x $ \r ->
withForeignRefs xs $ \rs -> f (r : rs)
if gopt Opt_ExternalInterpreter dflags then do
hsc_env <- env_top <$> getEnv
withIServ hsc_env $ \i -> do
tcg <- getGblEnv
th_state <- readTcRef (tcg_th_remote_state tcg)
case th_state of
Nothing -> return () -- TH was not started, nothing to do
Just fhv -> do
liftIO $ withForeignRef fhv $ \st ->
withForeignRefs finRefs $ \qrefs ->
writeIServ i (putMessage (RunModFinalizers st qrefs))
() <- runRemoteTH i []
readQResult i
else do
qs <- liftIO (withForeignRefs finRefs $ mapM localRef)
runQuasi $ sequence_ qs
runQResult
:: (a -> String)
-> (SrcSpan -> a -> b)
......@@ -884,8 +928,9 @@ instance TH.Quasi TcM where
2 (text "Probable cause: you used mkName instead of newName to generate a binding.")
qAddModFinalizer fin = do
th_modfinalizers_var <- fmap tcg_th_modfinalizers getGblEnv
updTcRef th_modfinalizers_var (\fins -> fin:fins)
r <- liftIO $ mkRemoteRef fin
fref <- liftIO $ mkForeignRef r (freeRemoteRef r)
addModFinalizerRef fref
qGetQ :: forall a. Typeable a => TcM (Maybe a)
qGetQ = do
......@@ -904,30 +949,30 @@ instance TH.Quasi TcM where
dflags <- hsc_dflags <$> getTopEnv
return $ map toEnum $ IntSet.elems $ extensionFlags dflags
-- | Adds a mod finalizer reference to the local environment.
addModFinalizerRef :: ForeignRef (TH.Q ()) -> TcM ()
addModFinalizerRef finRef = do
th_stage <- getStage
case th_stage of
RunSplice th_modfinalizers_var -> updTcRef th_modfinalizers_var (finRef :)
-- This case happens only if a splice is executed and the caller does
-- not set the 'ThStage' to 'RunSplice' to collect finalizers.
-- See Note [Delaying modFinalizers in untyped splices] in RnSplice.
_ ->
pprPanic "addModFinalizer was called when no finalizers were collected"
(ppr th_stage)
-- | Run all module finalizers
finishTH :: TcM ()
finishTH = do
hsc_env <- env_top <$> getEnv
tcg <- getGblEnv
let th_modfinalizers_var = tcg_th_modfinalizers tcg
modfinalizers <- readTcRef th_modfinalizers_var
writeTcRef th_modfinalizers_var []
sequence_ modfinalizers
dflags <- getDynFlags
if not (gopt Opt_ExternalInterpreter dflags)
then do
tcg <- getGblEnv
let th_modfinalizers_var = tcg_th_modfinalizers tcg
modfinalizers <- readTcRef th_modfinalizers_var
writeTcRef th_modfinalizers_var []
mapM_ runQuasi modfinalizers
else withIServ hsc_env $ \i -> do
tcg <- getGblEnv
th_state <- readTcRef (tcg_th_remote_state tcg)
case th_state of
Nothing -> return () -- TH was not started, nothing to do
Just fhv -> do
liftIO $ withForeignRef fhv $ \rhv ->
writeIServ i (putMessage (FinishTH rhv))
() <- runRemoteTH i []
() <- readQResult i
writeTcRef (tcg_th_remote_state tcg) Nothing
when (gopt Opt_ExternalInterpreter dflags) $
writeTcRef (tcg_th_remote_state tcg) Nothing
runTHExp :: ForeignHValue -> TcM TH.Exp
runTHExp = runTH THExp
......@@ -1073,6 +1118,9 @@ handleTHMessage msg = case msg of
ReifyModule m -> wrapTHResult $ TH.qReifyModule m
ReifyConStrictness nm -> wrapTHResult $ TH.qReifyConStrictness nm
AddDependentFile f -> wrapTHResult $ TH.qAddDependentFile f
AddModFinalizer r -> do
hsc_env <- env_top <$> getEnv
wrapTHResult $ liftIO (mkFinalizedHValue hsc_env r) >>= addModFinalizerRef
AddTopDecls decs -> wrapTHResult $ TH.qAddTopDecls decs
IsExtEnabled ext -> wrapTHResult $ TH.qIsExtEnabled ext
ExtsEnabled -> wrapTHResult $ TH.qExtsEnabled
......
......@@ -9,7 +9,7 @@ import TcType ( ExpRhoType )
import Annotations ( Annotation, CoreAnnTarget )
#ifdef GHCI
import HsSyn ( LHsType, LPat, LHsDecl )
import HsSyn ( LHsType, LPat, LHsDecl, ThModFinalizers )
import RdrName ( RdrName )
import TcRnTypes ( SpliceType )
import qualified Language.Haskell.TH as TH
......@@ -39,5 +39,6 @@ runMetaD :: LHsExpr TcId -> TcM [LHsDecl RdrName]
lookupThName_maybe :: TH.Name -> TcM (Maybe Name)
runQuasi :: TH.Q a -> TcM a
runRemoteModFinalizers :: ThModFinalizers -> TcM ()
finishTH :: TcM ()
#endif
......@@ -53,7 +53,7 @@ serv verbose pipe@Pipe{..} restore = loop
case msg of
Shutdown -> return ()
RunTH st q ty loc -> wrapRunTH $ runTH pipe st q ty loc
FinishTH st -> wrapRunTH $ finishTH pipe st
RunModFinalizers st qrefs -> wrapRunTH $ runModFinalizerRefs pipe st qrefs
_other -> run msg >>= reply
reply :: forall a. (Binary a, Show a) => a -> IO ()
......
......@@ -172,9 +172,6 @@ data Message a where
-- | Start a new TH module, return a state token that should be
StartTH :: Message (RemoteRef (IORef QState))
-- | Run TH module finalizers, and free the HValueRef
FinishTH :: RemoteRef (IORef QState) -> Message (QResult ())
-- | Evaluate a TH computation.
--
-- Returns a ByteString, because we have to force the result
......@@ -189,6 +186,10 @@ data Message a where
-> Maybe TH.Loc
-> Message (QResult ByteString)
-- | Run the given mod finalizers.
RunModFinalizers :: RemoteRef (IORef QState)
-> [RemoteRef (TH.Q ())]
-> Message (QResult ())
deriving instance Show (Message a)
......@@ -223,6 +224,7 @@ data THMessage a where
ReifyConStrictness :: TH.Name -> THMessage (THResult [TH.DecidedStrictness])
AddDependentFile :: FilePath -> THMessage (THResult ())
AddModFinalizer :: RemoteRef (TH.Q ()) -> THMessage (THResult ())
AddTopDecls :: [TH.Dec] -> THMessage (THResult ())
IsExtEnabled :: Extension -> THMessage (THResult Bool)
ExtsEnabled :: THMessage (THResult [Extension])
......@@ -258,7 +260,8 @@ getTHMessage = do
13 -> THMsg <$> return ExtsEnabled
14 -> THMsg <$> return StartRecover
15 -> THMsg <$> EndRecover <$> get
_ -> return (THMsg RunTHDone)
16 -> return (THMsg RunTHDone)
_ -> THMsg <$> AddModFinalizer <$> get
putTHMessage :: THMessage a -> Put
putTHMessage m = case m of
......@@ -279,6 +282,7 @@ putTHMessage m = case m of
StartRecover -> putWord8 14
EndRecover a -> putWord8 15 >> put a
RunTHDone -> putWord8 16
AddModFinalizer a -> putWord8 17 >> put a
data EvalOpts = EvalOpts
......@@ -368,8 +372,6 @@ instance Binary THResultType
data QState = QState
{ qsMap :: Map TypeRep Dynamic
-- ^ persistent data between splices in a module
, qsFinalizers :: [TH.Q ()]
-- ^ registered finalizers (in reverse order)
, qsLocation :: Maybe TH.Loc
-- ^ location for current splice, if any
, qsPipe :: Pipe
......@@ -415,7 +417,7 @@ getMessage = do
29 -> Msg <$> (BreakpointStatus <$> get <*> get)
30 -> Msg <$> (GetBreakpointVar <$> get <*> get)
31 -> Msg <$> return StartTH
32 -> Msg <$> FinishTH <$> get
32 -> Msg <$> (RunModFinalizers <$> get <*> get)
_ -> Msg <$> (RunTH <$> get <*> get <*> get <*> get)
putMessage :: Message a -> Put
......@@ -452,7 +454,7 @@ putMessage m = case m of
BreakpointStatus arr ix -> putWord8 29 >> put arr >> put ix
GetBreakpointVar a b -> putWord8 30 >> put a >> put b
StartTH -> putWord8 31
FinishTH val -> putWord8 32 >> put val
RunModFinalizers a b -> putWord8 32 >> put a >> put b
RunTH st q loc ty -> putWord8 33 >> put st >> put q >> put loc >> put ty
-- -----------------------------------------------------------------------------
......
......@@ -5,7 +5,12 @@
-- |
-- Running TH splices
--
module GHCi.TH (startTH, finishTH, runTH, GHCiQException(..)) where
module GHCi.TH
( startTH
, runModFinalizerRefs
, runTH
, GHCiQException(..)
) where
{- Note [Remote Template Haskell]
......@@ -110,14 +115,7 @@ import Unsafe.Coerce
-- | Create a new instance of 'QState'
initQState :: Pipe -> QState
initQState p = QState M.empty [] Nothing p
runModFinalizers :: GHCiQ ()
runModFinalizers = go =<< getState
where
go s | (f:ff) <- qsFinalizers s = do
putState (s { qsFinalizers = ff}) >> TH.runQ f >> getState >>= go
go _ = return ()
initQState p = QState M.empty Nothing p
-- | The monad in which we run TH computations on the server
newtype GHCiQ a = GHCiQ { runGHCiQ :: QState -> IO (a, QState) }
......@@ -151,9 +149,6 @@ instance Fail.MonadFail GHCiQ where
getState :: GHCiQ QState
getState = GHCiQ $ \s -> return (s,s)
putState :: QState -> GHCiQ ()
putState s = GHCiQ $ \_ -> return ((),s)
noLoc :: TH.Loc
noLoc = TH.Loc "<no file>" "<no package>" "<no module>" (0,0) (0,0)
......@@ -198,8 +193,8 @@ instance TH.Quasi GHCiQ where
qRunIO m = GHCiQ $ \s -> fmap (,s) m
qAddDependentFile file = ghcCmd (AddDependentFile file)
qAddTopDecls decls = ghcCmd (AddTopDecls decls)
qAddModFinalizer fin = GHCiQ $ \s ->
return ((), s { qsFinalizers = fin : qsFinalizers s })
qAddModFinalizer fin = GHCiQ (\s -> mkRemoteRef fin >>= return . (, s)) >>=
ghcCmd . AddModFinalizer
qGetQ = GHCiQ $ \s ->
let lookup :: forall a. Typeable a => Map TypeRep Dynamic -> Maybe a
lookup m = fromDynamic =<< M.lookup (typeOf (undefined::a)) m
......@@ -216,12 +211,17 @@ startTH = do
r <- newIORef (initQState (error "startTH: no pipe"))
mkRemoteRef r
-- | The implementation of the 'FinishTH' message.
finishTH :: Pipe -> RemoteRef (IORef QState) -> IO ()
finishTH pipe rstate = do
-- | Runs the mod finalizers.
--
-- The references must be created on the caller process.
runModFinalizerRefs :: Pipe -> RemoteRef (IORef QState)
-> [RemoteRef (TH.Q ())]
-> IO ()
runModFinalizerRefs pipe rstate qrefs = do
qs <- mapM localRef qrefs
qstateref <- localRef rstate
qstate <- readIORef qstateref
_ <- runGHCiQ runModFinalizers qstate { qsPipe = pipe }
_ <- runGHCiQ (TH.runQ $ sequence_ qs) qstate { qsPipe = pipe }
return ()
-- | The implementation of the 'RunTH' message
......
......@@ -458,6 +458,10 @@ 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.
--
-- The finalizer is given the local type environment at the splice point. Thus
-- 'reify' is able to find the local definitions when executed inside the
-- finalizer.
addModFinalizer :: Q () -> Q ()
addModFinalizer act = Q (qAddModFinalizer (unQ act))
......
-- test reification of local definitions
{-# LANGUAGE CPP #-}
{-# LANGUAGE TemplateHaskell #-}
import Language.Haskell.TH.Syntax
import System.IO
-- Sidestep the staging restriction
-- printTypeOf :: String -> Q ()
#define printTypeOf(n) (addModFinalizer $ do \
{ VarI _ t _ <- reify (mkName (n)) \
; runIO $ hPutStrLn stderr (n ++ " :: " ++ show t) \
})
main :: IO ()
main = print (f 1 "", g 'a' 2, h True 3)
where
f xf yf = ( xf :: Int
, let ff $(do printTypeOf("yf")
[p| z |]
) = z :: $(do printTypeOf("z")
[t| () |]
)
in $(do printTypeOf("xf")
[| yf :: String |]
)
)
g xg y = ( $(do printTypeOf("xg")
[| y :: Int |]
)
, xg :: Char
)
h xh y = ( $$(do printTypeOf("xh")
[|| y :: Int ||]
)
, xh :: Bool
)
xh :: ConT GHC.Types.Bool
xf :: ConT GHC.Types.Int
z :: TupleT 0
yf :: ConT GHC.Base.String
xg :: ConT GHC.Types.Char
......@@ -77,6 +77,7 @@ test('TH_spliceD2',
test('TH_reifyDecl1', normal, compile, ['-v0'])
test('TH_reifyDecl2', normal, compile, ['-v0'])
test('TH_reifyLocalDefs', normal, compile, ['-v0'])
test('TH_reifyMkName', normal, compile, ['-v0'])
......
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