{-# LANGUAGE CPP #-}

module Test.DocTest.Internal.Interpreter (
  Interpreter
, safeEval
, safeEvalIt
, withInterpreter
, ghc
, interpreterSupported

-- * exported for testing
, ghcInfo
, haveInterpreterKey
) where

import System.Process
import System.Directory (getPermissions, executable)
import Control.Monad
import Control.Exception hiding (handle)
import Data.Char
import GHC.Paths (ghc)

import Test.DocTest.Internal.GhciWrapper
import Test.DocTest.Internal.Logging (DebugLogger)

-- $setup
-- >>> import Test.DocTest.Internal.GhciWrapper (eval)
-- >>> import Test.DocTest.Internal.Logging (noLogger)

haveInterpreterKey :: String
haveInterpreterKey :: String
haveInterpreterKey = String
"Have interpreter"

ghcInfo :: IO [(String, String)]
ghcInfo :: IO [(String, String)]
ghcInfo = String -> [(String, String)]
forall a. Read a => String -> a
read (String -> [(String, String)])
-> IO String -> IO [(String, String)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> [String] -> String -> IO String
readProcess String
ghc [String
"--info"] []

interpreterSupported :: IO Bool
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..
  Permissions
x <- String -> IO Permissions
getPermissions String
ghc
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Permissions -> Bool
executable Permissions
x) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    String -> IO ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
ghc String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" is not executable!"

  Bool -> (String -> Bool) -> Maybe String -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"YES") (Maybe String -> Bool)
-> ([(String, String)] -> Maybe String)
-> [(String, String)]
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [(String, String)] -> Maybe String
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
haveInterpreterKey ([(String, String)] -> Bool) -> IO [(String, String)] -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO [(String, String)]
ghcInfo

-- | Run an interpreter session.
--
-- Example:
--
-- >>> withInterpreter noLogger [] $ \i -> eval i "23 + 42"
-- "65\n"
withInterpreter
  :: DebugLogger            -- ^ Debug logger
  -> [String]               -- ^ List of flags, passed to GHC
  -> (Interpreter -> IO a)  -- ^ Action to run
  -> IO a                   -- ^ Result of action
withInterpreter :: (String -> IO ()) -> [String] -> (Interpreter -> IO a) -> IO a
withInterpreter String -> IO ()
logger [String]
flags Interpreter -> IO a
action = do
  let
    args :: [String]
args = [String]
flags [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [
        String
"--interactive"
#if __GLASGOW_HASKELL__ >= 802
      , String
"-fdiagnostics-color=never"
      , String
"-fno-diagnostics-show-caret"
#endif
      ]
  IO Interpreter
-> (Interpreter -> IO ()) -> (Interpreter -> IO a) -> IO a
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket ((String -> IO ()) -> Config -> [String] -> IO Interpreter
new String -> IO ()
logger Config
defaultConfig{configGhci :: String
configGhci = String
ghc} [String]
args) Interpreter -> IO ()
close Interpreter -> IO a
action

-- | 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 :: Interpreter -> String -> IO (Either String String)
safeEval Interpreter
repl = (String -> IO (Either String String))
-> (String -> IO (Either String String))
-> Either String String
-> IO (Either String String)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Either String String -> IO (Either String String)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String String -> IO (Either String String))
-> (String -> Either String String)
-> String
-> IO (Either String String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Either String String
forall a b. a -> Either a b
Left) ((String -> Either String String)
-> IO String -> IO (Either String String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> Either String String
forall a b. b -> Either a b
Right (IO String -> IO (Either String String))
-> (String -> IO String) -> String -> IO (Either String String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Interpreter -> String -> IO String
eval Interpreter
repl) (Either String String -> IO (Either String String))
-> (String -> Either String String)
-> String
-> IO (Either String String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Either String String
filterExpression

safeEvalIt :: Interpreter -> String -> IO (Either String String)
safeEvalIt :: Interpreter -> String -> IO (Either String String)
safeEvalIt Interpreter
repl = (String -> IO (Either String String))
-> (String -> IO (Either String String))
-> Either String String
-> IO (Either String String)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Either String String -> IO (Either String String)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String String -> IO (Either String String))
-> (String -> Either String String)
-> String
-> IO (Either String String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Either String String
forall a b. a -> Either a b
Left) ((String -> Either String String)
-> IO String -> IO (Either String String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> Either String String
forall a b. b -> Either a b
Right (IO String -> IO (Either String String))
-> (String -> IO String) -> String -> IO (Either String String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Interpreter -> String -> IO String
evalIt Interpreter
repl) (Either String String -> IO (Either String String))
-> (String -> Either String String)
-> String
-> IO (Either String String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Either String String
filterExpression

filterExpression :: String -> Either String String
filterExpression :: String -> Either String String
filterExpression String
e =
  case String -> [String]
lines String
e of
    [] -> String -> Either String String
forall a b. b -> Either a b
Right String
e
    [String]
l  -> if String
firstLine String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
":{" Bool -> Bool -> Bool
&& String
lastLine String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= String
":}" then Either String String
forall b. Either String b
fail_ else String -> Either String String
forall a b. b -> Either a b
Right String
e
      where
        firstLine :: String
firstLine = String -> String
strip (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall a. [a] -> a
head [String]
l
        lastLine :: String
lastLine  = String -> String
strip (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall a. [a] -> a
last [String]
l
        fail_ :: Either String b
fail_ = String -> Either String b
forall a b. a -> Either a b
Left String
"unterminated multiline command"
  where
    strip :: String -> String
    strip :: String -> String
strip = (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
forall a. [a] -> [a]
reverse (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
forall a. [a] -> [a]
reverse