module Language.Haskell.GhciWrapper (
Interpreter
, Config(..)
, defaultConfig
, new
, close
, eval
, evalEcho
) where
import System.IO hiding (stdin, stdout, stderr)
import System.Process
import System.Exit
import Control.Monad
import Control.Exception
import Data.List
import Data.Maybe
data Config = Config {
configGhci :: String
, configVerbose :: Bool
, configIgnoreDotGhci :: Bool
} deriving (Eq, Show)
defaultConfig :: Config
defaultConfig = Config {
configGhci = "ghci"
, configVerbose = False
, configIgnoreDotGhci = True
}
marker :: String
marker = show "dcbd2a1e20ae519a1c7714df2859f1890581d57fac96ba3f499412b2f5c928a1"
data Interpreter = Interpreter {
hIn :: Handle
, hOut :: Handle
, process :: ProcessHandle
}
new :: Config -> [String] -> IO Interpreter
new Config{..} args_ = do
(Just stdin_, Just stdout_, Nothing, processHandle ) <- createProcess $ (proc configGhci args) {std_in = CreatePipe, std_out = CreatePipe, std_err = Inherit}
setMode stdin_
setMode stdout_
let interpreter = Interpreter {hIn = stdin_, hOut = stdout_, process = processHandle}
_ <- eval interpreter "import System.IO"
_ <- eval interpreter "import GHC.IO.Handle"
_ <- eval interpreter "hDuplicateTo stdout stderr"
_ <- eval interpreter "hSetBuffering stdout LineBuffering"
_ <- eval interpreter "hSetBuffering stderr LineBuffering"
_ <- eval interpreter "hSetEncoding stdout utf8"
_ <- eval interpreter "hSetEncoding stderr utf8"
_ <- eval interpreter ":m - System.IO"
_ <- eval interpreter ":m - GHC.IO.Handle"
return interpreter
where
args = args_ ++ catMaybes [
if configIgnoreDotGhci then Just "-ignore-dot-ghci" else Nothing
, if configVerbose then Nothing else Just "-v0"
]
setMode h = do
hSetBinaryMode h False
hSetBuffering h LineBuffering
hSetEncoding h utf8
close :: Interpreter -> IO ()
close repl = do
hClose $ hIn repl
e <- waitForProcess $ process repl
hClose $ hOut repl
when (e /= ExitSuccess) $ do
throwIO (userError $ "Language.Haskell.GhciWrapper.close: Interpreter exited with an error (" ++ show e ++ ")")
putExpression :: Interpreter -> String -> IO ()
putExpression Interpreter{hIn = stdin} e = do
hPutStrLn stdin e
hPutStrLn stdin marker
hFlush stdin
getResult :: Bool -> Interpreter -> IO String
getResult echoMode Interpreter{hOut = stdout} = go
where
go = do
line <- hGetLine stdout
if marker `isSuffixOf` line
then do
let xs = stripMarker line
echo xs
return xs
else do
echo (line ++ "\n")
result <- go
return (line ++ "\n" ++ result)
stripMarker l = take (length l length marker) l
echo :: String -> IO ()
echo
| echoMode = putStr
| otherwise = (const $ return ())
eval :: Interpreter -> String -> IO String
eval repl expr = do
putExpression repl expr
getResult False repl
evalEcho :: Interpreter -> String -> IO String
evalEcho repl expr = do
putExpression repl expr
getResult True repl