TH.hs 5.37 KB
Newer Older
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
{-# LANGUAGE ScopedTypeVariables, StandaloneDeriving, DeriveGeneric,
    TupleSections, RecordWildCards, InstanceSigs #-}
{-# OPTIONS_GHC -fno-warn-name-shadowing #-}

-- |
-- Running TH splices
--
module GHCi.TH (startTH, finishTH, runTH, GHCiQException(..)) where

import GHCi.Message
import GHCi.RemoteTypes
import GHC.Serialized

import Control.Exception
import Data.Binary
import Data.Binary.Put
import Data.ByteString (ByteString)
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as LB
import Data.Data
import Data.Dynamic
import Data.IORef
import Data.Map (Map)
import qualified Data.Map as M
import Data.Maybe
import GHC.Desugar
import qualified Language.Haskell.TH        as TH
import qualified Language.Haskell.TH.Syntax as TH
import Unsafe.Coerce

initQState :: Pipe -> QState
initQState p = QState M.empty [] Nothing p

runModFinalizers :: GHCiQ ()
runModFinalizers = go =<< getState
  where
    go s | (f:ff) <- qsFinalizers s = do
      putState (s { qsFinalizers = ff}) >> TH.runQ f >> getState >>= go
    go _ = return ()

newtype GHCiQ a = GHCiQ { runGHCiQ :: QState -> IO (a, QState) }

data GHCiQException = GHCiQException QState String
  deriving (Show, Typeable)

instance Exception GHCiQException

instance Functor GHCiQ where
  fmap f (GHCiQ s) = GHCiQ $ fmap (\(x,s') -> (f x,s')) . s

instance Applicative GHCiQ where
  f <*> a = GHCiQ $ \s ->
    do (f',s')  <- runGHCiQ f s
       (a',s'') <- runGHCiQ a s'
       return (f' a', s'')
  pure x = GHCiQ (\s -> return (x,s))

instance Monad GHCiQ where
  m >>= f = GHCiQ $ \s ->
    do (m', s')  <- runGHCiQ m s
       (a,  s'') <- runGHCiQ (f m') s'
       return (a, s'')
  fail err  = GHCiQ $ \s -> throwIO (GHCiQException s err)

getState :: GHCiQ QState
getState = GHCiQ $ \s -> return (s,s)

putState :: QState -> GHCiQ ()
putState s = GHCiQ $ \_ -> return ((),s)

noLoc :: TH.Loc
noLoc = TH.Loc "<no file>" "<no package>" "<no module>" (0,0) (0,0)

ghcCmd :: Binary a => Message (THResult a) -> GHCiQ a
ghcCmd m = GHCiQ $ \s -> do
  r <- remoteCall (qsPipe s) m
  case r of
    THException str -> throwIO (GHCiQException s str)
    THComplete res -> return (res, s)

instance TH.Quasi GHCiQ where
  qNewName str = ghcCmd (NewName str)
  qReport isError msg = ghcCmd (Report isError msg)
84
85
86
87
88
89
90
91
92

  -- See Note [TH recover with -fexternal-interpreter] in TcSplice
  qRecover (GHCiQ h) (GHCiQ a) = GHCiQ $ \s -> (do
    remoteCall (qsPipe s) StartRecover
    (r, s') <- a s
    remoteCall (qsPipe s) (EndRecover False)
    return (r,s'))
      `catch`
       \GHCiQException{} -> remoteCall (qsPipe s) (EndRecover True) >> h s
93
94
95
96
97
98
  qLookupName isType occ = ghcCmd (LookupName isType occ)
  qReify name = ghcCmd (Reify name)
  qReifyFixity name = ghcCmd (ReifyFixity name)
  qReifyInstances name tys = ghcCmd (ReifyInstances name tys)
  qReifyRoles name = ghcCmd (ReifyRoles name)

99
100
101
  -- To reify annotations, we send GHC the AnnLookup and also the
  -- TypeRep of the thing we're looking for, to avoid needing to
  -- serialize irrelevant annotations.
102
103
  qReifyAnnotations :: forall a . Data a => TH.AnnLookup -> GHCiQ [a]
  qReifyAnnotations lookup =
104
105
    map (deserializeWithData . B.unpack) <$>
      ghcCmd (ReifyAnnotations lookup typerep)
106
107
108
    where typerep = typeOf (undefined :: a)

  qReifyModule m = ghcCmd (ReifyModule m)
109
  qReifyConStrictness name = ghcCmd (ReifyConStrictness name)
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
  qLocation = fromMaybe noLoc . qsLocation <$> getState
  qRunIO m = GHCiQ $ \s -> fmap (,s) m
  qAddDependentFile file = ghcCmd (AddDependentFile file)
  qAddTopDecls decls = ghcCmd (AddTopDecls decls)
  qAddModFinalizer fin = GHCiQ $ \s ->
    return ((), s { qsFinalizers = fin : qsFinalizers s })
  qGetQ = GHCiQ $ \s ->
    let lookup :: forall a. Typeable a => Map TypeRep Dynamic -> Maybe a
        lookup m = fromDynamic =<< M.lookup (typeOf (undefined::a)) m
    in return (lookup (qsMap s), s)
  qPutQ k = GHCiQ $ \s ->
    return ((), s { qsMap = M.insert (typeOf k) (toDyn k) (qsMap s) })
  qIsExtEnabled x = ghcCmd (IsExtEnabled x)
  qExtsEnabled = ghcCmd ExtsEnabled

125
startTH :: IO (RemoteRef (IORef QState))
126
127
startTH = do
  r <- newIORef (initQState (error "startTH: no pipe"))
128
  mkRemoteRef r
129

130
finishTH :: Pipe -> RemoteRef (IORef QState) -> IO ()
131
finishTH pipe rstate = do
132
  qstateref <- localRef rstate
133
134
135
136
137
  qstate <- readIORef qstateref
  _ <- runGHCiQ runModFinalizers qstate { qsPipe = pipe }
  return ()

runTH
138
  :: Pipe -> RemoteRef (IORef QState) -> HValueRef
139
140
141
142
  -> THResultType
  -> Maybe TH.Loc
  -> IO ByteString
runTH pipe rstate rhv ty mb_loc = do
143
  hv <- localRef rhv
144
145
146
147
148
149
  case ty of
    THExp -> runTHQ pipe rstate mb_loc (unsafeCoerce hv :: TH.Q TH.Exp)
    THPat -> runTHQ pipe rstate mb_loc (unsafeCoerce hv :: TH.Q TH.Pat)
    THType -> runTHQ pipe rstate mb_loc (unsafeCoerce hv :: TH.Q TH.Type)
    THDec -> runTHQ pipe rstate mb_loc (unsafeCoerce hv :: TH.Q [TH.Dec])
    THAnnWrapper -> do
150
      hv <- unsafeCoerce <$> localRef rhv
151
      case hv :: AnnotationWrapper of
152
153
        AnnotationWrapper thing -> return $!
          LB.toStrict (runPut (put (toSerialized serializeWithData thing)))
154

155
156
157
runTHQ
  :: Binary a => Pipe -> RemoteRef (IORef QState) -> Maybe TH.Loc -> TH.Q a
  -> IO ByteString
158
runTHQ pipe@Pipe{..} rstate mb_loc ghciq = do
159
  qstateref <- localRef rstate
160
161
162
163
164
  qstate <- readIORef qstateref
  let st = qstate { qsLocation = mb_loc, qsPipe = pipe }
  (r,new_state) <- runGHCiQ (TH.runQ ghciq) st
  writeIORef qstateref new_state
  return $! LB.toStrict (runPut (put r))