{-# 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

import Text.Printf
import System.Environment (getProgName)

type MessageHook = Msg -> IO Msg

trace :: String -> IO ()
trace :: String -> IO ()
trace String
s = IO String
getProgName forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \String
name -> forall r. PrintfType r => String -> r
printf String
"[%20s] %s\n" String
name String
s

serv :: Bool -> MessageHook -> Pipe -> (forall a .IO a -> IO a) -> IO ()
serv :: Bool -> MessageHook -> Pipe -> (forall a. IO a -> IO a) -> IO ()
serv Bool
verbose MessageHook
hook Pipe
pipe forall a. IO a -> IO a
restore = IO ()
loop
 where
  loop :: IO ()
loop = do
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
verbose forall a b. (a -> b) -> a -> b
$ String -> IO ()
trace String
"reading pipe..."
    Msg Message a
msg <- forall a. Pipe -> Get a -> IO a
readPipe Pipe
pipe Get Msg
getMessage forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= MessageHook
hook

    IO ()
discardCtrlC

    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
verbose forall a b. (a -> b) -> a -> b
$ String -> IO ()
trace (String
"msg: " forall a. [a] -> [a] -> [a]
++ (forall a. Show a => a -> String
show Message a
msg))
    case Message a
msg of
      Message a
Shutdown -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
      RunTH RemoteRef (IORef QState)
st HValueRef
q THResultType
ty Maybe Loc
loc -> forall a. (Binary a, Show a) => IO a -> IO ()
wrapRunTH 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 RemoteRef (IORef QState)
st [RemoteRef (Q ())]
qrefs -> forall a. (Binary a, Show a) => IO a -> IO ()
wrapRunTH forall a b. (a -> b) -> a -> b
$ Pipe -> RemoteRef (IORef QState) -> [RemoteRef (Q ())] -> IO ()
runModFinalizerRefs Pipe
pipe RemoteRef (IORef QState)
st [RemoteRef (Q ())]
qrefs
      Message a
_other -> forall a. Message a -> IO a
run Message a
msg forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a. (Binary a, Show a) => a -> IO ()
reply

  reply :: forall a. (Binary a, Show a) => a -> IO ()
  reply :: forall a. (Binary a, Show a) => a -> IO ()
reply a
r = do
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
verbose forall a b. (a -> b) -> a -> b
$ String -> IO ()
trace (String
"writing pipe: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show a
r)
    Pipe -> Put -> IO ()
writePipe Pipe
pipe (forall t. Binary t => t -> Put
put a
r)
    IO ()
loop

  -- Run some TH code, which may interact with GHC by sending
  -- THMessage requests, and then finally send RunTHDone followed by a
  -- QResult.  For an overview of how TH works with Remote GHCi, see
  -- Note [Remote Template Haskell] in libraries/ghci/GHCi/TH.hs.
  wrapRunTH :: forall a. (Binary a, Show a) => IO a -> IO ()
  wrapRunTH :: forall a. (Binary a, Show a) => IO a -> IO ()
wrapRunTH IO a
io = do
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
verbose forall a b. (a -> b) -> a -> b
$ String -> IO ()
trace String
"wrapRunTH..."
    Either SomeException a
r <- forall e a. Exception e => IO a -> IO (Either e a)
try IO a
io
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
verbose forall a b. (a -> b) -> a -> b
$ String -> IO ()
trace String
"wrapRunTH done."
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
verbose forall a b. (a -> b) -> a -> b
$ String -> IO ()
trace String
"writing RunTHDone."
    Pipe -> Put -> IO ()
writePipe Pipe
pipe (forall a. THMessage a -> Put
putTHMessage THMessage ()
RunTHDone)
    case Either SomeException a
r of
      Left SomeException
e
        | Just (GHCiQException QState
_ String
err) <- forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e  -> do
           forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
verbose forall a b. (a -> b) -> a -> b
$ String -> IO ()
trace (String
"QFail " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show String
err)
           forall a. (Binary a, Show a) => a -> IO ()
reply (forall a. String -> QResult a
QFail String
err :: QResult a)
        | Bool
otherwise -> do
           String
str <- SomeException -> IO String
showException SomeException
e
           forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
verbose forall a b. (a -> b) -> a -> b
$ String -> IO ()
trace (String
"QException " forall a. [a] -> [a] -> [a]
++ String
str)
           forall a. (Binary a, Show a) => a -> IO ()
reply (forall a. String -> QResult a
QException String
str :: QResult a)
      Right a
a -> do
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
verbose forall a b. (a -> b) -> a -> b
$ String -> IO ()
trace String
"QDone"
        forall a. (Binary a, Show a) => a -> IO ()
reply (forall a. a -> QResult a
QDone a
a)

  -- carefully when showing an exception, there might be other exceptions
  -- lurking inside it.  If so, we return the inner exception instead.
  showException :: SomeException -> IO String
  showException :: SomeException -> IO String
showException SomeException
e0 = do
     forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
verbose forall a b. (a -> b) -> a -> b
$ String -> IO ()
trace String
"showException"
     Either SomeException String
r <- forall e a. Exception e => IO a -> IO (Either e a)
try forall a b. (a -> b) -> a -> b
$ forall a. a -> IO a
evaluate (forall a. NFData a => a -> a
force (forall a. Show a => a -> String
show (SomeException
e0::SomeException)))
     case Either SomeException String
r of
       Left SomeException
e -> SomeException -> IO String
showException SomeException
e
       Right String
str -> forall (m :: * -> *) a. Monad m => a -> m a
return String
str

  -- throw away any pending ^C exceptions while we're not running
  -- interpreted code.  GHC will also get the ^C, and either ignore it
  -- (if this is GHCi), or tell us to quit with a Shutdown message.
  discardCtrlC :: IO ()
discardCtrlC = do
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
verbose forall a b. (a -> b) -> a -> b
$ String -> IO ()
trace String
"discardCtrlC"
    Either AsyncException ()
r <- 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
restore forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return ()
    case Either AsyncException ()
r of
      Left AsyncException
UserInterrupt -> forall (m :: * -> *) a. Monad m => a -> m a
return () forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
discardCtrlC
      Left AsyncException
e -> forall e a. Exception e => e -> IO a
throwIO AsyncException
e
      Either AsyncException ()
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()