{-# 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 -> [Char]
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 -> [Char]
(Int -> Config -> ShowS)
-> (Config -> [Char]) -> ([Config] -> ShowS) -> Show Config
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Config -> ShowS
showsPrec :: Int -> Config -> ShowS
$cshow :: Config -> [Char]
show :: Config -> [Char]
$cshowList :: [Config] -> ShowS
showList :: [Config] -> ShowS
Show)

defaultConfig :: Config
defaultConfig :: Config
defaultConfig = Config {
  configGhci :: [Char]
configGhci = [Char]
"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 :: [Char]
marker = ShowS
forall a. Show a => a -> [Char]
show [Char]
"dcbd2a1e20ae519a1c7714df2859f1890581d57fac96ba3f499412b2f5c928a1"

itMarker :: String
itMarker :: [Char]
itMarker = [Char]
"d42472243a0e6fc481e7514cbc9eb08812ed48daa29ca815844d86010b1d113a"

data Interpreter = Interpreter {
  Interpreter -> Handle
hIn  :: Handle
, Interpreter -> Handle
hOut :: Handle
, Interpreter -> ProcessHandle
process :: ProcessHandle
}

new :: Config -> [String] -> IO Interpreter
new :: Config -> [[Char]] -> IO Interpreter
new Config{Bool
[Char]
configGhci :: Config -> [Char]
configVerbose :: Config -> Bool
configIgnoreDotGhci :: Config -> Bool
configGhci :: [Char]
configVerbose :: Bool
configIgnoreDotGhci :: Bool
..} [[Char]]
args_ = do
  (Just stdin_, Just stdout_, Nothing, processHandle ) <- CreateProcess
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
createProcess ([Char] -> [[Char]] -> CreateProcess
proc [Char]
configGhci [[Char]]
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 :: [[Char]]
args = [[Char]]
args_ [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ [Maybe [Char]] -> [[Char]]
forall a. [Maybe a] -> [a]
catMaybes [
        if Bool
configIgnoreDotGhci then [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just [Char]
"-ignore-dot-ghci" else Maybe [Char]
forall a. Maybe a
Nothing
      , if Bool
configVerbose then Maybe [Char]
forall a. Maybe a
Nothing else [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just [Char]
"-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 -> [Char] -> IO ()
evalThrow Interpreter
interpreter [Char]
expr = do
      output <- Interpreter -> [Char] -> IO [Char]
eval Interpreter
interpreter [Char]
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 -> [Char] -> IO ()
putExpression Interpreter{hIn :: Interpreter -> Handle
hIn = Handle
stdin} (PreserveIt -> PreserveIt -> Bool
forall a. Eq a => a -> a -> Bool
equals PreserveIt
PreserveIt -> Bool
preserveIt) [Char]
e = do
  Handle -> [Char] -> IO ()
hPutStrLn Handle
stdin [Char]
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 -> [Char] -> IO ()
hPutStrLn Handle
stdin ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"let " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
itMarker [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
" = it"
  Handle -> [Char] -> IO ()
hPutStrLn Handle
stdin ([Char]
marker [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
" :: 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 -> [Char] -> IO ()
hPutStrLn Handle
stdin ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"let it = " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
itMarker
  Handle -> IO ()
hFlush Handle
stdin

getResult :: Bool -> Interpreter -> IO String
getResult :: Bool -> Interpreter -> IO [Char]
getResult Bool
echoMode Interpreter{hOut :: Interpreter -> Handle
hOut = Handle
stdout} = IO [Char]
go
  where
    go :: IO [Char]
go = do
      line <- Handle -> IO [Char]
hGetLine Handle
stdout
      if marker `isSuffixOf` line
        then do
          let xs = ShowS
forall {a}. [a] -> [a]
stripMarker [Char]
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
- [Char] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Char]
marker) [a]
l

    echo :: String -> IO ()
    echo :: [Char] -> IO ()
echo
      | Bool
echoMode = [Char] -> IO ()
putStr
      | Bool
otherwise = \ [Char]
_ -> () -> 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 -> [Char] -> IO [Char]
eval = PreserveIt -> Interpreter -> [Char] -> IO [Char]
evalWith PreserveIt
NoPreserveIt

-- | Like 'eval', but try to preserve the @it@ variable
evalWith :: PreserveIt -> Interpreter -> String -> IO String
evalWith :: PreserveIt -> Interpreter -> [Char] -> IO [Char]
evalWith PreserveIt
preserveIt Interpreter
repl [Char]
expr = do
  Interpreter -> PreserveIt -> [Char] -> IO ()
putExpression Interpreter
repl PreserveIt
preserveIt [Char]
expr
  Bool -> Interpreter -> IO [Char]
getResult Bool
False Interpreter
repl

-- | Evaluate an expression
evalEcho :: Interpreter -> String -> IO String
evalEcho :: Interpreter -> [Char] -> IO [Char]
evalEcho Interpreter
repl [Char]
expr = do
  Interpreter -> PreserveIt -> [Char] -> IO ()
putExpression Interpreter
repl PreserveIt
NoPreserveIt [Char]
expr
  Bool -> Interpreter -> IO [Char]
getResult Bool
True Interpreter
repl