{-# LANGUAGE CPP #-}
module Interpreter (
  Interpreter
, safeEval
, safeEvalIt
, withInterpreter
, ghc
, interpreterSupported

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

import           Imports

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

import           Language.Haskell.GhciWrapper

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

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

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

withInterpreter
  :: (String, [String])
  -> (Interpreter -> IO a)  -- ^ Action to run
  -> IO a                   -- ^ Result of action
withInterpreter :: forall a. (String, [String]) -> (Interpreter -> IO a) -> IO a
withInterpreter (String
command, [String]
flags) Interpreter -> IO a
action = do
  let
    args :: [String]
args = [String]
flags forall a. [a] -> [a] -> [a]
++ [
        String
xTemplateHaskell
#if __GLASGOW_HASKELL__ >= 802
      , String
"-fdiagnostics-color=never"
      , String
"-fno-diagnostics-show-caret"
#endif
      ]
  forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket (Config -> [String] -> IO Interpreter
new Config
defaultConfig{configGhci :: String
configGhci = String
command} [String]
args) Interpreter -> IO ()
close Interpreter -> IO a
action

xTemplateHaskell :: String
xTemplateHaskell :: String
xTemplateHaskell = String
"-XTemplateHaskell"

-- | 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 = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> Either a b
Left) (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. b -> Either a b
Right forall b c a. (b -> c) -> (a -> b) -> a -> c
. Interpreter -> String -> IO String
eval Interpreter
repl) 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 = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> Either a b
Left) (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. b -> Either a b
Right forall b c a. (b -> c) -> (a -> b) -> a -> c
. Interpreter -> String -> IO String
evalIt Interpreter
repl) 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
    [] -> forall a b. b -> Either a b
Right String
e
    [String]
l  -> if String
firstLine forall a. Eq a => a -> a -> Bool
== String
":{" Bool -> Bool -> Bool
&& String
lastLine forall a. Eq a => a -> a -> Bool
/= String
":}" then forall {b}. Either String b
err else forall a b. b -> Either a b
Right (String -> String
filterXTemplateHaskell String
e)
      where
        firstLine :: String
firstLine = String -> String
strip forall a b. (a -> b) -> a -> b
$ forall a. [a] -> a
head [String]
l
        lastLine :: String
lastLine  = String -> String
strip forall a b. (a -> b) -> a -> b
$ forall a. [a] -> a
last [String]
l
        err :: Either String b
err = forall a b. a -> Either a b
Left String
"unterminated multi-line command"
  where
    strip :: String -> String
    strip :: String -> String
strip = forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> [a]
reverse forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> [a]
reverse

filterXTemplateHaskell :: String -> String
filterXTemplateHaskell :: String -> String
filterXTemplateHaskell String
input = case String -> [String]
words String
input of
  [String
":set", String
setting] | String
setting forall a. Eq a => a -> a -> Bool
== String
xTemplateHaskell -> String
""
  String
":set" : [String]
xs | String
xTemplateHaskell forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
xs -> [String] -> String
unwords forall a b. (a -> b) -> a -> b
$ String
":set" forall a. a -> [a] -> [a]
: forall a. (a -> Bool) -> [a] -> [a]
filter (forall a. Eq a => a -> a -> Bool
/= String
xTemplateHaskell) [String]
xs
  [String]
_ -> String
input