never executed always true always false
1 {-# LANGUAGE ScopedTypeVariables, StandaloneDeriving, DeriveGeneric,
2 TupleSections, RecordWildCards, InstanceSigs, CPP #-}
3 {-# OPTIONS_GHC -fno-warn-name-shadowing #-}
4
5 -- |
6 -- Running TH splices
7 --
8 module GHCi.TH
9 ( startTH
10 , runModFinalizerRefs
11 , runTH
12 , GHCiQException(..)
13 ) where
14
15 {- Note [Remote Template Haskell]
16
17 Here is an overview of how TH works with -fexternal-interpreter.
18
19 Initialisation
20 ~~~~~~~~~~~~~~
21
22 GHC sends a StartTH message to the server (see GHC.Tc.Gen.Splice.getTHState):
23
24 StartTH :: Message (RemoteRef (IORef QState))
25
26 The server creates an initial QState object, makes an IORef to it, and
27 returns a RemoteRef to this to GHC. (see GHCi.TH.startTH below).
28
29 This happens once per module, the first time we need to run a TH
30 splice. The reference that GHC gets back is kept in
31 tcg_th_remote_state in the TcGblEnv, and passed to each RunTH call
32 that follows.
33
34
35 For each splice
36 ~~~~~~~~~~~~~~~
37
38 1. GHC compiles a splice to byte code, and sends it to the server: in
39 a CreateBCOs message:
40
41 CreateBCOs :: [LB.ByteString] -> Message [HValueRef]
42
43 2. The server creates the real byte-code objects in its heap, and
44 returns HValueRefs to GHC. HValueRef is the same as RemoteRef
45 HValue.
46
47 3. GHC sends a RunTH message to the server:
48
49 RunTH
50 :: RemoteRef (IORef QState)
51 -- The state returned by StartTH in step1
52 -> HValueRef
53 -- The HValueRef we got in step 4, points to the code for the splice
54 -> THResultType
55 -- Tells us what kind of splice this is (decl, expr, type, etc.)
56 -> Maybe TH.Loc
57 -- Source location
58 -> Message (QResult ByteString)
59 -- Eventually it will return a QResult back to GHC. The
60 -- ByteString here is the (encoded) result of the splice.
61
62 4. The server runs the splice code.
63
64 5. Each time the splice code calls a method of the Quasi class, such
65 as qReify, a message is sent from the server to GHC. These
66 messages are defined by the THMessage type. GHC responds with the
67 result of the request, e.g. in the case of qReify it would be the
68 TH.Info for the requested entity.
69
70 6. When the splice has been fully evaluated, the server sends
71 RunTHDone back to GHC. This tells GHC that the server has finished
72 sending THMessages and will send the QResult next.
73
74 8. The server then sends a QResult back to GHC, which is notionally
75 the response to the original RunTH message. The QResult indicates
76 whether the splice succeeded, failed, or threw an exception.
77
78
79 After typechecking
80 ~~~~~~~~~~~~~~~~~~
81
82 GHC sends a FinishTH message to the server (see GHC.Tc.Gen.Splice.finishTH).
83 The server runs any finalizers that were added by addModuleFinalizer.
84
85
86 Other Notes on TH / Remote GHCi
87
88 * Note [Remote GHCi] in compiler/GHC/Runtime/Interpreter.hs
89 * Note [External GHCi pointers] in compiler/GHC/Runtime/Interpreter.hs
90 * Note [TH recover with -fexternal-interpreter] in GHC.Tc.Gen.Splice
91 -}
92
93 import Prelude -- See note [Why do we import Prelude here?]
94 import GHCi.Message
95 import GHCi.RemoteTypes
96 import GHC.Serialized
97
98 import Control.Exception
99 import Control.Monad.IO.Class (MonadIO (..))
100 import Data.Binary
101 import Data.Binary.Put
102 import Data.ByteString (ByteString)
103 import qualified Data.ByteString as B
104 import qualified Data.ByteString.Lazy as LB
105 import Data.Data
106 import Data.Dynamic
107 import Data.Either
108 import Data.IORef
109 import Data.Map (Map)
110 import qualified Data.Map as M
111 import Data.Maybe
112 import GHC.Desugar
113 import qualified Language.Haskell.TH as TH
114 import qualified Language.Haskell.TH.Syntax as TH
115 import Unsafe.Coerce
116
117 -- | Create a new instance of 'QState'
118 initQState :: Pipe -> QState
119 initQState p = QState M.empty Nothing p
120
121 -- | The monad in which we run TH computations on the server
122 newtype GHCiQ a = GHCiQ { runGHCiQ :: QState -> IO (a, QState) }
123
124 -- | The exception thrown by "fail" in the GHCiQ monad
125 data GHCiQException = GHCiQException QState String
126 deriving Show
127
128 instance Exception GHCiQException
129
130 instance Functor GHCiQ where
131 fmap f (GHCiQ s) = GHCiQ $ fmap (\(x,s') -> (f x,s')) . s
132
133 instance Applicative GHCiQ where
134 f <*> a = GHCiQ $ \s ->
135 do (f',s') <- runGHCiQ f s
136 (a',s'') <- runGHCiQ a s'
137 return (f' a', s'')
138 pure x = GHCiQ (\s -> return (x,s))
139
140 instance Monad GHCiQ where
141 m >>= f = GHCiQ $ \s ->
142 do (m', s') <- runGHCiQ m s
143 (a, s'') <- runGHCiQ (f m') s'
144 return (a, s'')
145
146 instance MonadFail GHCiQ where
147 fail err = GHCiQ $ \s -> throwIO (GHCiQException s err)
148
149 getState :: GHCiQ QState
150 getState = GHCiQ $ \s -> return (s,s)
151
152 noLoc :: TH.Loc
153 noLoc = TH.Loc "<no file>" "<no package>" "<no module>" (0,0) (0,0)
154
155 -- | Send a 'THMessage' to GHC and return the result.
156 ghcCmd :: Binary a => THMessage (THResult a) -> GHCiQ a
157 ghcCmd m = GHCiQ $ \s -> do
158 r <- remoteTHCall (qsPipe s) m
159 case r of
160 THException str -> throwIO (GHCiQException s str)
161 THComplete res -> return (res, s)
162
163 instance MonadIO GHCiQ where
164 liftIO m = GHCiQ $ \s -> fmap (,s) m
165
166 instance TH.Quasi GHCiQ where
167 qNewName str = ghcCmd (NewName str)
168 qReport isError msg = ghcCmd (Report isError msg)
169
170 -- See Note [TH recover with -fexternal-interpreter] in GHC.Tc.Gen.Splice
171 qRecover (GHCiQ h) a = GHCiQ $ \s -> mask $ \unmask -> do
172 remoteTHCall (qsPipe s) StartRecover
173 e <- try $ unmask $ runGHCiQ (a <* ghcCmd FailIfErrs) s
174 remoteTHCall (qsPipe s) (EndRecover (isLeft e))
175 case e of
176 Left GHCiQException{} -> h s
177 Right r -> return r
178 qLookupName isType occ = ghcCmd (LookupName isType occ)
179 qReify name = ghcCmd (Reify name)
180 qReifyFixity name = ghcCmd (ReifyFixity name)
181 qReifyType name = ghcCmd (ReifyType name)
182 qReifyInstances name tys = ghcCmd (ReifyInstances name tys)
183 qReifyRoles name = ghcCmd (ReifyRoles name)
184
185 -- To reify annotations, we send GHC the AnnLookup and also the
186 -- TypeRep of the thing we're looking for, to avoid needing to
187 -- serialize irrelevant annotations.
188 qReifyAnnotations :: forall a . Data a => TH.AnnLookup -> GHCiQ [a]
189 qReifyAnnotations lookup =
190 map (deserializeWithData . B.unpack) <$>
191 ghcCmd (ReifyAnnotations lookup typerep)
192 where typerep = typeOf (undefined :: a)
193
194 qReifyModule m = ghcCmd (ReifyModule m)
195 qReifyConStrictness name = ghcCmd (ReifyConStrictness name)
196 qLocation = fromMaybe noLoc . qsLocation <$> getState
197 qAddDependentFile file = ghcCmd (AddDependentFile file)
198 qAddTempFile suffix = ghcCmd (AddTempFile suffix)
199 qAddTopDecls decls = ghcCmd (AddTopDecls decls)
200 qAddForeignFilePath lang fp = ghcCmd (AddForeignFilePath lang fp)
201 qAddModFinalizer fin = GHCiQ (\s -> mkRemoteRef fin >>= return . (, s)) >>=
202 ghcCmd . AddModFinalizer
203 qAddCorePlugin str = ghcCmd (AddCorePlugin str)
204 qGetQ = GHCiQ $ \s ->
205 let lookup :: forall a. Typeable a => Map TypeRep Dynamic -> Maybe a
206 lookup m = fromDynamic =<< M.lookup (typeOf (undefined::a)) m
207 in return (lookup (qsMap s), s)
208 qPutQ k = GHCiQ $ \s ->
209 return ((), s { qsMap = M.insert (typeOf k) (toDyn k) (qsMap s) })
210 qIsExtEnabled x = ghcCmd (IsExtEnabled x)
211 qExtsEnabled = ghcCmd ExtsEnabled
212 qPutDoc l s = ghcCmd (PutDoc l s)
213 qGetDoc l = ghcCmd (GetDoc l)
214
215 -- | The implementation of the 'StartTH' message: create
216 -- a new IORef QState, and return a RemoteRef to it.
217 startTH :: IO (RemoteRef (IORef QState))
218 startTH = do
219 r <- newIORef (initQState (error "startTH: no pipe"))
220 mkRemoteRef r
221
222 -- | Runs the mod finalizers.
223 --
224 -- The references must be created on the caller process.
225 runModFinalizerRefs :: Pipe -> RemoteRef (IORef QState)
226 -> [RemoteRef (TH.Q ())]
227 -> IO ()
228 runModFinalizerRefs pipe rstate qrefs = do
229 qs <- mapM localRef qrefs
230 qstateref <- localRef rstate
231 qstate <- readIORef qstateref
232 _ <- runGHCiQ (TH.runQ $ sequence_ qs) qstate { qsPipe = pipe }
233 return ()
234
235 -- | The implementation of the 'RunTH' message
236 runTH
237 :: Pipe
238 -> RemoteRef (IORef QState)
239 -- ^ The TH state, created by 'startTH'
240 -> HValueRef
241 -- ^ The splice to run
242 -> THResultType
243 -- ^ What kind of splice it is
244 -> Maybe TH.Loc
245 -- ^ The source location
246 -> IO ByteString
247 -- ^ Returns an (encoded) result that depends on the THResultType
248
249 runTH pipe rstate rhv ty mb_loc = do
250 hv <- localRef rhv
251 case ty of
252 THExp -> runTHQ pipe rstate mb_loc (unsafeCoerce hv :: TH.Q TH.Exp)
253 THPat -> runTHQ pipe rstate mb_loc (unsafeCoerce hv :: TH.Q TH.Pat)
254 THType -> runTHQ pipe rstate mb_loc (unsafeCoerce hv :: TH.Q TH.Type)
255 THDec -> runTHQ pipe rstate mb_loc (unsafeCoerce hv :: TH.Q [TH.Dec])
256 THAnnWrapper -> do
257 hv <- unsafeCoerce <$> localRef rhv
258 case hv :: AnnotationWrapper of
259 AnnotationWrapper thing -> return $!
260 LB.toStrict (runPut (put (toSerialized serializeWithData thing)))
261
262 -- | Run a Q computation.
263 runTHQ
264 :: Binary a => Pipe -> RemoteRef (IORef QState) -> Maybe TH.Loc -> TH.Q a
265 -> IO ByteString
266 runTHQ pipe rstate mb_loc ghciq = do
267 qstateref <- localRef rstate
268 qstate <- readIORef qstateref
269 let st = qstate { qsLocation = mb_loc, qsPipe = pipe }
270 (r,new_state) <- runGHCiQ (TH.runQ ghciq) st
271 writeIORef qstateref new_state
272 return $! LB.toStrict (runPut (put r))