{-# LANGUAGE RankNTypes, RecordWildCards, GADTs, ScopedTypeVariables #-}
module Lib (serv) where
import GHCi.Run
import GHCi.TH
import GHCi.Message
import Control.DeepSeq
import Control.Exception
import Control.Monad
import Data.Binary
type MessageHook = Msg -> IO Msg
serv :: Bool -> MessageHook -> Pipe -> (forall a .IO a -> IO a) -> IO ()
serv :: Bool -> MessageHook -> Pipe -> (forall a. IO a -> IO a) -> IO ()
serv verbose :: Bool
verbose hook :: MessageHook
hook pipe :: Pipe
pipe@Pipe{..} restore :: forall a. IO a -> IO a
restore = IO ()
loop
where
loop :: IO ()
loop = do
Msg msg :: Message a
msg <- Pipe -> Get Msg -> IO Msg
forall a. Pipe -> Get a -> IO a
readPipe Pipe
pipe Get Msg
getMessage IO Msg -> MessageHook -> IO Msg
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= MessageHook
hook
IO ()
discardCtrlC
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
verbose (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn ("iserv: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Message a -> String
forall a. Show a => a -> String
show Message a
msg)
case Message a
msg of
Shutdown -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
RunTH st :: RemoteRef (IORef QState)
st q :: HValueRef
q ty :: THResultType
ty loc :: Maybe Loc
loc -> IO ByteString -> IO ()
forall a. (Binary a, Show a) => IO a -> IO ()
wrapRunTH (IO ByteString -> IO ()) -> IO ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ Pipe
-> RemoteRef (IORef QState)
-> HValueRef
-> THResultType
-> Maybe Loc
-> IO ByteString
runTH Pipe
pipe RemoteRef (IORef QState)
st HValueRef
q THResultType
ty Maybe Loc
loc
RunModFinalizers st :: RemoteRef (IORef QState)
st qrefs :: [RemoteRef (Q ())]
qrefs -> IO () -> IO ()
forall a. (Binary a, Show a) => IO a -> IO ()
wrapRunTH (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Pipe -> RemoteRef (IORef QState) -> [RemoteRef (Q ())] -> IO ()
runModFinalizerRefs Pipe
pipe RemoteRef (IORef QState)
st [RemoteRef (Q ())]
qrefs
_other :: Message a
_other -> Message a -> IO a
forall a. Message a -> IO a
run Message a
msg IO a -> (a -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= a -> IO ()
forall a. (Binary a, Show a) => a -> IO ()
reply
reply :: forall a. (Binary a, Show a) => a -> IO ()
reply :: a -> IO ()
reply r :: a
r = do
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
verbose (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn ("iserv: return: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
r)
Pipe -> Put -> IO ()
writePipe Pipe
pipe (a -> Put
forall t. Binary t => t -> Put
put a
r)
IO ()
loop
wrapRunTH :: forall a. (Binary a, Show a) => IO a -> IO ()
wrapRunTH :: IO a -> IO ()
wrapRunTH io :: IO a
io = do
Either SomeException a
r <- IO a -> IO (Either SomeException a)
forall e a. Exception e => IO a -> IO (Either e a)
try IO a
io
Pipe -> Put -> IO ()
writePipe Pipe
pipe (THMessage () -> Put
forall a. THMessage a -> Put
putTHMessage THMessage ()
RunTHDone)
case Either SomeException a
r of
Left e :: SomeException
e
| Just (GHCiQException _ err :: String
err) <- SomeException -> Maybe GHCiQException
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e ->
QResult a -> IO ()
forall a. (Binary a, Show a) => a -> IO ()
reply (String -> QResult a
forall a. String -> QResult a
QFail String
err :: QResult a)
| Bool
otherwise -> do
String
str <- SomeException -> IO String
showException SomeException
e
QResult a -> IO ()
forall a. (Binary a, Show a) => a -> IO ()
reply (String -> QResult a
forall a. String -> QResult a
QException String
str :: QResult a)
Right a :: a
a -> do
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
verbose (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn "iserv: QDone"
QResult a -> IO ()
forall a. (Binary a, Show a) => a -> IO ()
reply (a -> QResult a
forall a. a -> QResult a
QDone a
a)
showException :: SomeException -> IO String
showException :: SomeException -> IO String
showException e0 :: SomeException
e0 = do
Either SomeException String
r <- IO String -> IO (Either SomeException String)
forall e a. Exception e => IO a -> IO (Either e a)
try (IO String -> IO (Either SomeException String))
-> IO String -> IO (Either SomeException String)
forall a b. (a -> b) -> a -> b
$ String -> IO String
forall a. a -> IO a
evaluate (String -> String
forall a. NFData a => a -> a
force (SomeException -> String
forall a. Show a => a -> String
show (SomeException
e0::SomeException)))
case Either SomeException String
r of
Left e :: SomeException
e -> SomeException -> IO String
showException SomeException
e
Right str :: String
str -> String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return String
str
discardCtrlC :: IO ()
discardCtrlC = do
Either AsyncException ()
r <- IO () -> IO (Either AsyncException ())
forall e a. Exception e => IO a -> IO (Either e a)
try (IO () -> IO (Either AsyncException ()))
-> IO () -> IO (Either AsyncException ())
forall a b. (a -> b) -> a -> b
$ IO () -> IO ()
forall a. IO a -> IO a
restore (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
case Either AsyncException ()
r of
Left UserInterrupt -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return () IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
discardCtrlC
Left e :: AsyncException
e -> AsyncException -> IO ()
forall e a. Exception e => e -> IO a
throwIO AsyncException
e
_ -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()