module Language.Haskell.GhciWrapper (
  Interpreter
, Config(..)
, defaultConfig
, new
, close
, eval
, evalIt
, evalEcho
) where

import           Imports

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

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

  Interpreter -> String -> IO ()
evalThrow Interpreter
interpreter String
":m - System.IO"
  Interpreter -> String -> IO ()
evalThrow Interpreter
interpreter String
":m - GHC.IO.Encoding"
  Interpreter -> String -> IO ()
evalThrow Interpreter
interpreter String
":m - GHC.IO.Handle"

  forall (m :: * -> *) a. Monad m => a -> m a
return Interpreter
interpreter
  where
    args :: [String]
args = [String]
args_ forall a. [a] -> [a] -> [a]
++ forall a. [Maybe a] -> [a]
catMaybes [
        if Bool
configIgnoreDotGhci then forall a. a -> Maybe a
Just String
"-ignore-dot-ghci" else forall a. Maybe a
Nothing
      , if Bool
configVerbose then forall a. Maybe a
Nothing else 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
      String
output <- Interpreter -> String -> IO String
eval Interpreter
interpreter String
expr
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
output Bool -> Bool -> Bool
|| Bool
configVerbose) forall a b. (a -> b) -> a -> b
$ do
        Interpreter -> IO ()
close Interpreter
interpreter
        forall e a. Exception e => e -> IO a
throwIO (String -> ErrorCall
ErrorCall String
output)

close :: Interpreter -> IO ()
close :: Interpreter -> IO ()
close Interpreter
repl = do
  Handle -> IO ()
hClose 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 forall a b. (a -> b) -> a -> b
$ Interpreter -> ProcessHandle
process Interpreter
repl
  Handle -> IO ()
hClose forall a b. (a -> b) -> a -> b
$ Interpreter -> Handle
hOut Interpreter
repl

  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ExitCode
e forall a. Eq a => a -> a -> Bool
/= ExitCode
ExitSuccess) forall a b. (a -> b) -> a -> b
$ do
    forall e a. Exception e => e -> IO a
throwIO (String -> IOError
userError forall a b. (a -> b) -> a -> b
$ String
"Language.Haskell.GhciWrapper.close: Interpreter exited with an error (" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show ExitCode
e forall a. [a] -> [a] -> [a]
++ String
")")

putExpression :: Interpreter -> Bool -> String -> IO ()
putExpression :: Interpreter -> Bool -> String -> IO ()
putExpression Interpreter{hIn :: Interpreter -> Handle
hIn = Handle
stdin} Bool
preserveIt String
e = do
  Handle -> String -> IO ()
hPutStrLn Handle
stdin String
e
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
preserveIt forall a b. (a -> b) -> a -> b
$ Handle -> String -> IO ()
hPutStrLn Handle
stdin forall a b. (a -> b) -> a -> b
$ String
"let " forall a. [a] -> [a] -> [a]
++ String
itMarker forall a. [a] -> [a] -> [a]
++ String
" = it"
  Handle -> String -> IO ()
hPutStrLn Handle
stdin (String
marker forall a. [a] -> [a] -> [a]
++ String
" :: Data.String.String")
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
preserveIt forall a b. (a -> b) -> a -> b
$ Handle -> String -> IO ()
hPutStrLn Handle
stdin forall a b. (a -> b) -> a -> b
$ String
"let it = " 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
      String
line <- Handle -> IO String
hGetLine Handle
stdout
      if String
marker forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` String
line
        then do
          let xs :: String
xs = forall {a}. [a] -> [a]
stripMarker String
line
          String -> IO ()
echo String
xs
          forall (m :: * -> *) a. Monad m => a -> m a
return String
xs
        else do
          String -> IO ()
echo (String
line forall a. [a] -> [a] -> [a]
++ String
"\n")
          String
result <- IO String
go
          forall (m :: * -> *) a. Monad m => a -> m a
return (String
line forall a. [a] -> [a] -> [a]
++ String
"\n" forall a. [a] -> [a] -> [a]
++ String
result)
    stripMarker :: [a] -> [a]
stripMarker [a]
l = forall a. Int -> [a] -> [a]
take (forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
l forall a. Num a => a -> a -> a
- 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
_ -> 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 -> String -> IO ()
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 -> String -> IO ()
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 -> String -> IO ()
putExpression Interpreter
repl Bool
False String
expr
  Bool -> Interpreter -> IO String
getResult Bool
True Interpreter
repl