Fix for recover with -fexternal-interpreter (#15418)
[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.Either
109 import Data.IORef
110 import Data.Map (Map)
111 import qualified Data.Map as M
112 import Data.Maybe
113 import GHC.Desugar
114 import qualified Language.Haskell.TH as TH
115 import qualified Language.Haskell.TH.Syntax as TH
116 import Unsafe.Coerce
117
118 -- | Create a new instance of 'QState'
119 initQState :: Pipe -> QState
120 initQState p = QState M.empty Nothing p
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 noLoc :: TH.Loc
155 noLoc = TH.Loc "<no file>" "<no package>" "<no module>" (0,0) (0,0)
156
157 -- | Send a 'THMessage' to GHC and return the result.
158 ghcCmd :: Binary a => THMessage (THResult a) -> GHCiQ a
159 ghcCmd m = GHCiQ $ \s -> do
160 r <- remoteTHCall (qsPipe s) m
161 case r of
162 THException str -> throwIO (GHCiQException s str)
163 THComplete res -> return (res, s)
164
165 instance MonadIO GHCiQ where
166 liftIO m = GHCiQ $ \s -> fmap (,s) m
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) a = GHCiQ $ \s -> mask $ \unmask -> do
174 remoteTHCall (qsPipe s) StartRecover
175 e <- try $ unmask $ runGHCiQ (a <* ghcCmd FailIfErrs) s
176 remoteTHCall (qsPipe s) (EndRecover (isLeft e))
177 case e of
178 Left GHCiQException{} -> h s
179 Right r -> return r
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 qAddDependentFile file = ghcCmd (AddDependentFile file)
199 qAddTempFile suffix = ghcCmd (AddTempFile suffix)
200 qAddTopDecls decls = ghcCmd (AddTopDecls decls)
201 qAddForeignFilePath lang fp = ghcCmd (AddForeignFilePath lang fp)
202 qAddModFinalizer fin = GHCiQ (\s -> mkRemoteRef fin >>= return . (, s)) >>=
203 ghcCmd . AddModFinalizer
204 qAddCorePlugin str = ghcCmd (AddCorePlugin str)
205 qGetQ = GHCiQ $ \s ->
206 let lookup :: forall a. Typeable a => Map TypeRep Dynamic -> Maybe a
207 lookup m = fromDynamic =<< M.lookup (typeOf (undefined::a)) m
208 in return (lookup (qsMap s), s)
209 qPutQ k = GHCiQ $ \s ->
210 return ((), s { qsMap = M.insert (typeOf k) (toDyn k) (qsMap s) })
211 qIsExtEnabled x = ghcCmd (IsExtEnabled x)
212 qExtsEnabled = ghcCmd ExtsEnabled
213
214 -- | The implementation of the 'StartTH' message: create
215 -- a new IORef QState, and return a RemoteRef to it.
216 startTH :: IO (RemoteRef (IORef QState))
217 startTH = do
218 r <- newIORef (initQState (error "startTH: no pipe"))
219 mkRemoteRef r
220
221 -- | Runs the mod finalizers.
222 --
223 -- The references must be created on the caller process.
224 runModFinalizerRefs :: Pipe -> RemoteRef (IORef QState)
225 -> [RemoteRef (TH.Q ())]
226 -> IO ()
227 runModFinalizerRefs pipe rstate qrefs = do
228 qs <- mapM localRef qrefs
229 qstateref <- localRef rstate
230 qstate <- readIORef qstateref
231 _ <- runGHCiQ (TH.runQ $ sequence_ qs) qstate { qsPipe = pipe }
232 return ()
233
234 -- | The implementation of the 'RunTH' message
235 runTH
236 :: Pipe
237 -> RemoteRef (IORef QState)
238 -- ^ The TH state, created by 'startTH'
239 -> HValueRef
240 -- ^ The splice to run
241 -> THResultType
242 -- ^ What kind of splice it is
243 -> Maybe TH.Loc
244 -- ^ The source location
245 -> IO ByteString
246 -- ^ Returns an (encoded) result that depends on the THResultType
247
248 runTH pipe rstate rhv ty mb_loc = do
249 hv <- localRef rhv
250 case ty of
251 THExp -> runTHQ pipe rstate mb_loc (unsafeCoerce hv :: TH.Q TH.Exp)
252 THPat -> runTHQ pipe rstate mb_loc (unsafeCoerce hv :: TH.Q TH.Pat)
253 THType -> runTHQ pipe rstate mb_loc (unsafeCoerce hv :: TH.Q TH.Type)
254 THDec -> runTHQ pipe rstate mb_loc (unsafeCoerce hv :: TH.Q [TH.Dec])
255 THAnnWrapper -> do
256 hv <- unsafeCoerce <$> localRef rhv
257 case hv :: AnnotationWrapper of
258 AnnotationWrapper thing -> return $!
259 LB.toStrict (runPut (put (toSerialized serializeWithData thing)))
260
261 -- | Run a Q computation.
262 runTHQ
263 :: Binary a => Pipe -> RemoteRef (IORef QState) -> Maybe TH.Loc -> TH.Q a
264 -> IO ByteString
265 runTHQ pipe@Pipe{..} rstate mb_loc ghciq = do
266 qstateref <- localRef rstate
267 qstate <- readIORef qstateref
268 let st = qstate { qsLocation = mb_loc, qsPipe = pipe }
269 (r,new_state) <- runGHCiQ (TH.runQ ghciq) st
270 writeIORef qstateref new_state
271 return $! LB.toStrict (runPut (put r))