    {-# 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
    $c== :: Config -> Config -> Bool
    == :: Config -> Config -> Bool
    $c/= :: Config -> Config -> Bool
    /= :: 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
    $cshowsPrec :: Int -> Config -> ShowS
    showsPrec :: Int -> Config -> ShowS
    $cshow :: Config -> String
    show :: Config -> String
    $cshowList :: [Config] -> ShowS
    showList :: [Config] -> ShowS
    Show)

    defaultConfig :: Config
    defaultConfig :: Config
    defaultConfig = 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
    configGhci :: Config -> String
    configVerbose :: Config -> Bool
    configIgnoreDotGhci :: Config -> Bool
    configGhci :: String
    configVerbose :: Bool
    configIgnoreDotGhci :: Bool
    ..} [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 stdin_, Just stdout_, Nothing, 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 = CreatePipe, std_out = CreatePipe, std_err = Inherit}
      setMode stdin_
      setMode stdout_
      let
        interpreter = Interpreter
          { hIn :: Handle
    hIn = Handle
    stdin_
          , hOut :: Handle
    hOut = Handle
    stdout_
          , process :: ProcessHandle
    process = ProcessHandle
    processHandle
          , logger :: DebugLogger
    logger=DebugLogger
    logger
          }
      _ <- eval interpreter "import qualified System.IO"
      _ <- eval interpreter "import qualified GHC.IO.Handle"
      -- The buffering of stdout and stderr is NoBuffering
      _ <- eval interpreter "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.
      _ <- eval interpreter "GHC.IO.Handle.hSetBuffering System.IO.stdout GHC.IO.Handle.LineBuffering"
      _ <- eval interpreter "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)
      _ <- eval interpreter "GHC.IO.Handle.hSetEncoding System.IO.stdout System.IO.utf8"
      _ <- eval interpreter "GHC.IO.Handle.hSetEncoding System.IO.stderr System.IO.utf8"

      _ <- eval interpreter ":m - System.IO"
      _ <- eval interpreter ":m - GHC.IO.Handle"

      return 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).
      e <- ProcessHandle -> IO ExitCode
    waitForProcess (ProcessHandle -> IO ExitCode) -> ProcessHandle -> IO ExitCode
    forall a b. (a -> b) -> a -> b
    $ Interpreter -> ProcessHandle
    process Interpreter
    repl
      hClose $ hOut repl

      when (e /= ExitSuccess) $ do
        throwIO (userError $ "Test.DocTest.Internal.GhciWrapper.close: Interpreter exited with an error (" ++ show e ++ ")")

    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
      result <- IO String
    go
      unless (result == mempty) $ logger result
      pure result
      where
        go :: IO String
    go = do
          line <- Handle -> IO String
    hGetLine Handle
    stdout

          if
            | marker `isSuffixOf` line -> do
              let xs = ShowS
    forall {a}. [a] -> [a]
    stripMarker String
    line
              echo xs
              return xs
            | otherwise -> do
              echo (line ++ "\n")
              result <- go
              return (line ++ "\n" ++ result)
        stripMarker :: [a] -> [a]
    stripMarker [a]
    l = Int -> [a] -> [a]
    forall a. Int -> [a] -> [a]
    take ([a] -> Int
    forall a. [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 a. [a] -> 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 a. a -> IO a
    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