module GHCi.TH
( startTH
, runModFinalizerRefs
, runTH
, GHCiQException(..)
) where
import Prelude
import GHCi.Message
import GHCi.RemoteTypes
import GHC.Serialized
import Control.Exception
import qualified Control.Monad.Fail as Fail
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 p = QState M.empty Nothing p
newtype GHCiQ a = GHCiQ { runGHCiQ :: QState -> IO (a, QState) }
data GHCiQException = GHCiQException QState String
deriving Show
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'')
#if !MIN_VERSION_base(4,13,0)
fail = Fail.fail
#endif
instance Fail.MonadFail GHCiQ where
fail err = GHCiQ $ \s -> throwIO (GHCiQException s err)
getState :: GHCiQ QState
getState = GHCiQ $ \s -> return (s,s)
noLoc :: TH.Loc
noLoc = TH.Loc "<no file>" "<no package>" "<no module>" (0,0) (0,0)
ghcCmd :: Binary a => THMessage (THResult a) -> GHCiQ a
ghcCmd m = GHCiQ $ \s -> do
r <- remoteTHCall (qsPipe s) m
case r of
THException str -> throwIO (GHCiQException s str)
THComplete res -> return (res, s)
instance MonadIO GHCiQ where
liftIO m = GHCiQ $ \s -> fmap (,s) m
instance TH.Quasi GHCiQ where
qNewName str = ghcCmd (NewName str)
qReport isError msg = ghcCmd (Report isError msg)
qRecover (GHCiQ h) a = GHCiQ $ \s -> mask $ \unmask -> do
remoteTHCall (qsPipe s) StartRecover
e <- try $ unmask $ runGHCiQ (a <* ghcCmd FailIfErrs) s
remoteTHCall (qsPipe s) (EndRecover (isLeft e))
case e of
Left GHCiQException{} -> h s
Right r -> return r
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)
qReifyAnnotations :: forall a . Data a => TH.AnnLookup -> GHCiQ [a]
qReifyAnnotations lookup =
map (deserializeWithData . B.unpack) <$>
ghcCmd (ReifyAnnotations lookup typerep)
where typerep = typeOf (undefined :: a)
qReifyModule m = ghcCmd (ReifyModule m)
qReifyConStrictness name = ghcCmd (ReifyConStrictness name)
qLocation = fromMaybe noLoc . qsLocation <$> getState
qAddDependentFile file = ghcCmd (AddDependentFile file)
qAddTempFile suffix = ghcCmd (AddTempFile suffix)
qAddTopDecls decls = ghcCmd (AddTopDecls decls)
qAddForeignFilePath lang fp = ghcCmd (AddForeignFilePath lang fp)
qAddModFinalizer fin = GHCiQ (\s -> mkRemoteRef fin >>= return . (, s)) >>=
ghcCmd . AddModFinalizer
qAddCorePlugin str = ghcCmd (AddCorePlugin str)
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
startTH :: IO (RemoteRef (IORef QState))
startTH = do
r <- newIORef (initQState (error "startTH: no pipe"))
mkRemoteRef r
runModFinalizerRefs :: Pipe -> RemoteRef (IORef QState)
-> [RemoteRef (TH.Q ())]
-> IO ()
runModFinalizerRefs pipe rstate qrefs = do
qs <- mapM localRef qrefs
qstateref <- localRef rstate
qstate <- readIORef qstateref
_ <- runGHCiQ (TH.runQ $ sequence_ qs) qstate { qsPipe = pipe }
return ()
runTH
:: Pipe
-> RemoteRef (IORef QState)
-> HValueRef
-> THResultType
-> Maybe TH.Loc
-> IO ByteString
runTH pipe rstate rhv ty mb_loc = do
hv <- localRef rhv
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
hv <- unsafeCoerce <$> localRef rhv
case hv :: AnnotationWrapper of
AnnotationWrapper thing -> return $!
LB.toStrict (runPut (put (toSerialized serializeWithData thing)))
runTHQ
:: Binary a => Pipe -> RemoteRef (IORef QState) -> Maybe TH.Loc -> TH.Q a
-> IO ByteString
runTHQ pipe@Pipe{..} rstate mb_loc ghciq = do
qstateref <- localRef rstate
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))