module Language.Haskell.GhciWrapper (
Interpreter
, Config(..)
, defaultConfig
, new
, close
, eval
, evalIt
, evalEcho
) where
import Imports
import System.IO hiding (stdin, stdout, stderr)
import System.Process
import System.Exit
import Control.Exception
import Data.List (isSuffixOf)
import Data.Maybe
data Config = Config {
Config -> String
configGhci :: String
, Config -> Bool
configVerbose :: Bool
, Config -> Bool
configIgnoreDotGhci :: Bool
} deriving (Config -> Config -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Config -> Config -> Bool
$c/= :: Config -> Config -> Bool
== :: Config -> Config -> Bool
$c== :: Config -> Config -> Bool
Eq, Int -> Config -> ShowS
[Config] -> ShowS
Config -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Config] -> ShowS
$cshowList :: [Config] -> ShowS
show :: Config -> String
$cshow :: Config -> String
showsPrec :: Int -> Config -> ShowS
$cshowsPrec :: Int -> Config -> ShowS
Show)
defaultConfig :: Config
defaultConfig :: Config
defaultConfig = Config {
configGhci :: String
configGhci = String
"ghci"
, configVerbose :: Bool
configVerbose = Bool
False
, configIgnoreDotGhci :: Bool
configIgnoreDotGhci = Bool
True
}
marker :: String
marker :: String
marker = forall a. Show a => a -> String
show String
"dcbd2a1e20ae519a1c7714df2859f1890581d57fac96ba3f499412b2f5c928a1"
itMarker :: String
itMarker :: String
itMarker = String
"d42472243a0e6fc481e7514cbc9eb08812ed48daa29ca815844d86010b1d113a"
data Interpreter = Interpreter {
Interpreter -> Handle
hIn :: Handle
, Interpreter -> Handle
hOut :: Handle
, Interpreter -> ProcessHandle
process :: ProcessHandle
}
new :: Config -> [String] -> IO Interpreter
new :: Config -> [String] -> IO Interpreter
new Config{Bool
String
configIgnoreDotGhci :: Bool
configVerbose :: Bool
configGhci :: String
configIgnoreDotGhci :: Config -> Bool
configVerbose :: Config -> Bool
configGhci :: Config -> String
..} [String]
args_ = do
(Just Handle
stdin_, Just Handle
stdout_, Maybe Handle
Nothing, ProcessHandle
processHandle ) <- CreateProcess
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
createProcess (String -> [String] -> CreateProcess
proc String
configGhci [String]
args) {
std_in :: StdStream
std_in = StdStream
CreatePipe
, std_out :: StdStream
std_out = StdStream
CreatePipe
, std_err :: StdStream
std_err = StdStream
Inherit
}
Handle -> IO ()
setMode Handle
stdin_
Handle -> IO ()
setMode Handle
stdout_
let interpreter :: Interpreter
interpreter = Interpreter {hIn :: Handle
hIn = Handle
stdin_, hOut :: Handle
hOut = Handle
stdout_, process :: ProcessHandle
process = ProcessHandle
processHandle}
Interpreter -> String -> IO ()
evalThrow Interpreter
interpreter String
"import qualified System.IO"
Interpreter -> String -> IO ()
evalThrow Interpreter
interpreter String
"import qualified GHC.IO.Encoding"
Interpreter -> String -> IO ()
evalThrow Interpreter
interpreter String
"import qualified GHC.IO.Handle"
Interpreter -> String -> IO ()
evalThrow Interpreter
interpreter String
"GHC.IO.Handle.hDuplicateTo System.IO.stdout System.IO.stderr"
Interpreter -> String -> IO ()
evalThrow Interpreter
interpreter String
"GHC.IO.Handle.hSetBuffering System.IO.stdout GHC.IO.Handle.LineBuffering"
Interpreter -> String -> IO ()
evalThrow Interpreter
interpreter String
"GHC.IO.Handle.hSetBuffering System.IO.stderr GHC.IO.Handle.LineBuffering"
Interpreter -> String -> IO ()
evalThrow Interpreter
interpreter String
"GHC.IO.Handle.hSetEncoding System.IO.stdout GHC.IO.Encoding.utf8"
Interpreter -> String -> IO ()
evalThrow Interpreter
interpreter String
"GHC.IO.Handle.hSetEncoding System.IO.stderr GHC.IO.Encoding.utf8"
Interpreter -> String -> IO ()
evalThrow Interpreter
interpreter String
":m - System.IO"
Interpreter -> String -> IO ()
evalThrow Interpreter
interpreter String
":m - GHC.IO.Encoding"
Interpreter -> String -> IO ()
evalThrow Interpreter
interpreter String
":m - GHC.IO.Handle"
forall (m :: * -> *) a. Monad m => a -> m a
return Interpreter
interpreter
where
args :: [String]
args = [String]
args_ forall a. [a] -> [a] -> [a]
++ forall a. [Maybe a] -> [a]
catMaybes [
if Bool
configIgnoreDotGhci then forall a. a -> Maybe a
Just String
"-ignore-dot-ghci" else forall a. Maybe a
Nothing
, if Bool
configVerbose then forall a. Maybe a
Nothing else forall a. a -> Maybe a
Just String
"-v0"
]
setMode :: Handle -> IO ()
setMode Handle
h = do
Handle -> Bool -> IO ()
hSetBinaryMode Handle
h Bool
False
Handle -> BufferMode -> IO ()
hSetBuffering Handle
h BufferMode
LineBuffering
Handle -> TextEncoding -> IO ()
hSetEncoding Handle
h TextEncoding
utf8
evalThrow :: Interpreter -> String -> IO ()
evalThrow :: Interpreter -> String -> IO ()
evalThrow Interpreter
interpreter String
expr = do
String
output <- Interpreter -> String -> IO String
eval Interpreter
interpreter String
expr
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
output Bool -> Bool -> Bool
|| Bool
configVerbose) forall a b. (a -> b) -> a -> b
$ do
Interpreter -> IO ()
close Interpreter
interpreter
forall e a. Exception e => e -> IO a
throwIO (String -> ErrorCall
ErrorCall String
output)
close :: Interpreter -> IO ()
close :: Interpreter -> IO ()
close Interpreter
repl = do
Handle -> IO ()
hClose forall a b. (a -> b) -> a -> b
$ Interpreter -> Handle
hIn Interpreter
repl
ExitCode
e <- ProcessHandle -> IO ExitCode
waitForProcess forall a b. (a -> b) -> a -> b
$ Interpreter -> ProcessHandle
process Interpreter
repl
Handle -> IO ()
hClose forall a b. (a -> b) -> a -> b
$ Interpreter -> Handle
hOut Interpreter
repl
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ExitCode
e forall a. Eq a => a -> a -> Bool
/= ExitCode
ExitSuccess) forall a b. (a -> b) -> a -> b
$ do
forall e a. Exception e => e -> IO a
throwIO (String -> IOError
userError forall a b. (a -> b) -> a -> b
$ String
"Language.Haskell.GhciWrapper.close: Interpreter exited with an error (" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show ExitCode
e forall a. [a] -> [a] -> [a]
++ String
")")
putExpression :: Interpreter -> Bool -> String -> IO ()
putExpression :: Interpreter -> Bool -> String -> IO ()
putExpression Interpreter{hIn :: Interpreter -> Handle
hIn = Handle
stdin} Bool
preserveIt String
e = do
Handle -> String -> IO ()
hPutStrLn Handle
stdin String
e
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
preserveIt forall a b. (a -> b) -> a -> b
$ Handle -> String -> IO ()
hPutStrLn Handle
stdin forall a b. (a -> b) -> a -> b
$ String
"let " forall a. [a] -> [a] -> [a]
++ String
itMarker forall a. [a] -> [a] -> [a]
++ String
" = it"
Handle -> String -> IO ()
hPutStrLn Handle
stdin (String
marker forall a. [a] -> [a] -> [a]
++ String
" :: Data.String.String")
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
preserveIt forall a b. (a -> b) -> a -> b
$ Handle -> String -> IO ()
hPutStrLn Handle
stdin forall a b. (a -> b) -> a -> b
$ String
"let it = " forall a. [a] -> [a] -> [a]
++ String
itMarker
Handle -> IO ()
hFlush Handle
stdin
getResult :: Bool -> Interpreter -> IO String
getResult :: Bool -> Interpreter -> IO String
getResult Bool
echoMode Interpreter{hOut :: Interpreter -> Handle
hOut = Handle
stdout} = IO String
go
where
go :: IO String
go = do
String
line <- Handle -> IO String
hGetLine Handle
stdout
if String
marker forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` String
line
then do
let xs :: String
xs = forall {a}. [a] -> [a]
stripMarker String
line
String -> IO ()
echo String
xs
forall (m :: * -> *) a. Monad m => a -> m a
return String
xs
else do
String -> IO ()
echo (String
line forall a. [a] -> [a] -> [a]
++ String
"\n")
String
result <- IO String
go
forall (m :: * -> *) a. Monad m => a -> m a
return (String
line forall a. [a] -> [a] -> [a]
++ String
"\n" forall a. [a] -> [a] -> [a]
++ String
result)
stripMarker :: [a] -> [a]
stripMarker [a]
l = forall a. Int -> [a] -> [a]
take (forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
l forall a. Num a => a -> a -> a
- forall (t :: * -> *) a. Foldable t => t a -> Int
length String
marker) [a]
l
echo :: String -> IO ()
echo :: String -> IO ()
echo
| Bool
echoMode = String -> IO ()
putStr
| Bool
otherwise = \ String
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
eval :: Interpreter -> String -> IO String
eval :: Interpreter -> String -> IO String
eval Interpreter
repl String
expr = do
Interpreter -> Bool -> String -> IO ()
putExpression Interpreter
repl Bool
False String
expr
Bool -> Interpreter -> IO String
getResult Bool
False Interpreter
repl
evalIt :: Interpreter -> String -> IO String
evalIt :: Interpreter -> String -> IO String
evalIt Interpreter
repl String
expr = do
Interpreter -> Bool -> String -> IO ()
putExpression Interpreter
repl Bool
True String
expr
Bool -> Interpreter -> IO String
getResult Bool
False Interpreter
repl
evalEcho :: Interpreter -> String -> IO String
evalEcho :: Interpreter -> String -> IO String
evalEcho Interpreter
repl String
expr = do
Interpreter -> Bool -> String -> IO ()
putExpression Interpreter
repl Bool
False String
expr
Bool -> Interpreter -> IO String
getResult Bool
True Interpreter
repl