    {-# LANGUAGE ViewPatterns #-}
    module Language.Haskell.GhciWrapper (
      Interpreter
    , Config(..)
    , defaultConfig
    , PreserveIt(..)
    , new
    , close
    , eval
    , evalWith
    , evalEcho
    ) where

    import           Imports

    import           System.IO hiding (stdin, stdout, stderr)
    import           System.Process
    import           System.Exit
    import           Data.List (isSuffixOf)

    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
    }

    data PreserveIt = NoPreserveIt | PreserveIt
      deriving PreserveIt -> PreserveIt -> Bool
    (PreserveIt -> PreserveIt -> Bool)
    -> (PreserveIt -> PreserveIt -> Bool) -> Eq PreserveIt
    forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
    $c== :: PreserveIt -> PreserveIt -> Bool
    == :: PreserveIt -> PreserveIt -> Bool
    $c/= :: PreserveIt -> PreserveIt -> Bool
    /= :: PreserveIt -> PreserveIt -> Bool
    Eq

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

    new :: Config -> [String] -> IO Interpreter
    new :: Config -> [String] -> IO Interpreter
    new Config{Bool
    String
    configGhci :: Config -> String
    configVerbose :: Config -> Bool
    configIgnoreDotGhci :: Config -> Bool
    configGhci :: String
    configVerbose :: Bool
    configIgnoreDotGhci :: Bool
    ..} [String]
    args_ = do
      (Just stdin_, Just stdout_, Nothing, processHandle ) <- CreateProcess
    -> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
    createProcess (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}
      evalThrow interpreter "import qualified System.IO"
      evalThrow interpreter "import qualified GHC.IO.Encoding"
      evalThrow interpreter "import qualified GHC.IO.Handle"
      -- The buffering of stdout and stderr is NoBuffering
      evalThrow 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.
      evalThrow interpreter "GHC.IO.Handle.hSetBuffering System.IO.stdout GHC.IO.Handle.LineBuffering"
      evalThrow 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)
      evalThrow interpreter "GHC.IO.Handle.hSetEncoding System.IO.stdout GHC.IO.Encoding.utf8"
      evalThrow interpreter "GHC.IO.Handle.hSetEncoding System.IO.stderr GHC.IO.Encoding.utf8"

      evalThrow interpreter ":m - System.IO"
      evalThrow interpreter ":m - GHC.IO.Encoding"
      evalThrow 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

        evalThrow :: Interpreter -> String -> IO ()
        evalThrow :: Interpreter -> String -> IO ()
    evalThrow Interpreter
    interpreter String
    expr = do
          output <- Interpreter -> String -> IO String
    eval Interpreter
    interpreter String
    expr
          unless (null output || configVerbose) $ do
            close interpreter
            throwIO (ErrorCall output)

    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 $ "Language.Haskell.GhciWrapper.close: Interpreter exited with an error (" ++ show e ++ ")")

    putExpression :: Interpreter -> PreserveIt -> String -> IO ()
    putExpression :: Interpreter -> PreserveIt -> String -> IO ()
    putExpression Interpreter{hIn :: Interpreter -> Handle
    hIn = Handle
    stdin} (PreserveIt -> PreserveIt -> Bool
    forall a. Eq a => a -> a -> Bool
    equals PreserveIt
    PreserveIt -> Bool
    preserveIt) String
    e = do
      Handle -> String -> IO ()
    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
    $ Handle -> String -> IO ()
    hPutStrLn Handle
    stdin (String -> IO ()) -> String -> IO ()
    forall a b. (a -> b) -> a -> b
    $ String
    "let " String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ String
    itMarker String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ String
    " = it"
      Handle -> String -> IO ()
    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
    $ Handle -> String -> IO ()
    hPutStrLn Handle
    stdin (String -> IO ()) -> String -> IO ()
    forall a b. (a -> b) -> a -> b
    $ String
    "let it = " String -> ShowS
    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
          line <- Handle -> IO String
    hGetLine Handle
    stdout
          if marker `isSuffixOf` line
            then do
              let xs = ShowS
    forall {a}. [a] -> [a]
    stripMarker String
    line
              echo xs
              return xs
            else 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 :: String -> IO ()
    echo
          | Bool
    echoMode = String -> IO ()
    putStr
          | Bool
    otherwise = \ String
    _ -> () -> 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 = PreserveIt -> Interpreter -> String -> IO String
    evalWith PreserveIt
    NoPreserveIt

    -- | Like 'eval', but try to preserve the @it@ variable
    evalWith :: PreserveIt -> Interpreter -> String -> IO String
    evalWith :: PreserveIt -> Interpreter -> String -> IO String
    evalWith PreserveIt
    preserveIt Interpreter
    repl String
    expr = do
      Interpreter -> PreserveIt -> String -> IO ()
    putExpression Interpreter
    repl PreserveIt
    preserveIt 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 -> PreserveIt -> String -> IO ()
    putExpression Interpreter
    repl PreserveIt
    NoPreserveIt String
    expr
      Bool -> Interpreter -> IO String
    getResult Bool
    True Interpreter
    repl