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

-- | Truly random marker, used to separate expressions.
--
-- IMPORTANT: This module relies upon the fact that this marker is unique.  It
-- has been obtained from random.org.  Do not expect this module to work
-- properly, if you reuse it for any purpose!
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"
  -- The buffering of stdout and stderr is NoBuffering
  String
_ <- Interpreter -> String -> IO String
eval Interpreter
interpreter String
"GHC.IO.Handle.hDuplicateTo System.IO.stdout System.IO.stderr"
  -- Now the buffering of stderr is BlockBuffering Nothing
  -- In this situation, GHC 7.7 does not flush the buffer even when
  -- error happens.
  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"

  -- this is required on systems that don't use utf8 as default encoding (e.g.
  -- Windows)
  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

  -- It is crucial not to close `hOut` before calling `waitForProcess`,
  -- otherwise ghci may not cleanly terminate on SIGINT (ctrl-c) and hang
  -- around consuming 100% CPU.  This happens when ghci tries to print
  -- something to stdout in its signal handler (e.g. when it is blocked in
  -- threadDelay it writes "Interrupted." on SIGINT).
  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
        -- For some (happy) reason newer GHCs don't decide to print this
        -- message - or at least we don't see it.
        | "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 ())

-- | Evaluate an expression
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

-- | Like 'eval', but try to preserve the @it@ variable
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

-- | Evaluate an expression
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