Merge commit '7b0b9f603bb1215e2b7af23c2404d637b95a4988' as 'hadrian'
[ghc.git] / libraries / ghci / GHCi / TH.hs
1 {-# LANGUAGE ScopedTypeVariables, StandaloneDeriving, DeriveGeneric,
2 TupleSections, RecordWildCards, InstanceSigs #-}
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 TcSplice.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 TcSplice.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/ghci/GHCi.hs
89 * Note [External GHCi pointers] in compiler/ghci/GHCi.hs
90 * Note [TH recover with -fexternal-interpreter] in
91 compiler/typecheck/TcSplice.hs
92 -}
93
94 import GHCi.Message
95 import GHCi.RemoteTypes
96 import GHC.Serialized
97
98 import Control.Exception
99 import qualified Control.Monad.Fail as Fail
100 import Control.Monad.IO.Class (MonadIO (..))
101 import Data.Binary
102 import Data.Binary.Put
103 import Data.ByteString (ByteString)
104 import qualified Data.ByteString as B
105 import qualified Data.ByteString.Lazy as LB
106 import Data.Data
107 import Data.Dynamic
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 fail = Fail.fail
146
147 instance Fail.MonadFail GHCiQ where
148 fail err = GHCiQ $ \s -> throwIO (GHCiQException s err)
149
150 getState :: GHCiQ QState
151 getState = GHCiQ $ \s -> return (s,s)
152
153 noLoc :: TH.Loc
154 noLoc = TH.Loc "<no file>" "<no package>" "<no module>" (0,0) (0,0)
155
156 -- | Send a 'THMessage' to GHC and return the result.
157 ghcCmd :: Binary a => THMessage (THResult a) -> GHCiQ a
158 ghcCmd m = GHCiQ $ \s -> do
159 r <- remoteTHCall (qsPipe s) m
160 case r of
161 THException str -> throwIO (GHCiQException s str)
162 THComplete res -> return (res, s)
163
164 instance MonadIO GHCiQ where
165 liftIO m = GHCiQ $ \s -> fmap (,s) m
166
167 instance TH.Quasi GHCiQ where
168 qNewName str = ghcCmd (NewName str)
169 qReport isError msg = ghcCmd (Report isError msg)
170
171 -- See Note [TH recover with -fexternal-interpreter] in TcSplice
172 qRecover (GHCiQ h) (GHCiQ a) = GHCiQ $ \s -> (do
173 remoteTHCall (qsPipe s) StartRecover
174 (r, s') <- a s
175 remoteTHCall (qsPipe s) (EndRecover False)
176 return (r,s'))
177 `catch`
178 \GHCiQException{} -> remoteTHCall (qsPipe s) (EndRecover True) >> h s
179 qLookupName isType occ = ghcCmd (LookupName isType occ)
180 qReify name = ghcCmd (Reify name)
181 qReifyFixity name = ghcCmd (ReifyFixity 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 qAddTopDecls decls = ghcCmd (AddTopDecls decls)
199 qAddForeignFile str lang = ghcCmd (AddForeignFile str lang)
200 qAddModFinalizer fin = GHCiQ (\s -> mkRemoteRef fin >>= return . (, s)) >>=
201 ghcCmd . AddModFinalizer
202 qAddCorePlugin str = ghcCmd (AddCorePlugin str)
203 qGetQ = GHCiQ $ \s ->
204 let lookup :: forall a. Typeable a => Map TypeRep Dynamic -> Maybe a
205 lookup m = fromDynamic =<< M.lookup (typeOf (undefined::a)) m
206 in return (lookup (qsMap s), s)
207 qPutQ k = GHCiQ $ \s ->
208 return ((), s { qsMap = M.insert (typeOf k) (toDyn k) (qsMap s) })
209 qIsExtEnabled x = ghcCmd (IsExtEnabled x)
210 qExtsEnabled = ghcCmd ExtsEnabled
211
212 -- | The implementation of the 'StartTH' message: create
213 -- a new IORef QState, and return a RemoteRef to it.
214 startTH :: IO (RemoteRef (IORef QState))
215 startTH = do
216 r <- newIORef (initQState (error "startTH: no pipe"))
217 mkRemoteRef r
218
219 -- | Runs the mod finalizers.
220 --
221 -- The references must be created on the caller process.
222 runModFinalizerRefs :: Pipe -> RemoteRef (IORef QState)
223 -> [RemoteRef (TH.Q ())]
224 -> IO ()
225 runModFinalizerRefs pipe rstate qrefs = do
226 qs <- mapM localRef qrefs
227 qstateref <- localRef rstate
228 qstate <- readIORef qstateref
229 _ <- runGHCiQ (TH.runQ $ sequence_ qs) qstate { qsPipe = pipe }
230 return ()
231
232 -- | The implementation of the 'RunTH' message
233 runTH
234 :: Pipe
235 -> RemoteRef (IORef QState)
236 -- ^ The TH state, created by 'startTH'
237 -> HValueRef
238 -- ^ The splice to run
239 -> THResultType
240 -- ^ What kind of splice it is
241 -> Maybe TH.Loc
242 -- ^ The source location
243 -> IO ByteString
244 -- ^ Returns an (encoded) result that depends on the THResultType
245
246 runTH pipe rstate rhv ty mb_loc = do
247 hv <- localRef rhv
248 case ty of
249 THExp -> runTHQ pipe rstate mb_loc (unsafeCoerce hv :: TH.Q TH.Exp)
250 THPat -> runTHQ pipe rstate mb_loc (unsafeCoerce hv :: TH.Q TH.Pat)
251 THType -> runTHQ pipe rstate mb_loc (unsafeCoerce hv :: TH.Q TH.Type)
252 THDec -> runTHQ pipe rstate mb_loc (unsafeCoerce hv :: TH.Q [TH.Dec])
253 THAnnWrapper -> do
254 hv <- unsafeCoerce <$> localRef rhv
255 case hv :: AnnotationWrapper of
256 AnnotationWrapper thing -> return $!
257 LB.toStrict (runPut (put (toSerialized serializeWithData thing)))
258
259 -- | Run a Q computation.
260 runTHQ
261 :: Binary a => Pipe -> RemoteRef (IORef QState) -> Maybe TH.Loc -> TH.Q a
262 -> IO ByteString
263 runTHQ pipe@Pipe{..} rstate mb_loc ghciq = do
264 qstateref <- localRef rstate
265 qstate <- readIORef qstateref
266 let st = qstate { qsLocation = mb_loc, qsPipe = pipe }
267 (r,new_state) <- runGHCiQ (TH.runQ ghciq) st
268 writeIORef qstateref new_state
269 return $! LB.toStrict (runPut (put r))