Implement addCStub in template-haskell.
[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 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.IORef
108 import Data.Map (Map)
109 import qualified Data.Map as M
110 import Data.Maybe
111 import GHC.Desugar
112 import qualified Language.Haskell.TH as TH
113 import qualified Language.Haskell.TH.Syntax as TH
114 import Unsafe.Coerce
115
116 -- | Create a new instance of 'QState'
117 initQState :: Pipe -> QState
118 initQState p = QState M.empty Nothing p
119
120 -- | The monad in which we run TH computations on the server
121 newtype GHCiQ a = GHCiQ { runGHCiQ :: QState -> IO (a, QState) }
122
123 -- | The exception thrown by "fail" in the GHCiQ monad
124 data GHCiQException = GHCiQException QState String
125 deriving Show
126
127 instance Exception GHCiQException
128
129 instance Functor GHCiQ where
130 fmap f (GHCiQ s) = GHCiQ $ fmap (\(x,s') -> (f x,s')) . s
131
132 instance Applicative GHCiQ where
133 f <*> a = GHCiQ $ \s ->
134 do (f',s') <- runGHCiQ f s
135 (a',s'') <- runGHCiQ a s'
136 return (f' a', s'')
137 pure x = GHCiQ (\s -> return (x,s))
138
139 instance Monad GHCiQ where
140 m >>= f = GHCiQ $ \s ->
141 do (m', s') <- runGHCiQ m s
142 (a, s'') <- runGHCiQ (f m') s'
143 return (a, s'')
144 fail = Fail.fail
145
146 instance Fail.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 TH.Quasi GHCiQ where
164 qNewName str = ghcCmd (NewName str)
165 qReport isError msg = ghcCmd (Report isError msg)
166
167 -- See Note [TH recover with -fexternal-interpreter] in TcSplice
168 qRecover (GHCiQ h) (GHCiQ a) = GHCiQ $ \s -> (do
169 remoteTHCall (qsPipe s) StartRecover
170 (r, s') <- a s
171 remoteTHCall (qsPipe s) (EndRecover False)
172 return (r,s'))
173 `catch`
174 \GHCiQException{} -> remoteTHCall (qsPipe s) (EndRecover True) >> h s
175 qLookupName isType occ = ghcCmd (LookupName isType occ)
176 qReify name = ghcCmd (Reify name)
177 qReifyFixity name = ghcCmd (ReifyFixity name)
178 qReifyInstances name tys = ghcCmd (ReifyInstances name tys)
179 qReifyRoles name = ghcCmd (ReifyRoles name)
180
181 -- To reify annotations, we send GHC the AnnLookup and also the
182 -- TypeRep of the thing we're looking for, to avoid needing to
183 -- serialize irrelevant annotations.
184 qReifyAnnotations :: forall a . Data a => TH.AnnLookup -> GHCiQ [a]
185 qReifyAnnotations lookup =
186 map (deserializeWithData . B.unpack) <$>
187 ghcCmd (ReifyAnnotations lookup typerep)
188 where typerep = typeOf (undefined :: a)
189
190 qReifyModule m = ghcCmd (ReifyModule m)
191 qReifyConStrictness name = ghcCmd (ReifyConStrictness name)
192 qLocation = fromMaybe noLoc . qsLocation <$> getState
193 qRunIO m = GHCiQ $ \s -> fmap (,s) m
194 qAddDependentFile file = ghcCmd (AddDependentFile file)
195 qAddTopDecls decls = ghcCmd (AddTopDecls decls)
196 qAddCStub str = ghcCmd (AddCStub str)
197 qAddModFinalizer fin = GHCiQ (\s -> mkRemoteRef fin >>= return . (, s)) >>=
198 ghcCmd . AddModFinalizer
199 qGetQ = GHCiQ $ \s ->
200 let lookup :: forall a. Typeable a => Map TypeRep Dynamic -> Maybe a
201 lookup m = fromDynamic =<< M.lookup (typeOf (undefined::a)) m
202 in return (lookup (qsMap s), s)
203 qPutQ k = GHCiQ $ \s ->
204 return ((), s { qsMap = M.insert (typeOf k) (toDyn k) (qsMap s) })
205 qIsExtEnabled x = ghcCmd (IsExtEnabled x)
206 qExtsEnabled = ghcCmd ExtsEnabled
207
208 -- | The implementation of the 'StartTH' message: create
209 -- a new IORef QState, and return a RemoteRef to it.
210 startTH :: IO (RemoteRef (IORef QState))
211 startTH = do
212 r <- newIORef (initQState (error "startTH: no pipe"))
213 mkRemoteRef r
214
215 -- | Runs the mod finalizers.
216 --
217 -- The references must be created on the caller process.
218 runModFinalizerRefs :: Pipe -> RemoteRef (IORef QState)
219 -> [RemoteRef (TH.Q ())]
220 -> IO ()
221 runModFinalizerRefs pipe rstate qrefs = do
222 qs <- mapM localRef qrefs
223 qstateref <- localRef rstate
224 qstate <- readIORef qstateref
225 _ <- runGHCiQ (TH.runQ $ sequence_ qs) qstate { qsPipe = pipe }
226 return ()
227
228 -- | The implementation of the 'RunTH' message
229 runTH
230 :: Pipe
231 -> RemoteRef (IORef QState)
232 -- ^ The TH state, created by 'startTH'
233 -> HValueRef
234 -- ^ The splice to run
235 -> THResultType
236 -- ^ What kind of splice it is
237 -> Maybe TH.Loc
238 -- ^ The source location
239 -> IO ByteString
240 -- ^ Returns an (encoded) result that depends on the THResultType
241
242 runTH pipe rstate rhv ty mb_loc = do
243 hv <- localRef rhv
244 case ty of
245 THExp -> runTHQ pipe rstate mb_loc (unsafeCoerce hv :: TH.Q TH.Exp)
246 THPat -> runTHQ pipe rstate mb_loc (unsafeCoerce hv :: TH.Q TH.Pat)
247 THType -> runTHQ pipe rstate mb_loc (unsafeCoerce hv :: TH.Q TH.Type)
248 THDec -> runTHQ pipe rstate mb_loc (unsafeCoerce hv :: TH.Q [TH.Dec])
249 THAnnWrapper -> do
250 hv <- unsafeCoerce <$> localRef rhv
251 case hv :: AnnotationWrapper of
252 AnnotationWrapper thing -> return $!
253 LB.toStrict (runPut (put (toSerialized serializeWithData thing)))
254
255 -- | Run a Q computation.
256 runTHQ
257 :: Binary a => Pipe -> RemoteRef (IORef QState) -> Maybe TH.Loc -> TH.Q a
258 -> IO ByteString
259 runTHQ pipe@Pipe{..} rstate mb_loc ghciq = do
260 qstateref <- localRef rstate
261 qstate <- readIORef qstateref
262 let st = qstate { qsLocation = mb_loc, qsPipe = pipe }
263 (r,new_state) <- runGHCiQ (TH.runQ ghciq) st
264 writeIORef qstateref new_state
265 return $! LB.toStrict (runPut (put r))