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