module Interpreter (
Interpreter
, eval
, safeEval
, withInterpreter
, ghc
, interpreterSupported
, ghcInfo
, haveInterpreterKey
) where
import System.IO
import System.Process
import System.Exit
import System.Directory (getPermissions, executable)
import Control.Monad (when, unless)
import Control.Applicative
import Control.Exception hiding (handle)
import Data.Char
import Data.List
import GHC.Paths (ghc)
import Sandbox (getSandboxArguments)
marker :: String
marker = show "dcbd2a1e20ae519a1c7714df2859f1890581d57fac96ba3f499412b2f5c928a1"
data Interpreter = Interpreter {
hIn :: Handle
, hOut :: Handle
, process :: ProcessHandle
}
haveInterpreterKey :: String
haveInterpreterKey = "Have interpreter"
ghcInfo :: IO [(String, String)]
ghcInfo = read <$> readProcess ghc ["--info"] []
interpreterSupported :: IO Bool
interpreterSupported = do
x <- getPermissions ghc
unless (executable x) $ do
fail $ ghc ++ " is not executable!"
maybe False (== "YES") . lookup haveInterpreterKey <$> ghcInfo
newInterpreter :: [String] -> IO Interpreter
newInterpreter flags = do
sandboxFlags <- getSandboxArguments
let myFlags = ghciFlags ++ flags ++ sandboxFlags
(Just stdin_, Just stdout_, Nothing, processHandle ) <- createProcess $ (proc ghc myFlags) {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"
return interpreter
where
ghciFlags = ["-v0", "--interactive", "-ignore-dot-ghci"]
setMode handle = do
hSetBinaryMode handle False
hSetBuffering handle LineBuffering
hSetEncoding handle utf8
withInterpreter
:: [String]
-> (Interpreter -> IO a)
-> IO a
withInterpreter flags = bracket (newInterpreter flags) closeInterpreter
closeInterpreter :: Interpreter -> IO ()
closeInterpreter repl = do
hClose $ hIn repl
e <- waitForProcess $ process repl
hClose $ hOut repl
when (e /= ExitSuccess) $ error $ "Interpreter exited with an error: " ++ show e
return ()
putExpression :: Interpreter -> String -> IO ()
putExpression repl e = do
hPutStrLn stdin_ $ filterExpression e
hPutStrLn stdin_ marker
hFlush stdin_
return ()
where
stdin_ = hIn repl
filterExpression :: String -> String
filterExpression e =
case lines e of
[] -> e
l -> if firstLine == ":{" && lastLine /= ":}" then fail_ else e
where
firstLine = strip $ head l
lastLine = strip $ last l
fail_ = error "unterminated multiline command"
where
strip :: String -> String
strip = dropWhile isSpace . reverse . dropWhile isSpace . reverse
getResult :: Interpreter -> IO String
getResult repl = do
line <- hGetLine stdout_
if marker `isSuffixOf` line
then
return $ stripMarker line
else do
result <- getResult repl
return $ line ++ '\n' : result
where
stdout_ = hOut repl
stripMarker l = take (length l length marker) l
eval
:: Interpreter
-> String
-> IO String
eval repl expr = do
putExpression repl expr
getResult repl
safeEval :: Interpreter -> String -> IO (Either String String)
safeEval repl expression = (Right `fmap` Interpreter.eval repl expression) `catches` [
Handler $ \e -> throw (e :: AsyncException),
Handler $ \e -> (return . Left . show) (e :: SomeException)
]