{-# LANGUAGE CPP #-}

#if __GLASGOW_HASKELL__ <= 906
{-# LANGUAGE LambdaCase #-}
#endif

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
#if __GLASGOW_HASKELL__ > 906
import Data.List (unsnoc)
#else
import Data.Bifunctor (first)
#endif
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)

#if __GLASGOW_HASKELL__ <= 906
-- | If the list is empty returns 'Nothing', otherwise returns the 'init' and the 'last'.
--
-- > unsnoc "test" == Just ("tes",'t')
-- > unsnoc ""     == Nothing
-- > \xs -> unsnoc xs == if null xs then Nothing else Just (init xs, last xs)
unsnoc :: [a] -> Maybe ([a], a)
unsnoc :: forall a. [a] -> Maybe ([a], a)
unsnoc = \case
  []   -> Maybe ([a], a)
forall a. Maybe a
Nothing
  a
x:[a]
xs -> ([a], a) -> Maybe ([a], a)
forall a. a -> Maybe a
Just (([a], a) -> Maybe ([a], a)) -> ([a], a) -> Maybe ([a], a)
forall a b. (a -> b) -> a -> b
$ a -> [a] -> ([a], a)
forall a. a -> [a] -> ([a], a)
unsnoc1 a
x [a]
xs
  where
    unsnoc1 :: a -> [a] -> ([a], a)
    unsnoc1 :: forall a. a -> [a] -> ([a], a)
unsnoc1 a
x = \case
      []   -> ([], a
x)
      a
y:[a]
ys -> ([a] -> [a]) -> ([a], a) -> ([a], a)
forall a b c. (a -> b) -> (a, c) -> (b, c)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (a
xa -> [a] -> [a]
forall a. a -> [a] -> [a]
:) (([a], a) -> ([a], a)) -> ([a], a) -> ([a], a)
forall a b. (a -> b) -> a -> b
$ a -> [a] -> ([a], a)
forall a. a -> [a] -> ([a], a)
unsnoc1 a
y [a]
ys
#endif

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 a. String -> IO a
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 :: forall a.
(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"
      , String
"-fdiagnostics-color=never"
      , String
"-fno-diagnostics-show-caret"
      ]
  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 = 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 a. a -> IO a
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 a b. (a -> b) -> IO a -> IO b
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 a. a -> IO a
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 a b. (a -> b) -> IO a -> IO b
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) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map String -> String
strip (String -> [String]
lines String
e) of
    [] -> String -> Either String String
forall a b. b -> Either a b
Right String
e
    (String
firstLine:[String]
ls) ->
      let lastLine :: String
lastLine = String
-> (([String], String) -> String)
-> Maybe ([String], String)
-> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
firstLine ([String], String) -> String
forall a b. (a, b) -> b
snd ([String] -> Maybe ([String], String)
forall a. [a] -> Maybe ([a], a)
unsnoc [String]
ls) in
      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
    fail_ :: Either String b
fail_ = String -> Either String b
forall a b. a -> Either a b
Left String
"unterminated multiline command"

    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