Strip parentheses in expressions contexts in error messages
[ghc.git] / libraries / ghci / GHCi / TH.hs
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 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 Prelude -- See note [Why do we import Prelude here?]
95 import GHCi.Message
96 import GHCi.RemoteTypes
97 import GHC.Serialized
98
99 import Control.Exception
100 import qualified Control.Monad.Fail as Fail
101 import Control.Monad.IO.Class (MonadIO (..))
102 import Data.Binary
103 import Data.Binary.Put
104 import Data.ByteString (ByteString)
105 import qualified Data.ByteString as B
106 import qualified Data.ByteString.Lazy as LB
107 import Data.Data
108 import Data.Dynamic
109 import Data.Either
110 import Data.IORef
111 import Data.Map (Map)
112 import qualified Data.Map as M
113 import Data.Maybe
114 import GHC.Desugar
115 import qualified Language.Haskell.TH as TH
116 import qualified Language.Haskell.TH.Syntax as TH
117 import Unsafe.Coerce
118
119 -- | Create a new instance of 'QState'
120 initQState :: Pipe -> QState
121 initQState p = QState M.empty Nothing p
122
123 -- | The monad in which we run TH computations on the server
124 newtype GHCiQ a = GHCiQ { runGHCiQ :: QState -> IO (a, QState) }
125
126 -- | The exception thrown by "fail" in the GHCiQ monad
127 data GHCiQException = GHCiQException QState String
128 deriving Show
129
130 instance Exception GHCiQException
131
132 instance Functor GHCiQ where
133 fmap f (GHCiQ s) = GHCiQ $ fmap (\(x,s') -> (f x,s')) . s
134
135 instance Applicative GHCiQ where
136 f <*> a = GHCiQ $ \s ->
137 do (f',s') <- runGHCiQ f s
138 (a',s'') <- runGHCiQ a s'
139 return (f' a', s'')
140 pure x = GHCiQ (\s -> return (x,s))
141
142 instance Monad GHCiQ where
143 m >>= f = GHCiQ $ \s ->
144 do (m', s') <- runGHCiQ m s
145 (a, s'') <- runGHCiQ (f m') s'
146 return (a, s'')
147 #if !MIN_VERSION_base(4,13,0)
148 fail = Fail.fail
149 #endif
150
151 instance Fail.MonadFail GHCiQ where
152 fail err = GHCiQ $ \s -> throwIO (GHCiQException s err)
153
154 getState :: GHCiQ QState
155 getState = GHCiQ $ \s -> return (s,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 MonadIO GHCiQ where
169 liftIO m = GHCiQ $ \s -> fmap (,s) m
170
171 instance TH.Quasi GHCiQ where
172 qNewName str = ghcCmd (NewName str)
173 qReport isError msg = ghcCmd (Report isError msg)
174
175 -- See Note [TH recover with -fexternal-interpreter] in TcSplice
176 qRecover (GHCiQ h) a = GHCiQ $ \s -> mask $ \unmask -> do
177 remoteTHCall (qsPipe s) StartRecover
178 e <- try $ unmask $ runGHCiQ (a <* ghcCmd FailIfErrs) s
179 remoteTHCall (qsPipe s) (EndRecover (isLeft e))
180 case e of
181 Left GHCiQException{} -> h s
182 Right r -> return r
183 qLookupName isType occ = ghcCmd (LookupName isType occ)
184 qReify name = ghcCmd (Reify name)
185 qReifyFixity name = ghcCmd (ReifyFixity name)
186 qReifyType name = ghcCmd (ReifyType name)
187 qReifyInstances name tys = ghcCmd (ReifyInstances name tys)
188 qReifyRoles name = ghcCmd (ReifyRoles name)
189
190 -- To reify annotations, we send GHC the AnnLookup and also the
191 -- TypeRep of the thing we're looking for, to avoid needing to
192 -- serialize irrelevant annotations.
193 qReifyAnnotations :: forall a . Data a => TH.AnnLookup -> GHCiQ [a]
194 qReifyAnnotations lookup =
195 map (deserializeWithData . B.unpack) <$>
196 ghcCmd (ReifyAnnotations lookup typerep)
197 where typerep = typeOf (undefined :: a)
198
199 qReifyModule m = ghcCmd (ReifyModule m)
200 qReifyConStrictness name = ghcCmd (ReifyConStrictness name)
201 qLocation = fromMaybe noLoc . qsLocation <$> getState
202 qAddDependentFile file = ghcCmd (AddDependentFile file)
203 qAddTempFile suffix = ghcCmd (AddTempFile suffix)
204 qAddTopDecls decls = ghcCmd (AddTopDecls decls)
205 qAddForeignFilePath lang fp = ghcCmd (AddForeignFilePath lang fp)
206 qAddModFinalizer fin = GHCiQ (\s -> mkRemoteRef fin >>= return . (, s)) >>=
207 ghcCmd . AddModFinalizer
208 qAddCorePlugin str = ghcCmd (AddCorePlugin str)
209 qGetQ = GHCiQ $ \s ->
210 let lookup :: forall a. Typeable a => Map TypeRep Dynamic -> Maybe a
211 lookup m = fromDynamic =<< M.lookup (typeOf (undefined::a)) m
212 in return (lookup (qsMap s), s)
213 qPutQ k = GHCiQ $ \s ->
214 return ((), s { qsMap = M.insert (typeOf k) (toDyn k) (qsMap s) })
215 qIsExtEnabled x = ghcCmd (IsExtEnabled x)
216 qExtsEnabled = ghcCmd ExtsEnabled
217
218 -- | The implementation of the 'StartTH' message: create
219 -- a new IORef QState, and return a RemoteRef to it.
220 startTH :: IO (RemoteRef (IORef QState))
221 startTH = do
222 r <- newIORef (initQState (error "startTH: no pipe"))
223 mkRemoteRef r
224
225 -- | Runs the mod finalizers.
226 --
227 -- The references must be created on the caller process.
228 runModFinalizerRefs :: Pipe -> RemoteRef (IORef QState)
229 -> [RemoteRef (TH.Q ())]
230 -> IO ()
231 runModFinalizerRefs pipe rstate qrefs = do
232 qs <- mapM localRef qrefs
233 qstateref <- localRef rstate
234 qstate <- readIORef qstateref
235 _ <- runGHCiQ (TH.runQ $ sequence_ qs) qstate { qsPipe = pipe }
236 return ()
237
238 -- | The implementation of the 'RunTH' message
239 runTH
240 :: Pipe
241 -> RemoteRef (IORef QState)
242 -- ^ The TH state, created by 'startTH'
243 -> HValueRef
244 -- ^ The splice to run
245 -> THResultType
246 -- ^ What kind of splice it is
247 -> Maybe TH.Loc
248 -- ^ The source location
249 -> IO ByteString
250 -- ^ Returns an (encoded) result that depends on the THResultType
251
252 runTH pipe rstate rhv ty mb_loc = do
253 hv <- localRef rhv
254 case ty of
255 THExp -> runTHQ pipe rstate mb_loc (unsafeCoerce hv :: TH.Q TH.Exp)
256 THPat -> runTHQ pipe rstate mb_loc (unsafeCoerce hv :: TH.Q TH.Pat)
257 THType -> runTHQ pipe rstate mb_loc (unsafeCoerce hv :: TH.Q TH.Type)
258 THDec -> runTHQ pipe rstate mb_loc (unsafeCoerce hv :: TH.Q [TH.Dec])
259 THAnnWrapper -> do
260 hv <- unsafeCoerce <$> localRef rhv
261 case hv :: AnnotationWrapper of
262 AnnotationWrapper thing -> return $!
263 LB.toStrict (runPut (put (toSerialized serializeWithData thing)))
264
265 -- | Run a Q computation.
266 runTHQ
267 :: Binary a => Pipe -> RemoteRef (IORef QState) -> Maybe TH.Loc -> TH.Q a
268 -> IO ByteString
269 runTHQ pipe rstate mb_loc ghciq = do
270 qstateref <- localRef rstate
271 qstate <- readIORef qstateref
272 let st = qstate { qsLocation = mb_loc, qsPipe = pipe }
273 (r,new_state) <- runGHCiQ (TH.runQ ghciq) st
274 writeIORef qstateref new_state
275 return $! LB.toStrict (runPut (put r))