Remote GHCi, -fexternal-interpreter
[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 import GHCi.Message
11 import GHCi.RemoteTypes
12 import GHC.Serialized
13
14 import Control.Exception
15 import Data.Binary
16 import Data.Binary.Put
17 import Data.ByteString (ByteString)
18 import qualified Data.ByteString as B
19 import qualified Data.ByteString.Lazy as LB
20 import Data.Data
21 import Data.Dynamic
22 import Data.IORef
23 import Data.Map (Map)
24 import qualified Data.Map as M
25 import Data.Maybe
26 import GHC.Desugar
27 import qualified Language.Haskell.TH as TH
28 import qualified Language.Haskell.TH.Syntax as TH
29 import Unsafe.Coerce
30
31 data QState = QState
32 { qsMap :: Map TypeRep Dynamic
33 -- ^ persistent data between splices in a module
34 , qsFinalizers :: [TH.Q ()]
35 -- ^ registered finalizers (in reverse order)
36 , qsLocation :: Maybe TH.Loc
37 -- ^ location for current splice, if any
38 , qsPipe :: Pipe
39 -- ^ pipe to communicate with GHC
40 }
41 instance Show QState where show _ = "<QState>"
42
43 initQState :: Pipe -> QState
44 initQState p = QState M.empty [] Nothing p
45
46 runModFinalizers :: GHCiQ ()
47 runModFinalizers = go =<< getState
48 where
49 go s | (f:ff) <- qsFinalizers s = do
50 putState (s { qsFinalizers = ff}) >> TH.runQ f >> getState >>= go
51 go _ = return ()
52
53 newtype GHCiQ a = GHCiQ { runGHCiQ :: QState -> IO (a, QState) }
54
55 data GHCiQException = GHCiQException QState String
56 deriving (Show, Typeable)
57
58 instance Exception GHCiQException
59
60 instance Functor GHCiQ where
61 fmap f (GHCiQ s) = GHCiQ $ fmap (\(x,s') -> (f x,s')) . s
62
63 instance Applicative GHCiQ where
64 f <*> a = GHCiQ $ \s ->
65 do (f',s') <- runGHCiQ f s
66 (a',s'') <- runGHCiQ a s'
67 return (f' a', s'')
68 pure x = GHCiQ (\s -> return (x,s))
69
70 instance Monad GHCiQ where
71 m >>= f = GHCiQ $ \s ->
72 do (m', s') <- runGHCiQ m s
73 (a, s'') <- runGHCiQ (f m') s'
74 return (a, s'')
75 return = pure
76 fail err = GHCiQ $ \s -> throwIO (GHCiQException s err)
77
78 getState :: GHCiQ QState
79 getState = GHCiQ $ \s -> return (s,s)
80
81 putState :: QState -> GHCiQ ()
82 putState s = GHCiQ $ \_ -> return ((),s)
83
84 noLoc :: TH.Loc
85 noLoc = TH.Loc "<no file>" "<no package>" "<no module>" (0,0) (0,0)
86
87 ghcCmd :: Binary a => Message (THResult a) -> GHCiQ a
88 ghcCmd m = GHCiQ $ \s -> do
89 r <- remoteCall (qsPipe s) m
90 case r of
91 THException str -> throwIO (GHCiQException s str)
92 THComplete res -> return (res, s)
93
94 instance TH.Quasi GHCiQ where
95 qNewName str = ghcCmd (NewName str)
96 qReport isError msg = ghcCmd (Report isError msg)
97 qRecover = undefined
98 {-
99 qRecover (GHCiQ h) (GHCiQ a) = GHCiQ $ \s -> do
100 let r :: Bool -> IO ()
101 r b = do EndRecover' <- sendRequest (EndRecover b)
102 return ()
103 StartRecover' <- sendRequest StartRecover
104 (a s >>= \s' -> r False >> return s') `E.catch`
105 \(GHCiQException s' _ _) -> r True >> h s
106 -}
107 qLookupName isType occ = ghcCmd (LookupName isType occ)
108 qReify name = ghcCmd (Reify name)
109 qReifyFixity name = ghcCmd (ReifyFixity name)
110 qReifyInstances name tys = ghcCmd (ReifyInstances name tys)
111 qReifyRoles name = ghcCmd (ReifyRoles name)
112
113 -- To reify annotations, we send GHC the AnnLookup and also the TypeRep of the
114 -- thing we're looking for, to avoid needing to serialize irrelevant annotations.
115 qReifyAnnotations :: forall a . Data a => TH.AnnLookup -> GHCiQ [a]
116 qReifyAnnotations lookup =
117 map (deserializeWithData . B.unpack) <$> ghcCmd (ReifyAnnotations lookup typerep)
118 where typerep = typeOf (undefined :: a)
119
120 qReifyModule m = ghcCmd (ReifyModule m)
121 qLocation = fromMaybe noLoc . qsLocation <$> getState
122 qRunIO m = GHCiQ $ \s -> fmap (,s) m
123 qAddDependentFile file = ghcCmd (AddDependentFile file)
124 qAddTopDecls decls = ghcCmd (AddTopDecls decls)
125 qAddModFinalizer fin = GHCiQ $ \s ->
126 return ((), s { qsFinalizers = fin : qsFinalizers s })
127 qGetQ = GHCiQ $ \s ->
128 let lookup :: forall a. Typeable a => Map TypeRep Dynamic -> Maybe a
129 lookup m = fromDynamic =<< M.lookup (typeOf (undefined::a)) m
130 in return (lookup (qsMap s), s)
131 qPutQ k = GHCiQ $ \s ->
132 return ((), s { qsMap = M.insert (typeOf k) (toDyn k) (qsMap s) })
133 qIsExtEnabled x = ghcCmd (IsExtEnabled x)
134 qExtsEnabled = ghcCmd ExtsEnabled
135
136 startTH :: IO HValueRef
137 startTH = do
138 r <- newIORef (initQState (error "startTH: no pipe"))
139 mkHValueRef (unsafeCoerce r)
140
141 finishTH :: Pipe -> HValueRef -> IO ()
142 finishTH pipe rstate = do
143 qstateref <- unsafeCoerce <$> localHValueRef rstate
144 qstate <- readIORef qstateref
145 _ <- runGHCiQ runModFinalizers qstate { qsPipe = pipe }
146 freeHValueRef rstate
147 return ()
148
149 runTH
150 :: Pipe -> HValueRef -> HValueRef
151 -> THResultType
152 -> Maybe TH.Loc
153 -> IO ByteString
154 runTH pipe rstate rhv ty mb_loc = do
155 hv <- localHValueRef rhv
156 case ty of
157 THExp -> runTHQ pipe rstate mb_loc (unsafeCoerce hv :: TH.Q TH.Exp)
158 THPat -> runTHQ pipe rstate mb_loc (unsafeCoerce hv :: TH.Q TH.Pat)
159 THType -> runTHQ pipe rstate mb_loc (unsafeCoerce hv :: TH.Q TH.Type)
160 THDec -> runTHQ pipe rstate mb_loc (unsafeCoerce hv :: TH.Q [TH.Dec])
161 THAnnWrapper -> do
162 hv <- unsafeCoerce <$> localHValueRef rhv
163 case hv :: AnnotationWrapper of
164 AnnotationWrapper thing ->
165 return $! LB.toStrict (runPut (put (toSerialized serializeWithData thing)))
166
167 runTHQ :: Binary a => Pipe -> HValueRef -> Maybe TH.Loc -> TH.Q a
168 -> IO ByteString
169 runTHQ pipe@Pipe{..} rstate mb_loc ghciq = do
170 qstateref <- unsafeCoerce <$> localHValueRef rstate
171 qstate <- readIORef qstateref
172 let st = qstate { qsLocation = mb_loc, qsPipe = pipe }
173 (r,new_state) <- runGHCiQ (TH.runQ ghciq) st
174 writeIORef qstateref new_state
175 return $! LB.toStrict (runPut (put r))