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