doctest-0.9.8: src/Interpreter.hs

module Interpreter (
  Interpreter
, eval
, safeEval
, withInterpreter
, ghc
, interpreterSupported

-- exported for testing
, ghcInfo
, haveInterpreterKey
) where

import           System.IO
import           System.Process
import           System.Exit
import           System.Directory (getPermissions, executable)
import           Control.Monad (when, unless)
import           Control.Applicative
import           Control.Exception hiding (handle)
import           Data.Char
import           Data.List

import           GHC.Paths (ghc)
import           Sandbox (getSandboxArguments)

-- | 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 = show "dcbd2a1e20ae519a1c7714df2859f1890581d57fac96ba3f499412b2f5c928a1"

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

haveInterpreterKey :: String
haveInterpreterKey = "Have interpreter"

ghcInfo :: IO [(String, String)]
ghcInfo = read <$> readProcess ghc ["--info"] []

interpreterSupported :: IO Bool
interpreterSupported = do
  -- in a perfect world this permission check should never fail, but I know of
  -- at least one case where it did..
  x <- getPermissions ghc
  unless (executable x) $ do
    fail $ ghc ++ " is not executable!"

  maybe False (== "YES") . lookup haveInterpreterKey <$> ghcInfo

newInterpreter :: [String] -> IO Interpreter
newInterpreter flags = do
  sandboxFlags <- getSandboxArguments
  let myFlags = ghciFlags ++ flags ++ sandboxFlags
  -- get examples from Haddock comments
  (Just stdin_, Just stdout_, Nothing, processHandle ) <- createProcess $ (proc ghc myFlags) {std_in = CreatePipe, std_out = CreatePipe, std_err = Inherit}
  setMode stdin_
  setMode stdout_
  let interpreter = Interpreter {hIn = stdin_, hOut = stdout_, process = processHandle}
  _ <- eval interpreter "import System.IO"
  _ <- eval interpreter "import GHC.IO.Handle"
  -- The buffering of stdout and stderr is NoBuffering
  _ <- eval interpreter "hDuplicateTo stdout 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 "hSetBuffering stdout LineBuffering"
  _ <- eval interpreter "hSetBuffering stderr LineBuffering"

  -- this is required on systems that don't use utf8 as default encoding (e.g.
  -- Windows)
  _ <- eval interpreter "hSetEncoding stdout utf8"
  _ <- eval interpreter "hSetEncoding stderr utf8"

  return interpreter
  where
    ghciFlags = ["-v0", "--interactive", "-ignore-dot-ghci"]
    setMode handle = do
      hSetBinaryMode handle False
      hSetBuffering handle LineBuffering
      hSetEncoding handle utf8


-- | Run an interpreter session.
--
-- Example:
--
-- >>> withInterpreter [] $ \i -> eval i "23 + 42"
-- "65\n"
withInterpreter
  :: [String]               -- ^ List of flags, passed to GHC
  -> (Interpreter -> IO a)  -- ^ Action to run
  -> IO a                   -- ^ Result of action
withInterpreter flags = bracket (newInterpreter flags) closeInterpreter


closeInterpreter :: Interpreter -> IO ()
closeInterpreter repl = do
  hClose $ hIn 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 <- waitForProcess $ process repl
  hClose $ hOut repl

  when (e /= ExitSuccess) $ error $ "Interpreter exited with an error: " ++ show e
  return ()

putExpression :: Interpreter -> String -> IO ()
putExpression repl e = do
  hPutStrLn stdin_ $ filterExpression e
  hPutStrLn stdin_ marker
  hFlush stdin_
  return ()
  where
    stdin_ = hIn repl


-- | Fail on unterminated multiline commands.
--
-- Examples:
--
-- >>> filterExpression ""
-- ""
--
-- >>> filterExpression "foobar"
-- "foobar"
--
-- >>> filterExpression ":{"
-- "*** Exception: unterminated multiline command
--
-- >>> filterExpression "  :{  "
-- "*** Exception: unterminated multiline command
--
-- >>> filterExpression "  :{  \nfoobar"
-- "*** Exception: unterminated multiline command
--
-- >>> filterExpression "  :{  \nfoobar \n  :}  "
-- "  :{  \nfoobar \n  :}  "
--
filterExpression :: String -> String
filterExpression e =
  case lines e of
    [] -> e
    l  -> if firstLine == ":{" && lastLine /= ":}" then fail_ else e
      where
        firstLine = strip $ head l
        lastLine  = strip $ last l
        fail_ = error "unterminated multiline command"
  where
    strip :: String -> String
    strip = dropWhile isSpace . reverse . dropWhile isSpace . reverse


getResult :: Interpreter -> IO String
getResult repl = do
  line <- hGetLine stdout_
  if marker `isSuffixOf` line
    then
      return $ stripMarker line
    else do
      result <- getResult repl
      return $ line ++ '\n' : result
  where
    stdout_ = hOut repl
    stripMarker l = take (length l - length marker) l

-- | Evaluate an expresion
eval
  :: Interpreter
  -> String       -- Expression
  -> IO String    -- Result
eval repl expr = do
  putExpression repl expr
  getResult repl

-- | Evaluate an expression; return a Left value on exceptions.
--
-- An exception may e.g. be caused on unterminated multiline expressions.
safeEval :: Interpreter -> String -> IO (Either String String)
safeEval repl expression = (Right `fmap` Interpreter.eval repl expression) `catches` [
  -- Re-throw AsyncException, otherwise execution will not terminate on
  -- SIGINT (ctrl-c).  All AsyncExceptions are re-thrown (not just
  -- UserInterrupt) because all of them indicate severe conditions and
  -- should not occur during normal test runs.
  Handler $ \e -> throw (e :: AsyncException),

  Handler $ \e -> (return . Left . show) (e :: SomeException)
  ]