{-# LANGUAGE ScopedTypeVariables, StandaloneDeriving, DeriveGeneric,
TupleSections, RecordWildCards, InstanceSigs, CPP #-}
{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
module GHCi.TH
( startTH
, runModFinalizerRefs
, runTH
, GHCiQException(..)
) where
import Prelude
import GHCi.Message
import GHCi.RemoteTypes
import GHC.Serialized
import Control.Exception
import Control.Monad.IO.Class (MonadIO (..))
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.Either
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 :: Pipe -> QState
initQState Pipe
p = Map TypeRep Dynamic -> Maybe Loc -> Pipe -> QState
QState forall k a. Map k a
M.empty forall a. Maybe a
Nothing Pipe
p
newtype GHCiQ a = GHCiQ { forall a. GHCiQ a -> QState -> IO (a, QState)
runGHCiQ :: QState -> IO (a, QState) }
data GHCiQException = GHCiQException QState String
deriving Int -> GHCiQException -> ShowS
[GHCiQException] -> ShowS
GHCiQException -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [GHCiQException] -> ShowS
$cshowList :: [GHCiQException] -> ShowS
show :: GHCiQException -> String
$cshow :: GHCiQException -> String
showsPrec :: Int -> GHCiQException -> ShowS
$cshowsPrec :: Int -> GHCiQException -> ShowS
Show
instance Exception GHCiQException
instance Functor GHCiQ where
fmap :: forall a b. (a -> b) -> GHCiQ a -> GHCiQ b
fmap a -> b
f (GHCiQ QState -> IO (a, QState)
s) = forall a. (QState -> IO (a, QState)) -> GHCiQ a
GHCiQ forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(a
x,QState
s') -> (a -> b
f a
x,QState
s')) forall b c a. (b -> c) -> (a -> b) -> a -> c
. QState -> IO (a, QState)
s
instance Applicative GHCiQ where
GHCiQ (a -> b)
f <*> :: forall a b. GHCiQ (a -> b) -> GHCiQ a -> GHCiQ b
<*> GHCiQ a
a = forall a. (QState -> IO (a, QState)) -> GHCiQ a
GHCiQ forall a b. (a -> b) -> a -> b
$ \QState
s ->
do (a -> b
f',QState
s') <- forall a. GHCiQ a -> QState -> IO (a, QState)
runGHCiQ GHCiQ (a -> b)
f QState
s
(a
a',QState
s'') <- forall a. GHCiQ a -> QState -> IO (a, QState)
runGHCiQ GHCiQ a
a QState
s'
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> b
f' a
a', QState
s'')
pure :: forall a. a -> GHCiQ a
pure a
x = forall a. (QState -> IO (a, QState)) -> GHCiQ a
GHCiQ (\QState
s -> forall (m :: * -> *) a. Monad m => a -> m a
return (a
x,QState
s))
instance Monad GHCiQ where
GHCiQ a
m >>= :: forall a b. GHCiQ a -> (a -> GHCiQ b) -> GHCiQ b
>>= a -> GHCiQ b
f = forall a. (QState -> IO (a, QState)) -> GHCiQ a
GHCiQ forall a b. (a -> b) -> a -> b
$ \QState
s ->
do (a
m', QState
s') <- forall a. GHCiQ a -> QState -> IO (a, QState)
runGHCiQ GHCiQ a
m QState
s
(b
a, QState
s'') <- forall a. GHCiQ a -> QState -> IO (a, QState)
runGHCiQ (a -> GHCiQ b
f a
m') QState
s'
forall (m :: * -> *) a. Monad m => a -> m a
return (b
a, QState
s'')
instance MonadFail GHCiQ where
fail :: forall a. String -> GHCiQ a
fail String
err = forall a. (QState -> IO (a, QState)) -> GHCiQ a
GHCiQ forall a b. (a -> b) -> a -> b
$ \QState
s -> forall e a. Exception e => e -> IO a
throwIO (QState -> String -> GHCiQException
GHCiQException QState
s String
err)
getState :: GHCiQ QState
getState :: GHCiQ QState
getState = forall a. (QState -> IO (a, QState)) -> GHCiQ a
GHCiQ forall a b. (a -> b) -> a -> b
$ \QState
s -> forall (m :: * -> *) a. Monad m => a -> m a
return (QState
s,QState
s)
noLoc :: TH.Loc
noLoc :: Loc
noLoc = String -> String -> String -> CharPos -> CharPos -> Loc
TH.Loc String
"<no file>" String
"<no package>" String
"<no module>" (Int
0,Int
0) (Int
0,Int
0)
ghcCmd :: Binary a => THMessage (THResult a) -> GHCiQ a
ghcCmd :: forall a. Binary a => THMessage (THResult a) -> GHCiQ a
ghcCmd THMessage (THResult a)
m = forall a. (QState -> IO (a, QState)) -> GHCiQ a
GHCiQ forall a b. (a -> b) -> a -> b
$ \QState
s -> do
THResult a
r <- forall a. Binary a => Pipe -> THMessage a -> IO a
remoteTHCall (QState -> Pipe
qsPipe QState
s) THMessage (THResult a)
m
case THResult a
r of
THException String
str -> forall e a. Exception e => e -> IO a
throwIO (QState -> String -> GHCiQException
GHCiQException QState
s String
str)
THComplete a
res -> forall (m :: * -> *) a. Monad m => a -> m a
return (a
res, QState
s)
instance MonadIO GHCiQ where
liftIO :: forall a. IO a -> GHCiQ a
liftIO IO a
m = forall a. (QState -> IO (a, QState)) -> GHCiQ a
GHCiQ forall a b. (a -> b) -> a -> b
$ \QState
s -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (,QState
s) IO a
m
instance TH.Quasi GHCiQ where
qNewName :: String -> GHCiQ Name
qNewName String
str = forall a. Binary a => THMessage (THResult a) -> GHCiQ a
ghcCmd (String -> THMessage (THResult Name)
NewName String
str)
qReport :: Bool -> String -> GHCiQ ()
qReport Bool
isError String
msg = forall a. Binary a => THMessage (THResult a) -> GHCiQ a
ghcCmd (Bool -> String -> THMessage (THResult ())
Report Bool
isError String
msg)
qRecover :: forall a. GHCiQ a -> GHCiQ a -> GHCiQ a
qRecover (GHCiQ QState -> IO (a, QState)
h) GHCiQ a
a = forall a. (QState -> IO (a, QState)) -> GHCiQ a
GHCiQ forall a b. (a -> b) -> a -> b
$ \QState
s -> forall b. ((forall a. IO a -> IO a) -> IO b) -> IO b
mask forall a b. (a -> b) -> a -> b
$ \forall a. IO a -> IO a
unmask -> do
forall a. Binary a => Pipe -> THMessage a -> IO a
remoteTHCall (QState -> Pipe
qsPipe QState
s) THMessage ()
StartRecover
Either GHCiQException (a, QState)
e <- forall e a. Exception e => IO a -> IO (Either e a)
try forall a b. (a -> b) -> a -> b
$ forall a. IO a -> IO a
unmask forall a b. (a -> b) -> a -> b
$ forall a. GHCiQ a -> QState -> IO (a, QState)
runGHCiQ (GHCiQ a
a forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall a. Binary a => THMessage (THResult a) -> GHCiQ a
ghcCmd THMessage (THResult ())
FailIfErrs) QState
s
forall a. Binary a => Pipe -> THMessage a -> IO a
remoteTHCall (QState -> Pipe
qsPipe QState
s) (Bool -> THMessage ()
EndRecover (forall a b. Either a b -> Bool
isLeft Either GHCiQException (a, QState)
e))
case Either GHCiQException (a, QState)
e of
Left GHCiQException{} -> QState -> IO (a, QState)
h QState
s
Right (a, QState)
r -> forall (m :: * -> *) a. Monad m => a -> m a
return (a, QState)
r
qLookupName :: Bool -> String -> GHCiQ (Maybe Name)
qLookupName Bool
isType String
occ = forall a. Binary a => THMessage (THResult a) -> GHCiQ a
ghcCmd (Bool -> String -> THMessage (THResult (Maybe Name))
LookupName Bool
isType String
occ)
qReify :: Name -> GHCiQ Info
qReify Name
name = forall a. Binary a => THMessage (THResult a) -> GHCiQ a
ghcCmd (Name -> THMessage (THResult Info)
Reify Name
name)
qReifyFixity :: Name -> GHCiQ (Maybe Fixity)
qReifyFixity Name
name = forall a. Binary a => THMessage (THResult a) -> GHCiQ a
ghcCmd (Name -> THMessage (THResult (Maybe Fixity))
ReifyFixity Name
name)
qReifyType :: Name -> GHCiQ Type
qReifyType Name
name = forall a. Binary a => THMessage (THResult a) -> GHCiQ a
ghcCmd (Name -> THMessage (THResult Type)
ReifyType Name
name)
qReifyInstances :: Name -> [Type] -> GHCiQ [Dec]
qReifyInstances Name
name [Type]
tys = forall a. Binary a => THMessage (THResult a) -> GHCiQ a
ghcCmd (Name -> [Type] -> THMessage (THResult [Dec])
ReifyInstances Name
name [Type]
tys)
qReifyRoles :: Name -> GHCiQ [Role]
qReifyRoles Name
name = forall a. Binary a => THMessage (THResult a) -> GHCiQ a
ghcCmd (Name -> THMessage (THResult [Role])
ReifyRoles Name
name)
qReifyAnnotations :: forall a . Data a => TH.AnnLookup -> GHCiQ [a]
qReifyAnnotations :: forall a. Data a => AnnLookup -> GHCiQ [a]
qReifyAnnotations AnnLookup
lookup =
forall a b. (a -> b) -> [a] -> [b]
map (forall a. Data a => [Word8] -> a
deserializeWithData forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [Word8]
B.unpack) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
forall a. Binary a => THMessage (THResult a) -> GHCiQ a
ghcCmd (AnnLookup -> TypeRep -> THMessage (THResult [ByteString])
ReifyAnnotations AnnLookup
lookup TypeRep
typerep)
where typerep :: TypeRep
typerep = forall a. Typeable a => a -> TypeRep
typeOf (forall a. HasCallStack => a
undefined :: a)
qReifyModule :: Module -> GHCiQ ModuleInfo
qReifyModule Module
m = forall a. Binary a => THMessage (THResult a) -> GHCiQ a
ghcCmd (Module -> THMessage (THResult ModuleInfo)
ReifyModule Module
m)
qReifyConStrictness :: Name -> GHCiQ [DecidedStrictness]
qReifyConStrictness Name
name = forall a. Binary a => THMessage (THResult a) -> GHCiQ a
ghcCmd (Name -> THMessage (THResult [DecidedStrictness])
ReifyConStrictness Name
name)
qLocation :: GHCiQ Loc
qLocation = forall a. a -> Maybe a -> a
fromMaybe Loc
noLoc forall b c a. (b -> c) -> (a -> b) -> a -> c
. QState -> Maybe Loc
qsLocation forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GHCiQ QState
getState
qAddDependentFile :: String -> GHCiQ ()
qAddDependentFile String
file = forall a. Binary a => THMessage (THResult a) -> GHCiQ a
ghcCmd (String -> THMessage (THResult ())
AddDependentFile String
file)
qAddTempFile :: String -> GHCiQ String
qAddTempFile String
suffix = forall a. Binary a => THMessage (THResult a) -> GHCiQ a
ghcCmd (String -> THMessage (THResult String)
AddTempFile String
suffix)
qAddTopDecls :: [Dec] -> GHCiQ ()
qAddTopDecls [Dec]
decls = forall a. Binary a => THMessage (THResult a) -> GHCiQ a
ghcCmd ([Dec] -> THMessage (THResult ())
AddTopDecls [Dec]
decls)
qAddForeignFilePath :: ForeignSrcLang -> String -> GHCiQ ()
qAddForeignFilePath ForeignSrcLang
lang String
fp = forall a. Binary a => THMessage (THResult a) -> GHCiQ a
ghcCmd (ForeignSrcLang -> String -> THMessage (THResult ())
AddForeignFilePath ForeignSrcLang
lang String
fp)
qAddModFinalizer :: Q () -> GHCiQ ()
qAddModFinalizer Q ()
fin = forall a. (QState -> IO (a, QState)) -> GHCiQ a
GHCiQ (\QState
s -> forall a. a -> IO (RemoteRef a)
mkRemoteRef Q ()
fin forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. (, QState
s)) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
forall a. Binary a => THMessage (THResult a) -> GHCiQ a
ghcCmd forall b c a. (b -> c) -> (a -> b) -> a -> c
. RemoteRef (Q ()) -> THMessage (THResult ())
AddModFinalizer
qAddCorePlugin :: String -> GHCiQ ()
qAddCorePlugin String
str = forall a. Binary a => THMessage (THResult a) -> GHCiQ a
ghcCmd (String -> THMessage (THResult ())
AddCorePlugin String
str)
qGetQ :: forall a. Typeable a => GHCiQ (Maybe a)
qGetQ = forall a. (QState -> IO (a, QState)) -> GHCiQ a
GHCiQ forall a b. (a -> b) -> a -> b
$ \QState
s ->
let lookup :: forall a. Typeable a => Map TypeRep Dynamic -> Maybe a
lookup :: forall a. Typeable a => Map TypeRep Dynamic -> Maybe a
lookup Map TypeRep Dynamic
m = forall a. Typeable a => Dynamic -> Maybe a
fromDynamic forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (forall a. Typeable a => a -> TypeRep
typeOf (forall a. HasCallStack => a
undefined::a)) Map TypeRep Dynamic
m
in forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. Typeable a => Map TypeRep Dynamic -> Maybe a
lookup (QState -> Map TypeRep Dynamic
qsMap QState
s), QState
s)
qPutQ :: forall a. Typeable a => a -> GHCiQ ()
qPutQ a
k = forall a. (QState -> IO (a, QState)) -> GHCiQ a
GHCiQ forall a b. (a -> b) -> a -> b
$ \QState
s ->
forall (m :: * -> *) a. Monad m => a -> m a
return ((), QState
s { qsMap :: Map TypeRep Dynamic
qsMap = forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert (forall a. Typeable a => a -> TypeRep
typeOf a
k) (forall a. Typeable a => a -> Dynamic
toDyn a
k) (QState -> Map TypeRep Dynamic
qsMap QState
s) })
qIsExtEnabled :: Extension -> GHCiQ Bool
qIsExtEnabled Extension
x = forall a. Binary a => THMessage (THResult a) -> GHCiQ a
ghcCmd (Extension -> THMessage (THResult Bool)
IsExtEnabled Extension
x)
qExtsEnabled :: GHCiQ [Extension]
qExtsEnabled = forall a. Binary a => THMessage (THResult a) -> GHCiQ a
ghcCmd THMessage (THResult [Extension])
ExtsEnabled
qPutDoc :: DocLoc -> String -> GHCiQ ()
qPutDoc DocLoc
l String
s = forall a. Binary a => THMessage (THResult a) -> GHCiQ a
ghcCmd (DocLoc -> String -> THMessage (THResult ())
PutDoc DocLoc
l String
s)
qGetDoc :: DocLoc -> GHCiQ (Maybe String)
qGetDoc DocLoc
l = forall a. Binary a => THMessage (THResult a) -> GHCiQ a
ghcCmd (DocLoc -> THMessage (THResult (Maybe String))
GetDoc DocLoc
l)
startTH :: IO (RemoteRef (IORef QState))
startTH :: IO (RemoteRef (IORef QState))
startTH = do
IORef QState
r <- forall a. a -> IO (IORef a)
newIORef (Pipe -> QState
initQState (forall a. HasCallStack => String -> a
error String
"startTH: no pipe"))
forall a. a -> IO (RemoteRef a)
mkRemoteRef IORef QState
r
runModFinalizerRefs :: Pipe -> RemoteRef (IORef QState)
-> [RemoteRef (TH.Q ())]
-> IO ()
runModFinalizerRefs :: Pipe -> RemoteRef (IORef QState) -> [RemoteRef (Q ())] -> IO ()
runModFinalizerRefs Pipe
pipe RemoteRef (IORef QState)
rstate [RemoteRef (Q ())]
qrefs = do
[Q ()]
qs <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall a. RemoteRef a -> IO a
localRef [RemoteRef (Q ())]
qrefs
IORef QState
qstateref <- forall a. RemoteRef a -> IO a
localRef RemoteRef (IORef QState)
rstate
QState
qstate <- forall a. IORef a -> IO a
readIORef IORef QState
qstateref
((), QState)
_ <- forall a. GHCiQ a -> QState -> IO (a, QState)
runGHCiQ (forall (m :: * -> *) a. Quasi m => Q a -> m a
TH.runQ forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ [Q ()]
qs) QState
qstate { qsPipe :: Pipe
qsPipe = Pipe
pipe }
forall (m :: * -> *) a. Monad m => a -> m a
return ()
runTH
:: Pipe
-> RemoteRef (IORef QState)
-> HValueRef
-> THResultType
-> Maybe TH.Loc
-> IO ByteString
runTH :: Pipe
-> RemoteRef (IORef QState)
-> HValueRef
-> THResultType
-> Maybe Loc
-> IO ByteString
runTH Pipe
pipe RemoteRef (IORef QState)
rstate HValueRef
rhv THResultType
ty Maybe Loc
mb_loc = do
HValue
hv <- forall a. RemoteRef a -> IO a
localRef HValueRef
rhv
case THResultType
ty of
THResultType
THExp -> forall a.
Binary a =>
Pipe
-> RemoteRef (IORef QState) -> Maybe Loc -> Q a -> IO ByteString
runTHQ Pipe
pipe RemoteRef (IORef QState)
rstate Maybe Loc
mb_loc (forall a b. a -> b
unsafeCoerce HValue
hv :: TH.Q TH.Exp)
THResultType
THPat -> forall a.
Binary a =>
Pipe
-> RemoteRef (IORef QState) -> Maybe Loc -> Q a -> IO ByteString
runTHQ Pipe
pipe RemoteRef (IORef QState)
rstate Maybe Loc
mb_loc (forall a b. a -> b
unsafeCoerce HValue
hv :: TH.Q TH.Pat)
THResultType
THType -> forall a.
Binary a =>
Pipe
-> RemoteRef (IORef QState) -> Maybe Loc -> Q a -> IO ByteString
runTHQ Pipe
pipe RemoteRef (IORef QState)
rstate Maybe Loc
mb_loc (forall a b. a -> b
unsafeCoerce HValue
hv :: TH.Q TH.Type)
THResultType
THDec -> forall a.
Binary a =>
Pipe
-> RemoteRef (IORef QState) -> Maybe Loc -> Q a -> IO ByteString
runTHQ Pipe
pipe RemoteRef (IORef QState)
rstate Maybe Loc
mb_loc (forall a b. a -> b
unsafeCoerce HValue
hv :: TH.Q [TH.Dec])
THResultType
THAnnWrapper -> do
AnnotationWrapper
hv <- forall a b. a -> b
unsafeCoerce forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. RemoteRef a -> IO a
localRef HValueRef
rhv
case AnnotationWrapper
hv :: AnnotationWrapper of
AnnotationWrapper a
thing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$!
ByteString -> ByteString
LB.toStrict (Put -> ByteString
runPut (forall t. Binary t => t -> Put
put (forall a. Typeable a => (a -> [Word8]) -> a -> Serialized
toSerialized forall a. Data a => a -> [Word8]
serializeWithData a
thing)))
runTHQ
:: Binary a => Pipe -> RemoteRef (IORef QState) -> Maybe TH.Loc -> TH.Q a
-> IO ByteString
runTHQ :: forall a.
Binary a =>
Pipe
-> RemoteRef (IORef QState) -> Maybe Loc -> Q a -> IO ByteString
runTHQ Pipe
pipe RemoteRef (IORef QState)
rstate Maybe Loc
mb_loc Q a
ghciq = do
IORef QState
qstateref <- forall a. RemoteRef a -> IO a
localRef RemoteRef (IORef QState)
rstate
QState
qstate <- forall a. IORef a -> IO a
readIORef IORef QState
qstateref
let st :: QState
st = QState
qstate { qsLocation :: Maybe Loc
qsLocation = Maybe Loc
mb_loc, qsPipe :: Pipe
qsPipe = Pipe
pipe }
(a
r,QState
new_state) <- forall a. GHCiQ a -> QState -> IO (a, QState)
runGHCiQ (forall (m :: * -> *) a. Quasi m => Q a -> m a
TH.runQ Q a
ghciq) QState
st
forall a. IORef a -> a -> IO ()
writeIORef IORef QState
qstateref QState
new_state
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! ByteString -> ByteString
LB.toStrict (Put -> ByteString
runPut (forall t. Binary t => t -> Put
put a
r))