{-# LANGUAGE CPP #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE MultiWayIf #-}
module Test.DocTest.Internal.GhciWrapper (
Interpreter
, Config(..)
, defaultConfig
, new
, close
, eval
, evalIt
, 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
import Test.DocTest.Internal.Logging (DebugLogger)
data Config = Config {
Config -> String
configGhci :: String
, Config -> Bool
configVerbose :: Bool
, Config -> Bool
configIgnoreDotGhci :: Bool
} deriving (Config -> Config -> Bool
(Config -> Config -> Bool)
-> (Config -> Config -> Bool) -> Eq Config
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
(Int -> Config -> ShowS)
-> (Config -> String) -> ([Config] -> ShowS) -> Show Config
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 :: String -> Bool -> Bool -> Config
Config {
configGhci :: String
configGhci = String
"ghci"
, configVerbose :: Bool
configVerbose = Bool
False
, configIgnoreDotGhci :: Bool
configIgnoreDotGhci = Bool
True
}
marker :: String
marker :: String
marker = ShowS
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
, Interpreter -> DebugLogger
logger :: DebugLogger
}
new :: DebugLogger -> Config -> [String] -> IO Interpreter
new :: DebugLogger -> Config -> [String] -> IO Interpreter
new DebugLogger
logger Config{Bool
String
configIgnoreDotGhci :: Bool
configVerbose :: Bool
configGhci :: String
configIgnoreDotGhci :: Config -> Bool
configVerbose :: Config -> Bool
configGhci :: Config -> String
..} [String]
args_ = do
DebugLogger
logger (String
"Calling: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ [String] -> String
unwords (String
configGhciString -> [String] -> [String]
forall a. a -> [a] -> [a]
:[String]
args))
(Just Handle
stdin_, Just Handle
stdout_, Maybe Handle
Nothing, ProcessHandle
processHandle ) <- CreateProcess
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
createProcess (CreateProcess
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle))
-> CreateProcess
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
forall a b. (a -> b) -> a -> b
$ (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 :: Handle -> Handle -> ProcessHandle -> DebugLogger -> Interpreter
Interpreter
{ hIn :: Handle
hIn = Handle
stdin_
, hOut :: Handle
hOut = Handle
stdout_
, process :: ProcessHandle
process = ProcessHandle
processHandle
, logger :: DebugLogger
logger=DebugLogger
logger
}
String
_ <- Interpreter -> String -> IO String
eval Interpreter
interpreter String
"import qualified System.IO"
String
_ <- Interpreter -> String -> IO String
eval Interpreter
interpreter String
"import qualified GHC.IO.Handle"
String
_ <- Interpreter -> String -> IO String
eval Interpreter
interpreter String
"GHC.IO.Handle.hDuplicateTo System.IO.stdout System.IO.stderr"
String
_ <- Interpreter -> String -> IO String
eval Interpreter
interpreter String
"GHC.IO.Handle.hSetBuffering System.IO.stdout GHC.IO.Handle.LineBuffering"
String
_ <- Interpreter -> String -> IO String
eval Interpreter
interpreter String
"GHC.IO.Handle.hSetBuffering System.IO.stderr GHC.IO.Handle.LineBuffering"
String
_ <- Interpreter -> String -> IO String
eval Interpreter
interpreter String
"GHC.IO.Handle.hSetEncoding System.IO.stdout System.IO.utf8"
String
_ <- Interpreter -> String -> IO String
eval Interpreter
interpreter String
"GHC.IO.Handle.hSetEncoding System.IO.stderr System.IO.utf8"
String
_ <- Interpreter -> String -> IO String
eval Interpreter
interpreter String
":m - System.IO"
String
_ <- Interpreter -> String -> IO String
eval Interpreter
interpreter String
":m - GHC.IO.Handle"
Interpreter -> IO Interpreter
forall (m :: * -> *) a. Monad m => a -> m a
return Interpreter
interpreter
where
args :: [String]
args = [String]
args_ [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [Maybe String] -> [String]
forall a. [Maybe a] -> [a]
catMaybes [
if Bool
configIgnoreDotGhci then String -> Maybe String
forall a. a -> Maybe a
Just String
"-ignore-dot-ghci" else Maybe String
forall a. Maybe a
Nothing
, if Bool
configVerbose then Maybe String
forall a. Maybe a
Nothing else String -> Maybe String
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
close :: Interpreter -> IO ()
close :: Interpreter -> IO ()
close Interpreter
repl = do
Handle -> IO ()
hClose (Handle -> IO ()) -> Handle -> IO ()
forall a b. (a -> b) -> a -> b
$ Interpreter -> Handle
hIn Interpreter
repl
ExitCode
e <- ProcessHandle -> IO ExitCode
waitForProcess (ProcessHandle -> IO ExitCode) -> ProcessHandle -> IO ExitCode
forall a b. (a -> b) -> a -> b
$ Interpreter -> ProcessHandle
process Interpreter
repl
Handle -> IO ()
hClose (Handle -> IO ()) -> Handle -> IO ()
forall a b. (a -> b) -> a -> b
$ Interpreter -> Handle
hOut Interpreter
repl
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ExitCode
e ExitCode -> ExitCode -> Bool
forall a. Eq a => a -> a -> Bool
/= ExitCode
ExitSuccess) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
IOError -> IO ()
forall e a. Exception e => e -> IO a
throwIO (String -> IOError
userError (String -> IOError) -> String -> IOError
forall a b. (a -> b) -> a -> b
$ String
"Test.DocTest.Internal.GhciWrapper.close: Interpreter exited with an error (" String -> ShowS
forall a. [a] -> [a] -> [a]
++ ExitCode -> String
forall a. Show a => a -> String
show ExitCode
e String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
")")
putExpression :: Interpreter -> Bool -> String -> IO ()
putExpression :: Interpreter -> Bool -> DebugLogger
putExpression Interpreter{logger :: Interpreter -> DebugLogger
logger = DebugLogger
logger, hIn :: Interpreter -> Handle
hIn = Handle
stdin} Bool
preserveIt String
e = do
DebugLogger
logger (String
">>> " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
e)
Handle -> DebugLogger
hPutStrLn Handle
stdin String
e
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
preserveIt (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
let e1 :: String
e1 = String
"let " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
itMarker String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" = it"
DebugLogger
logger (String
">>> " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
e1)
Handle -> DebugLogger
hPutStrLn Handle
stdin String
e1
Handle -> DebugLogger
hPutStrLn Handle
stdin (String
marker String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" :: Data.String.String")
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
preserveIt (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
let e3 :: String
e3 = String
"let it = " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
itMarker
DebugLogger
logger (String
">>> " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
e3)
Handle -> DebugLogger
hPutStrLn Handle
stdin String
e3
Handle -> IO ()
hFlush Handle
stdin
getResult :: Bool -> Interpreter -> IO String
getResult :: Bool -> Interpreter -> IO String
getResult Bool
echoMode Interpreter{logger :: Interpreter -> DebugLogger
logger = DebugLogger
logger, hOut :: Interpreter -> Handle
hOut = Handle
stdout} = do
String
result <- IO String
go
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (String
result String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
forall a. Monoid a => a
mempty) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ DebugLogger
logger String
result
String -> IO String
forall (f :: * -> *) a. Applicative f => a -> f a
pure String
result
where
go :: IO String
go = do
String
line <- Handle -> IO String
hGetLine Handle
stdout
if
| String
marker String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` String
line -> do
let xs :: String
xs = ShowS
forall a. [a] -> [a]
stripMarker String
line
DebugLogger
echo String
xs
String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return String
xs
#if __GLASGOW_HASKELL__ < 810
| "Loaded package environment from " `isPrefixOf` line -> do
go
#endif
| Bool
otherwise -> do
DebugLogger
echo (String
line String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\n")
String
result <- IO String
go
String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return (String
line String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\n" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
result)
stripMarker :: [a] -> [a]
stripMarker [a]
l = Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
take ([a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
l Int -> Int -> Int
forall a. Num a => a -> a -> a
- String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
marker) [a]
l
echo :: String -> IO ()
echo :: DebugLogger
echo
| Bool
echoMode = DebugLogger
putStr
| Bool
otherwise = (IO () -> DebugLogger
forall a b. a -> b -> a
const (IO () -> DebugLogger) -> IO () -> DebugLogger
forall a b. (a -> b) -> a -> b
$ () -> IO ()
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 -> DebugLogger
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 -> DebugLogger
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 -> DebugLogger
putExpression Interpreter
repl Bool
False String
expr
Bool -> Interpreter -> IO String
getResult Bool
True Interpreter
repl