-- | Facilities for evaluating Futhark code.
--
-- This most directly provides the building blocks for @futhark eval@, but this
-- module also contains server interaction machinery used by @futhark repl@ and
-- other commands that make use of the Futhark interpreter.
module Futhark.Eval
  ( EvalConfig (..),
    InterpreterState,
    runExpr,
    evalConfig,
    evalServerOptions,
    runFFI,
    forceValue,
    externaliseLast,
    runInterpreterWith,
    interpretImports,
    initialiseInterpreter,
    newInterpreterState,
    Evaluation (..),
    EvalRecordRef,
    runEvalRecordRef,
  )
where

import Control.Exception (IOException, catch)
import Control.Monad (foldM, unless, void, when, (<=<))
import Control.Monad.Except (ExceptT (..), runExceptT, throwError)
import Control.Monad.Free.Church (F, runF)
import Control.Monad.IO.Class (MonadIO, liftIO)
import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.Reader (ReaderT (runReaderT), ask)
import Data.Bifunctor (first)
import Data.Either (isLeft)
import Data.IORef (IORef, modifyIORef')
import Data.Map qualified as M
import Data.Maybe (isJust, maybeToList)
import Data.Sequence (Seq, (|>))
import Data.Text qualified as T
import Futhark.Compiler (prettyWarnings, readProgramFilesExceptKnown)
import Futhark.Compiler.Program (FileModule (..), Imports, VFS, fileScope)
import Futhark.Error (badOnLeft, externalErrorS, prettyCompilerError)
import Futhark.FreshNames (VNameSource)
import Futhark.Server qualified as S
import Futhark.Test.Compile (FutharkExe (..), compileProgram, futharkServerCfg)
import Futhark.Util (showText)
import Futhark.Util.Options (ArgDescr (..), FunOptDescr, OptDescr (..))
import Futhark.Util.Pretty (commasep, hPutDoc, hPutDocLn, hardline, putDocLn)
import Language.Futhark.Core (locText)
import Language.Futhark.Interpreter qualified as I
import Language.Futhark.Interpreter.FFI.Push qualified as FFI
import Language.Futhark.Interpreter.FFI.ServerM qualified as FFI
import Language.Futhark.Parser (parseExp)
import Language.Futhark.Parser.Monad (SyntaxError (SyntaxError))
import Language.Futhark.Pretty (toName)
import Language.Futhark.Prop (UncheckedExp, typeOf)
import Language.Futhark.Semantic qualified as T
import Language.Futhark.Syntax (DecBase (LocalDec, ValDec), ProgBase (progDecs), ValBindBase (..), nameToText, typeParamName)
import Language.Futhark.TypeChecker qualified as T
import Prettyprinter (Doc, align, pretty, unAnnotate, vcat, (<+>))
import Prettyprinter.Render.Terminal (AnsiStyle)
import System.Environment (getExecutablePath)
import System.Exit (ExitCode (ExitFailure), exitWith)
import System.FilePath (dropExtension, (</>))
import System.IO (stderr)

-- | The class of monads that can perform expression evaluation.
class (Monad m) => Evaluation m where
  abort :: Doc AnsiStyle -> m b
  trace :: Doc AnsiStyle -> m ()

instance (Evaluation m) => Evaluation (ExceptT (Doc AnsiStyle) m) where
  trace :: Doc AnsiStyle -> ExceptT e m ()
  trace :: forall e. Doc AnsiStyle -> ExceptT e m ()
trace = m () -> ExceptT e m ()
forall (m :: * -> *) a. Monad m => m a -> ExceptT e m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> ExceptT e m ())
-> (Doc AnsiStyle -> m ()) -> Doc AnsiStyle -> ExceptT e m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc AnsiStyle -> m ()
forall (m :: * -> *). Evaluation m => Doc AnsiStyle -> m ()
trace

  abort :: forall b. Doc AnsiStyle -> ExceptT (Doc AnsiStyle) m b
abort = Doc AnsiStyle -> ExceptT (Doc AnsiStyle) m b
forall b. Doc AnsiStyle -> ExceptT (Doc AnsiStyle) m b
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError

instance Evaluation IO where
  abort :: forall b. Doc AnsiStyle -> IO b
abort Doc AnsiStyle
reason = do
    Handle -> Doc AnsiStyle -> IO ()
hPutDocLn Handle
stderr Doc AnsiStyle
reason
    ExitCode -> IO b
forall a. ExitCode -> IO a
exitWith (ExitCode -> IO b) -> ExitCode -> IO b
forall a b. (a -> b) -> a -> b
$ Int -> ExitCode
ExitFailure Int
1

  trace :: Doc AnsiStyle -> IO ()
trace = Doc AnsiStyle -> IO ()
putDocLn

newtype EvalRecordRef a
  = EvalRecordRef
      (ExceptT (Doc AnsiStyle) (ReaderT (IORef (Seq (Doc AnsiStyle))) IO) a)
  deriving ((forall a b. (a -> b) -> EvalRecordRef a -> EvalRecordRef b)
-> (forall a b. a -> EvalRecordRef b -> EvalRecordRef a)
-> Functor EvalRecordRef
forall a b. a -> EvalRecordRef b -> EvalRecordRef a
forall a b. (a -> b) -> EvalRecordRef a -> EvalRecordRef b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> EvalRecordRef a -> EvalRecordRef b
fmap :: forall a b. (a -> b) -> EvalRecordRef a -> EvalRecordRef b
$c<$ :: forall a b. a -> EvalRecordRef b -> EvalRecordRef a
<$ :: forall a b. a -> EvalRecordRef b -> EvalRecordRef a
Functor, Functor EvalRecordRef
Functor EvalRecordRef =>
(forall a. a -> EvalRecordRef a)
-> (forall a b.
    EvalRecordRef (a -> b) -> EvalRecordRef a -> EvalRecordRef b)
-> (forall a b c.
    (a -> b -> c)
    -> EvalRecordRef a -> EvalRecordRef b -> EvalRecordRef c)
-> (forall a b.
    EvalRecordRef a -> EvalRecordRef b -> EvalRecordRef b)
-> (forall a b.
    EvalRecordRef a -> EvalRecordRef b -> EvalRecordRef a)
-> Applicative EvalRecordRef
forall a. a -> EvalRecordRef a
forall a b. EvalRecordRef a -> EvalRecordRef b -> EvalRecordRef a
forall a b. EvalRecordRef a -> EvalRecordRef b -> EvalRecordRef b
forall a b.
EvalRecordRef (a -> b) -> EvalRecordRef a -> EvalRecordRef b
forall a b c.
(a -> b -> c)
-> EvalRecordRef a -> EvalRecordRef b -> EvalRecordRef c
forall (f :: * -> *).
Functor f =>
(forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
$cpure :: forall a. a -> EvalRecordRef a
pure :: forall a. a -> EvalRecordRef a
$c<*> :: forall a b.
EvalRecordRef (a -> b) -> EvalRecordRef a -> EvalRecordRef b
<*> :: forall a b.
EvalRecordRef (a -> b) -> EvalRecordRef a -> EvalRecordRef b
$cliftA2 :: forall a b c.
(a -> b -> c)
-> EvalRecordRef a -> EvalRecordRef b -> EvalRecordRef c
liftA2 :: forall a b c.
(a -> b -> c)
-> EvalRecordRef a -> EvalRecordRef b -> EvalRecordRef c
$c*> :: forall a b. EvalRecordRef a -> EvalRecordRef b -> EvalRecordRef b
*> :: forall a b. EvalRecordRef a -> EvalRecordRef b -> EvalRecordRef b
$c<* :: forall a b. EvalRecordRef a -> EvalRecordRef b -> EvalRecordRef a
<* :: forall a b. EvalRecordRef a -> EvalRecordRef b -> EvalRecordRef a
Applicative, Applicative EvalRecordRef
Applicative EvalRecordRef =>
(forall a b.
 EvalRecordRef a -> (a -> EvalRecordRef b) -> EvalRecordRef b)
-> (forall a b.
    EvalRecordRef a -> EvalRecordRef b -> EvalRecordRef b)
-> (forall a. a -> EvalRecordRef a)
-> Monad EvalRecordRef
forall a. a -> EvalRecordRef a
forall a b. EvalRecordRef a -> EvalRecordRef b -> EvalRecordRef b
forall a b.
EvalRecordRef a -> (a -> EvalRecordRef b) -> EvalRecordRef b
forall (m :: * -> *).
Applicative m =>
(forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
$c>>= :: forall a b.
EvalRecordRef a -> (a -> EvalRecordRef b) -> EvalRecordRef b
>>= :: forall a b.
EvalRecordRef a -> (a -> EvalRecordRef b) -> EvalRecordRef b
$c>> :: forall a b. EvalRecordRef a -> EvalRecordRef b -> EvalRecordRef b
>> :: forall a b. EvalRecordRef a -> EvalRecordRef b -> EvalRecordRef b
$creturn :: forall a. a -> EvalRecordRef a
return :: forall a. a -> EvalRecordRef a
Monad, Monad EvalRecordRef
Monad EvalRecordRef =>
(forall a. IO a -> EvalRecordRef a) -> MonadIO EvalRecordRef
forall a. IO a -> EvalRecordRef a
forall (m :: * -> *).
Monad m =>
(forall a. IO a -> m a) -> MonadIO m
$cliftIO :: forall a. IO a -> EvalRecordRef a
liftIO :: forall a. IO a -> EvalRecordRef a
MonadIO)

instance Evaluation EvalRecordRef where
  abort :: Doc AnsiStyle -> EvalRecordRef b
  abort :: forall b. Doc AnsiStyle -> EvalRecordRef b
abort = ExceptT
  (Doc AnsiStyle) (ReaderT (IORef (Seq (Doc AnsiStyle))) IO) b
-> EvalRecordRef b
forall a.
ExceptT
  (Doc AnsiStyle) (ReaderT (IORef (Seq (Doc AnsiStyle))) IO) a
-> EvalRecordRef a
EvalRecordRef (ExceptT
   (Doc AnsiStyle) (ReaderT (IORef (Seq (Doc AnsiStyle))) IO) b
 -> EvalRecordRef b)
-> (Doc AnsiStyle
    -> ExceptT
         (Doc AnsiStyle) (ReaderT (IORef (Seq (Doc AnsiStyle))) IO) b)
-> Doc AnsiStyle
-> EvalRecordRef b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc AnsiStyle
-> ExceptT
     (Doc AnsiStyle) (ReaderT (IORef (Seq (Doc AnsiStyle))) IO) b
forall a.
Doc AnsiStyle
-> ExceptT
     (Doc AnsiStyle) (ReaderT (IORef (Seq (Doc AnsiStyle))) IO) a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError

  trace :: Doc AnsiStyle -> EvalRecordRef ()
  trace :: Doc AnsiStyle -> EvalRecordRef ()
trace Doc AnsiStyle
message = ExceptT
  (Doc AnsiStyle) (ReaderT (IORef (Seq (Doc AnsiStyle))) IO) ()
-> EvalRecordRef ()
forall a.
ExceptT
  (Doc AnsiStyle) (ReaderT (IORef (Seq (Doc AnsiStyle))) IO) a
-> EvalRecordRef a
EvalRecordRef (ExceptT
   (Doc AnsiStyle) (ReaderT (IORef (Seq (Doc AnsiStyle))) IO) ()
 -> EvalRecordRef ())
-> ExceptT
     (Doc AnsiStyle) (ReaderT (IORef (Seq (Doc AnsiStyle))) IO) ()
-> EvalRecordRef ()
forall a b. (a -> b) -> a -> b
$ do
    messagesRef <- ReaderT
  (IORef (Seq (Doc AnsiStyle))) IO (IORef (Seq (Doc AnsiStyle)))
-> ExceptT
     (Doc AnsiStyle)
     (ReaderT (IORef (Seq (Doc AnsiStyle))) IO)
     (IORef (Seq (Doc AnsiStyle)))
forall (m :: * -> *) a.
Monad m =>
m a -> ExceptT (Doc AnsiStyle) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift ReaderT
  (IORef (Seq (Doc AnsiStyle))) IO (IORef (Seq (Doc AnsiStyle)))
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
    liftIO $ modifyIORef' messagesRef (|> message)

runEvalRecordRef ::
  IORef (Seq (Doc AnsiStyle)) ->
  EvalRecordRef a ->
  IO (Either (Doc AnsiStyle) a)
runEvalRecordRef :: forall a.
IORef (Seq (Doc AnsiStyle))
-> EvalRecordRef a -> IO (Either (Doc AnsiStyle) a)
runEvalRecordRef IORef (Seq (Doc AnsiStyle))
msgRef (EvalRecordRef ExceptT
  (Doc AnsiStyle) (ReaderT (IORef (Seq (Doc AnsiStyle))) IO) a
action) =
  (ReaderT
   (IORef (Seq (Doc AnsiStyle))) IO (Either (Doc AnsiStyle) a)
 -> IORef (Seq (Doc AnsiStyle)) -> IO (Either (Doc AnsiStyle) a))
-> IORef (Seq (Doc AnsiStyle))
-> ReaderT
     (IORef (Seq (Doc AnsiStyle))) IO (Either (Doc AnsiStyle) a)
-> IO (Either (Doc AnsiStyle) a)
forall a b c. (a -> b -> c) -> b -> a -> c
flip ReaderT (IORef (Seq (Doc AnsiStyle))) IO (Either (Doc AnsiStyle) a)
-> IORef (Seq (Doc AnsiStyle)) -> IO (Either (Doc AnsiStyle) a)
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT IORef (Seq (Doc AnsiStyle))
msgRef (ReaderT
   (IORef (Seq (Doc AnsiStyle))) IO (Either (Doc AnsiStyle) a)
 -> IO (Either (Doc AnsiStyle) a))
-> ReaderT
     (IORef (Seq (Doc AnsiStyle))) IO (Either (Doc AnsiStyle) a)
-> IO (Either (Doc AnsiStyle) a)
forall a b. (a -> b) -> a -> b
$ ExceptT
  (Doc AnsiStyle) (ReaderT (IORef (Seq (Doc AnsiStyle))) IO) a
-> ReaderT
     (IORef (Seq (Doc AnsiStyle))) IO (Either (Doc AnsiStyle) a)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT ExceptT
  (Doc AnsiStyle) (ReaderT (IORef (Seq (Doc AnsiStyle))) IO) a
action

newtype InterpreterState = InterpreterState (VNameSource, T.Env, I.Ctx, Maybe FFI.Server)

-- | Run an expression in the given interpreter state. The expression is parsed,
-- type checked, and then run. Returns a prettyprinted result. Must be run in a
-- monad that supports aborting and traces.
runExpr ::
  (Evaluation m, MonadIO m) =>
  InterpreterState ->
  T.Text ->
  m (Doc AnsiStyle)
runExpr :: forall (m :: * -> *).
(Evaluation m, MonadIO m) =>
InterpreterState -> Text -> m (Doc AnsiStyle)
runExpr InterpreterState
state Text
str =
  case String -> Text -> Either SyntaxError UncheckedExp
parseExp String
"" Text
str of
    Left (SyntaxError Loc
_ Text
serr) -> Doc AnsiStyle -> m (Doc AnsiStyle)
forall b. Doc AnsiStyle -> m b
forall (m :: * -> *) b. Evaluation m => Doc AnsiStyle -> m b
abort (Doc AnsiStyle -> m (Doc AnsiStyle))
-> Doc AnsiStyle -> m (Doc AnsiStyle)
forall a b. (a -> b) -> a -> b
$ Text -> Doc AnsiStyle
forall ann. Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Text
serr
    Right UncheckedExp
uexp -> InterpreterState -> UncheckedExp -> m (Doc AnsiStyle)
forall (m :: * -> *).
(Evaluation m, MonadIO m) =>
InterpreterState -> UncheckedExp -> m (Doc AnsiStyle)
runParsedExpr InterpreterState
state UncheckedExp
uexp

-- | As 'runExpr', but for an expression that has already been parsed -
-- perhaps from somewhere other than a Futhark file.
runParsedExpr ::
  (Evaluation m, MonadIO m) =>
  InterpreterState ->
  UncheckedExp ->
  m (Doc AnsiStyle)
runParsedExpr :: forall (m :: * -> *).
(Evaluation m, MonadIO m) =>
InterpreterState -> UncheckedExp -> m (Doc AnsiStyle)
runParsedExpr (InterpreterState (VNameSource
src, Env
env, Ctx
ctx, Maybe Server
s)) UncheckedExp
uexp = do
  fexp <- case Imports
-> VNameSource
-> Env
-> UncheckedExp
-> (Warnings, Either TypeError ([TypeParam], ExpBase Info VName))
T.checkExp [] VNameSource
src Env
env UncheckedExp
uexp of
    (Warnings
_, Left TypeError
terr) -> do
      Doc AnsiStyle -> m (ExpBase Info VName)
forall b. Doc AnsiStyle -> m b
forall (m :: * -> *) b. Evaluation m => Doc AnsiStyle -> m b
abort (Doc AnsiStyle -> m (ExpBase Info VName))
-> Doc AnsiStyle -> m (ExpBase Info VName)
forall a b. (a -> b) -> a -> b
$ TypeError -> Doc AnsiStyle
T.prettyTypeError TypeError
terr
    (Warnings
_, Right ([], ExpBase Info VName
e)) -> ExpBase Info VName -> m (ExpBase Info VName)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ExpBase Info VName
e
    (Warnings
_, Right ([TypeParam]
tparams, ExpBase Info VName
e)) ->
      Doc AnsiStyle -> m (ExpBase Info VName)
forall b. Doc AnsiStyle -> m b
forall (m :: * -> *) b. Evaluation m => Doc AnsiStyle -> m b
abort (Doc AnsiStyle -> m (ExpBase Info VName))
-> Doc AnsiStyle -> m (ExpBase Info VName)
forall a b. (a -> b) -> a -> b
$
        [Doc AnsiStyle] -> Doc AnsiStyle
forall ann. [Doc ann] -> Doc ann
vcat
          [ Doc AnsiStyle
"Inferred type of expression: " Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann
align (StructType -> Doc AnsiStyle
forall a ann. Pretty a => a -> Doc ann
forall ann. StructType -> Doc ann
pretty (ExpBase Info VName -> StructType
typeOf ExpBase Info VName
e)),
            Doc AnsiStyle
"The following types are ambiguous: "
              Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> [Doc AnsiStyle] -> Doc AnsiStyle
forall ann. [Doc ann] -> Doc ann
commasep ((TypeParam -> Doc AnsiStyle) -> [TypeParam] -> [Doc AnsiStyle]
forall a b. (a -> b) -> [a] -> [b]
map (Text -> Doc AnsiStyle
forall ann. Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (Text -> Doc AnsiStyle)
-> (TypeParam -> Text) -> TypeParam -> Doc AnsiStyle
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Text
nameToText (Name -> Text) -> (TypeParam -> Name) -> TypeParam -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. VName -> Name
forall v. IsName v => v -> Name
toName (VName -> Name) -> (TypeParam -> VName) -> TypeParam -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeParam -> VName
forall vn. TypeParamBase vn -> vn
typeParamName) [TypeParam]
tparams)
          ]
  pval <- runInterpreterWith trace s Nothing $ I.interpretExp ctx fexp
  case pval of
    Left InterpreterError
err -> Doc AnsiStyle -> m (Doc AnsiStyle)
forall b. Doc AnsiStyle -> m b
forall (m :: * -> *) b. Evaluation m => Doc AnsiStyle -> m b
abort (Doc AnsiStyle -> m (Doc AnsiStyle))
-> Doc AnsiStyle -> m (Doc AnsiStyle)
forall a b. (a -> b) -> a -> b
$ InterpreterError -> Doc AnsiStyle
I.prettyInterpreterError InterpreterError
err
    Right Value
val -> do
      forced <- IO (Either InterpreterError Value)
-> m (Either InterpreterError Value)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either InterpreterError Value)
 -> m (Either InterpreterError Value))
-> IO (Either InterpreterError Value)
-> m (Either InterpreterError Value)
forall a b. (a -> b) -> a -> b
$ Maybe Server -> Value -> IO (Either InterpreterError Value)
forceValue Maybe Server
s Value
val
      case forced of
        Left InterpreterError
err -> Doc AnsiStyle -> m (Doc AnsiStyle)
forall b. Doc AnsiStyle -> m b
forall (m :: * -> *) b. Evaluation m => Doc AnsiStyle -> m b
abort (Doc AnsiStyle -> m (Doc AnsiStyle))
-> Doc AnsiStyle -> m (Doc AnsiStyle)
forall a b. (a -> b) -> a -> b
$ InterpreterError -> Doc AnsiStyle
I.prettyInterpreterError InterpreterError
err
        Right Value
val' -> Doc AnsiStyle -> m (Doc AnsiStyle)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Doc AnsiStyle -> m (Doc AnsiStyle))
-> Doc AnsiStyle -> m (Doc AnsiStyle)
forall a b. (a -> b) -> a -> b
$ Value -> Doc AnsiStyle
forall (m :: * -> *) a. Value m -> Doc a
I.prettyValue Value
val' Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> Doc AnsiStyle
forall ann. Doc ann
hardline

data EvalConfig = EvalConfig
  { EvalConfig -> Bool
evalPrintWarnings :: Bool,
    EvalConfig -> Maybe String
evalFile :: Maybe String,
    -- | If @Just@, compile the file using this backend.
    EvalConfig -> Maybe String
evalBackend :: Maybe String,
    EvalConfig -> Bool
evalSkipCompilation :: Bool,
    EvalConfig -> [String]
evalExtraOptions :: [String],
    EvalConfig -> [String]
evalCompilerOptions :: [String],
    EvalConfig -> Maybe String
evalFuthark :: Maybe FilePath
  }

evalConfig :: EvalConfig
evalConfig :: EvalConfig
evalConfig =
  EvalConfig
    { evalPrintWarnings :: Bool
evalPrintWarnings = Bool
True,
      evalFile :: Maybe String
evalFile = Maybe String
forall a. Maybe a
Nothing,
      evalBackend :: Maybe String
evalBackend = Maybe String
forall a. Maybe a
Nothing,
      evalSkipCompilation :: Bool
evalSkipCompilation = Bool
False,
      evalExtraOptions :: [String]
evalExtraOptions = [],
      evalCompilerOptions :: [String]
evalCompilerOptions = [],
      evalFuthark :: Maybe String
evalFuthark = Maybe String
forall a. Maybe a
Nothing
    }

-- | Command line options for configuring the use of an external server.
evalServerOptions :: [FunOptDescr EvalConfig]
evalServerOptions :: [FunOptDescr EvalConfig]
evalServerOptions =
  [ String
-> [String]
-> ArgDescr (Either (IO ()) (EvalConfig -> EvalConfig))
-> String
-> FunOptDescr EvalConfig
forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
Option
      String
"p"
      [String
"pass-option"]
      ( (String -> Either (IO ()) (EvalConfig -> EvalConfig))
-> String -> ArgDescr (Either (IO ()) (EvalConfig -> EvalConfig))
forall a. (String -> a) -> String -> ArgDescr a
ReqArg
          ( \String
opt ->
              (EvalConfig -> EvalConfig)
-> Either (IO ()) (EvalConfig -> EvalConfig)
forall a b. b -> Either a b
Right ((EvalConfig -> EvalConfig)
 -> Either (IO ()) (EvalConfig -> EvalConfig))
-> (EvalConfig -> EvalConfig)
-> Either (IO ()) (EvalConfig -> EvalConfig)
forall a b. (a -> b) -> a -> b
$ \EvalConfig
config ->
                EvalConfig
config {evalExtraOptions = opt : evalExtraOptions config}
          )
          String
"OPT"
      )
      String
"Pass this option to programs being run.",
    String
-> [String]
-> ArgDescr (Either (IO ()) (EvalConfig -> EvalConfig))
-> String
-> FunOptDescr EvalConfig
forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
Option
      []
      [String
"pass-compiler-option"]
      ( (String -> Either (IO ()) (EvalConfig -> EvalConfig))
-> String -> ArgDescr (Either (IO ()) (EvalConfig -> EvalConfig))
forall a. (String -> a) -> String -> ArgDescr a
ReqArg
          ( \String
opt ->
              (EvalConfig -> EvalConfig)
-> Either (IO ()) (EvalConfig -> EvalConfig)
forall a b. b -> Either a b
Right ((EvalConfig -> EvalConfig)
 -> Either (IO ()) (EvalConfig -> EvalConfig))
-> (EvalConfig -> EvalConfig)
-> Either (IO ()) (EvalConfig -> EvalConfig)
forall a b. (a -> b) -> a -> b
$ \EvalConfig
config ->
                EvalConfig
config {evalCompilerOptions = opt : evalCompilerOptions config}
          )
          String
"OPT"
      )
      String
"Pass this option to the compiler.",
    String
-> [String]
-> ArgDescr (Either (IO ()) (EvalConfig -> EvalConfig))
-> String
-> FunOptDescr EvalConfig
forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
Option
      []
      [String
"skip-compilation"]
      (Either (IO ()) (EvalConfig -> EvalConfig)
-> ArgDescr (Either (IO ()) (EvalConfig -> EvalConfig))
forall a. a -> ArgDescr a
NoArg (Either (IO ()) (EvalConfig -> EvalConfig)
 -> ArgDescr (Either (IO ()) (EvalConfig -> EvalConfig)))
-> Either (IO ()) (EvalConfig -> EvalConfig)
-> ArgDescr (Either (IO ()) (EvalConfig -> EvalConfig))
forall a b. (a -> b) -> a -> b
$ (EvalConfig -> EvalConfig)
-> Either (IO ()) (EvalConfig -> EvalConfig)
forall a b. b -> Either a b
Right ((EvalConfig -> EvalConfig)
 -> Either (IO ()) (EvalConfig -> EvalConfig))
-> (EvalConfig -> EvalConfig)
-> Either (IO ()) (EvalConfig -> EvalConfig)
forall a b. (a -> b) -> a -> b
$ \EvalConfig
config -> EvalConfig
config {evalSkipCompilation = True})
      String
"Use already compiled server-mode program.",
    String
-> [String]
-> ArgDescr (Either (IO ()) (EvalConfig -> EvalConfig))
-> String
-> FunOptDescr EvalConfig
forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
Option
      []
      [String
"backend"]
      ( (String -> Either (IO ()) (EvalConfig -> EvalConfig))
-> String -> ArgDescr (Either (IO ()) (EvalConfig -> EvalConfig))
forall a. (String -> a) -> String -> ArgDescr a
ReqArg
          (\String
backend -> (EvalConfig -> EvalConfig)
-> Either (IO ()) (EvalConfig -> EvalConfig)
forall a b. b -> Either a b
Right ((EvalConfig -> EvalConfig)
 -> Either (IO ()) (EvalConfig -> EvalConfig))
-> (EvalConfig -> EvalConfig)
-> Either (IO ()) (EvalConfig -> EvalConfig)
forall a b. (a -> b) -> a -> b
$ \EvalConfig
config -> EvalConfig
config {evalBackend = Just backend})
          String
"BACKEND"
      )
      String
"The compiler backend used (defaults to interpreted)."
  ]

-- | Compile the given file and start a server for it. Returns 'Left' on error.
prepareServer :: EvalConfig -> FilePath -> String -> IO (Either T.Text FFI.Server)
prepareServer :: EvalConfig -> String -> String -> IO (Either Text Server)
prepareServer EvalConfig
cfg String
file String
backend = ExceptT Text IO Server -> IO (Either Text Server)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT Text IO Server -> IO (Either Text Server))
-> ExceptT Text IO Server -> IO (Either Text Server)
forall a b. (a -> b) -> a -> b
$ do
  futhark <- IO String -> ExceptT Text IO String
forall a. IO a -> ExceptT Text IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO String -> ExceptT Text IO String)
-> IO String -> ExceptT Text IO String
forall a b. (a -> b) -> a -> b
$ IO String -> (String -> IO String) -> Maybe String -> IO String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe IO String
getExecutablePath String -> IO String
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe String -> IO String) -> Maybe String -> IO String
forall a b. (a -> b) -> a -> b
$ EvalConfig -> Maybe String
evalFuthark EvalConfig
cfg

  unless (evalSkipCompilation cfg) $
    void $
      compileProgram ("--server" : evalCompilerOptions cfg) (FutharkExe futhark) backend file

  let server_cfg = String -> [String] -> ServerCfg
futharkServerCfg (String
"." String -> String -> String
</> String -> String
dropExtension String
file) ([String] -> ServerCfg) -> [String] -> ServerCfg
forall a b. (a -> b) -> a -> b
$ EvalConfig -> [String]
evalExtraOptions EvalConfig
cfg
  started <-
    liftIO $
      (Right <$> FFI.startServer server_cfg)
        `catch` (\(S.ServerException Text
err) -> Either Text Server -> IO (Either Text Server)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either Text Server -> IO (Either Text Server))
-> Either Text Server -> IO (Either Text Server)
forall a b. (a -> b) -> a -> b
$ Text -> Either Text Server
forall a b. a -> Either a b
Left Text
err)
        `catch` (\(IOException
err :: IOException) -> Either Text Server -> IO (Either Text Server)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either Text Server -> IO (Either Text Server))
-> Either Text Server -> IO (Either Text Server)
forall a b. (a -> b) -> a -> b
$ Text -> Either Text Server
forall a b. a -> Either a b
Left (Text -> Either Text Server) -> Text -> Either Text Server
forall a b. (a -> b) -> a -> b
$ IOException -> Text
forall a. Show a => a -> Text
showText IOException
err)
  either throwError pure started

-- | Perform an action on the server. A failure is reported as a 'Left'. Calls
-- 'error' if no server is provided.
runFFI ::
  Maybe FFI.Server ->
  FFI.ServerM I.Value ->
  IO (Either I.InterpreterError I.Value)
runFFI :: Maybe Server -> ServerM Value -> IO (Either InterpreterError Value)
runFFI Maybe Server
Nothing ServerM Value
_ = String -> IO (Either InterpreterError Value)
forall a. HasCallStack => String -> a
error String
"External call, but no server."
runFFI (Just Server
server) ServerM Value
m =
  (String -> InterpreterError)
-> Either String Value -> Either InterpreterError Value
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (Text -> InterpreterError
I.InterpreterError (Text -> InterpreterError)
-> (String -> Text) -> String -> InterpreterError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack) (Either String Value -> Either InterpreterError Value)
-> IO (Either String Value) -> IO (Either InterpreterError Value)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Server -> ServerM Value -> IO (Either String Value)
forall a. Server -> ServerM a -> IO (Either String a)
FFI.runServerM Server
server ServerM Value
m

-- | Fetch in full a value that may reside on a server, so that it can
-- be printed or otherwise inspected.
forceValue ::
  Maybe FFI.Server ->
  I.Value ->
  IO (Either I.InterpreterError I.Value)
forceValue :: Maybe Server -> Value -> IO (Either InterpreterError Value)
forceValue Maybe Server
Nothing Value
v = Either InterpreterError Value -> IO (Either InterpreterError Value)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either InterpreterError Value
 -> IO (Either InterpreterError Value))
-> Either InterpreterError Value
-> IO (Either InterpreterError Value)
forall a b. (a -> b) -> a -> b
$ Value -> Either InterpreterError Value
forall a b. b -> Either a b
Right Value
v
forceValue Maybe Server
server Value
v = Maybe Server -> ServerM Value -> IO (Either InterpreterError Value)
runFFI Maybe Server
server (ServerM Value -> IO (Either InterpreterError Value))
-> ServerM Value -> IO (Either InterpreterError Value)
forall a b. (a -> b) -> a -> b
$ Value -> ServerM Value
forall (a :: * -> *). Value a -> ServerM (Value a)
FFI.getLazy Value
v

externalise :: FileModule -> FileModule
externalise :: FileModule -> FileModule
externalise FileModule
fm = FileModule
fm {fileProg = (fileProg fm) {progDecs = map onDec $ progDecs $ fileProg fm}}
  where
    onDec :: DecBase f vn -> DecBase f vn
onDec (ValDec ValBindBase f vn
vb)
      | Maybe (f EntryPoint) -> Bool
forall a. Maybe a -> Bool
isJust (Maybe (f EntryPoint) -> Bool) -> Maybe (f EntryPoint) -> Bool
forall a b. (a -> b) -> a -> b
$ ValBindBase f vn -> Maybe (f EntryPoint)
forall (f :: * -> *) vn. ValBindBase f vn -> Maybe (f EntryPoint)
valBindEntryPoint ValBindBase f vn
vb =
          ValBindBase f vn -> DecBase f vn
forall (f :: * -> *) vn. ValBindBase f vn -> DecBase f vn
ValDec (ValBindBase f vn -> DecBase f vn)
-> ValBindBase f vn -> DecBase f vn
forall a b. (a -> b) -> a -> b
$ ValBindBase f vn
vb {valBindAttrs = "$external" : valBindAttrs vb}
    onDec (LocalDec DecBase f vn
dec SrcLoc
loc) = DecBase f vn -> SrcLoc -> DecBase f vn
forall (f :: * -> *) vn. DecBase f vn -> SrcLoc -> DecBase f vn
LocalDec (DecBase f vn -> DecBase f vn
onDec DecBase f vn
dec) SrcLoc
loc
    onDec DecBase f vn
dec = DecBase f vn
dec

-- | Mark the entry points of the last import - which is the file the
-- user actually asked us to load - as external, meaning that calls to
-- them are dispatched to a server instead of being interpreted.
externaliseLast :: Imports -> Imports
externaliseLast :: Imports -> Imports
externaliseLast [] = []
externaliseLast [(ImportName
k, FileModule
fm)] = [(ImportName
k, FileModule -> FileModule
externalise FileModule
fm)]
externaliseLast ((ImportName, FileModule)
x : Imports
xs) = (ImportName, FileModule)
x (ImportName, FileModule) -> Imports -> Imports
forall a. a -> [a] -> [a]
: Imports -> Imports
externaliseLast Imports
xs

-- | Type check and interpret the given program (if any), producing a state
-- in which expressions can be evaluated with 'runExpr'.
newInterpreterState ::
  (MonadIO m, Evaluation m) =>
  EvalConfig ->
  VFS ->
  m (Either (Doc AnsiStyle) InterpreterState)
newInterpreterState :: forall (m :: * -> *).
(MonadIO m, Evaluation m) =>
EvalConfig -> VFS -> m (Either (Doc AnsiStyle) InterpreterState)
newInterpreterState EvalConfig
cfg VFS
vfs = ExceptT (Doc AnsiStyle) m InterpreterState
-> m (Either (Doc AnsiStyle) InterpreterState)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT (Doc AnsiStyle) m InterpreterState
 -> m (Either (Doc AnsiStyle) InterpreterState))
-> ExceptT (Doc AnsiStyle) m InterpreterState
-> m (Either (Doc AnsiStyle) InterpreterState)
forall a b. (a -> b) -> a -> b
$ do
  let maybe_file :: Maybe String
maybe_file = EvalConfig -> Maybe String
evalFile EvalConfig
cfg
  (ws, imports, src) <-
    (CompilerError -> Doc AnsiStyle)
-> Either CompilerError (Warnings, Imports, VNameSource)
-> ExceptT (Doc AnsiStyle) m (Warnings, Imports, VNameSource)
forall err' (m :: * -> *) err a.
MonadError err' m =>
(err -> err') -> Either err a -> m a
badOnLeft CompilerError -> Doc AnsiStyle
prettyCompilerError
      (Either CompilerError (Warnings, Imports, VNameSource)
 -> ExceptT (Doc AnsiStyle) m (Warnings, Imports, VNameSource))
-> ExceptT
     (Doc AnsiStyle)
     m
     (Either CompilerError (Warnings, Imports, VNameSource))
-> ExceptT (Doc AnsiStyle) m (Warnings, Imports, VNameSource)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO (Either CompilerError (Warnings, Imports, VNameSource))
-> ExceptT
     (Doc AnsiStyle)
     m
     (Either CompilerError (Warnings, Imports, VNameSource))
forall a. IO a -> ExceptT (Doc AnsiStyle) m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
        ( ExceptT CompilerError IO (Warnings, Imports, VNameSource)
-> IO (Either CompilerError (Warnings, Imports, VNameSource))
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT ([Name]
-> VFS
-> [String]
-> ExceptT CompilerError IO (Warnings, Imports, VNameSource)
forall (m :: * -> *).
(MonadError CompilerError m, MonadIO m) =>
[Name] -> VFS -> [String] -> m (Warnings, Imports, VNameSource)
readProgramFilesExceptKnown [] VFS
vfs ([String]
 -> ExceptT CompilerError IO (Warnings, Imports, VNameSource))
-> [String]
-> ExceptT CompilerError IO (Warnings, Imports, VNameSource)
forall a b. (a -> b) -> a -> b
$ Maybe String -> [String]
forall a. Maybe a -> [a]
maybeToList Maybe String
maybe_file)
            IO (Either CompilerError (Warnings, Imports, VNameSource))
-> (IOException
    -> IO (Either CompilerError (Warnings, Imports, VNameSource)))
-> IO (Either CompilerError (Warnings, Imports, VNameSource))
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` \(IOException
err :: IOException) ->
              Either CompilerError (Warnings, Imports, VNameSource)
-> IO (Either CompilerError (Warnings, Imports, VNameSource))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> Either CompilerError (Warnings, Imports, VNameSource)
forall (m :: * -> *) a. MonadError CompilerError m => String -> m a
externalErrorS (IOException -> String
forall a. Show a => a -> String
show IOException
err))
        )
  when (evalPrintWarnings cfg) $
    liftIO . hPutDoc stderr $
      prettyWarnings ws

  (s, tenv, ienv) <- ExceptT $ initialiseInterpreter cfg maybe_file Nothing imports

  pure $ InterpreterState (src, tenv, ienv, s)

-- | Interpret the given imports in order with the provided interpreter runner,
-- and produce the type and interpreter environment of the last one.
interpretImports ::
  (Monad m) =>
  (F I.ExtOp I.Ctx -> m (Either I.InterpreterError I.Ctx)) ->
  Imports ->
  ExceptT (Doc AnsiStyle) m (T.Env, I.Ctx)
interpretImports :: forall (m :: * -> *).
Monad m =>
(F ExtOp Ctx -> m (Either InterpreterError Ctx))
-> Imports -> ExceptT (Doc AnsiStyle) m (Env, Ctx)
interpretImports F ExtOp Ctx -> m (Either InterpreterError Ctx)
runner Imports
imports = do
  let foldFile :: Ctx -> (ImportName, ProgBase Info VName) -> t m Ctx
foldFile Ctx
ctx =
        (InterpreterError -> Doc AnsiStyle)
-> Either InterpreterError Ctx -> t m Ctx
forall err' (m :: * -> *) err a.
MonadError err' m =>
(err -> err') -> Either err a -> m a
badOnLeft InterpreterError -> Doc AnsiStyle
I.prettyInterpreterError
          (Either InterpreterError Ctx -> t m Ctx)
-> ((ImportName, ProgBase Info VName)
    -> t m (Either InterpreterError Ctx))
-> (ImportName, ProgBase Info VName)
-> t m Ctx
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< m (Either InterpreterError Ctx)
-> t m (Either InterpreterError Ctx)
forall (m :: * -> *) a. Monad m => m a -> t m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (Either InterpreterError Ctx)
 -> t m (Either InterpreterError Ctx))
-> ((ImportName, ProgBase Info VName)
    -> m (Either InterpreterError Ctx))
-> (ImportName, ProgBase Info VName)
-> t m (Either InterpreterError Ctx)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. F ExtOp Ctx -> m (Either InterpreterError Ctx)
runner (F ExtOp Ctx -> m (Either InterpreterError Ctx))
-> ((ImportName, ProgBase Info VName) -> F ExtOp Ctx)
-> (ImportName, ProgBase Info VName)
-> m (Either InterpreterError Ctx)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ctx -> (ImportName, ProgBase Info VName) -> F ExtOp Ctx
I.interpretImport Ctx
ctx
  ictx <- (Ctx
 -> (ImportName, ProgBase Info VName)
 -> ExceptT (Doc AnsiStyle) m Ctx)
-> Ctx
-> [(ImportName, ProgBase Info VName)]
-> ExceptT (Doc AnsiStyle) m Ctx
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM Ctx
-> (ImportName, ProgBase Info VName)
-> ExceptT (Doc AnsiStyle) m Ctx
forall {t :: (* -> *) -> * -> *}.
(MonadError (Doc AnsiStyle) (t m), MonadTrans t) =>
Ctx -> (ImportName, ProgBase Info VName) -> t m Ctx
foldFile Ctx
I.initialCtx ([(ImportName, ProgBase Info VName)]
 -> ExceptT (Doc AnsiStyle) m Ctx)
-> [(ImportName, ProgBase Info VName)]
-> ExceptT (Doc AnsiStyle) m Ctx
forall a b. (a -> b) -> a -> b
$ ((ImportName, FileModule) -> (ImportName, ProgBase Info VName))
-> Imports -> [(ImportName, ProgBase Info VName)]
forall a b. (a -> b) -> [a] -> [b]
map ((FileModule -> ProgBase Info VName)
-> (ImportName, FileModule) -> (ImportName, ProgBase Info VName)
forall a b. (a -> b) -> (ImportName, a) -> (ImportName, b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FileModule -> ProgBase Info VName
fileProg) Imports
imports
  let (iname, fm) = last imports
  pure (fileScope fm, ictx {I.ctxEnv = I.ctxImports ictx M.! iname})

-- | Set up an interpreter context for the given program. If a server is
-- provided, or a backend has been requested (in which case a server is
-- started), then the entry points of the loaded file are marked external, such
-- that calls to them are dispatched to the server instead of being interpreted.
-- On failure, a server started here is shut down again, so a returned server is
-- always one that the caller now owns (and must eventually stop). A server
-- passed in by the caller is never shut down here.
initialiseInterpreter ::
  (Evaluation m, MonadIO m) =>
  EvalConfig ->
  Maybe FilePath ->
  Maybe FFI.Server ->
  Imports ->
  m (Either (Doc AnsiStyle) (Maybe FFI.Server, T.Env, I.Ctx))
initialiseInterpreter :: forall (m :: * -> *).
(Evaluation m, MonadIO m) =>
EvalConfig
-> Maybe String
-> Maybe Server
-> Imports
-> m (Either (Doc AnsiStyle) (Maybe Server, Env, Ctx))
initialiseInterpreter EvalConfig
cfg Maybe String
maybe_file Maybe Server
server Imports
imports =
  case (Maybe Server
server, Maybe String
maybe_file, EvalConfig -> Maybe String
evalBackend EvalConfig
cfg) of
    (Just Server
s, Maybe String
_, Maybe String
_) ->
      Maybe Server
-> Imports -> m (Either (Doc AnsiStyle) (Maybe Server, Env, Ctx))
forall {m :: * -> *}.
(MonadIO m, Evaluation m) =>
Maybe Server
-> Imports -> m (Either (Doc AnsiStyle) (Maybe Server, Env, Ctx))
evalWith (Server -> Maybe Server
forall a. a -> Maybe a
Just Server
s) (Imports -> m (Either (Doc AnsiStyle) (Maybe Server, Env, Ctx)))
-> Imports -> m (Either (Doc AnsiStyle) (Maybe Server, Env, Ctx))
forall a b. (a -> b) -> a -> b
$ Imports -> Imports
externaliseLast Imports
imports
    (Maybe Server
Nothing, Just String
file, Just String
backend) -> do
      started <- IO (Either Text Server) -> m (Either Text Server)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either Text Server) -> m (Either Text Server))
-> IO (Either Text Server) -> m (Either Text Server)
forall a b. (a -> b) -> a -> b
$ EvalConfig -> String -> String -> IO (Either Text Server)
prepareServer EvalConfig
cfg String
file String
backend
      case started of
        Left Text
err -> Either (Doc AnsiStyle) (Maybe Server, Env, Ctx)
-> m (Either (Doc AnsiStyle) (Maybe Server, Env, Ctx))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either (Doc AnsiStyle) (Maybe Server, Env, Ctx)
 -> m (Either (Doc AnsiStyle) (Maybe Server, Env, Ctx)))
-> Either (Doc AnsiStyle) (Maybe Server, Env, Ctx)
-> m (Either (Doc AnsiStyle) (Maybe Server, Env, Ctx))
forall a b. (a -> b) -> a -> b
$ Doc AnsiStyle -> Either (Doc AnsiStyle) (Maybe Server, Env, Ctx)
forall a b. a -> Either a b
Left (Doc AnsiStyle -> Either (Doc AnsiStyle) (Maybe Server, Env, Ctx))
-> Doc AnsiStyle -> Either (Doc AnsiStyle) (Maybe Server, Env, Ctx)
forall a b. (a -> b) -> a -> b
$ Text -> Doc AnsiStyle
forall ann. Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Text
err
        Right Server
s -> do
          r <- Maybe Server
-> Imports -> m (Either (Doc AnsiStyle) (Maybe Server, Env, Ctx))
forall {m :: * -> *}.
(MonadIO m, Evaluation m) =>
Maybe Server
-> Imports -> m (Either (Doc AnsiStyle) (Maybe Server, Env, Ctx))
evalWith (Server -> Maybe Server
forall a. a -> Maybe a
Just Server
s) (Imports -> m (Either (Doc AnsiStyle) (Maybe Server, Env, Ctx)))
-> Imports -> m (Either (Doc AnsiStyle) (Maybe Server, Env, Ctx))
forall a b. (a -> b) -> a -> b
$ Imports -> Imports
externaliseLast Imports
imports
          -- Do not leave a server running if we never got off the ground.
          when (isLeft r) $ void $ liftIO $ FFI.stopServer s
          pure r
    (Maybe Server, Maybe String, Maybe String)
_ -> Maybe Server
-> Imports -> m (Either (Doc AnsiStyle) (Maybe Server, Env, Ctx))
forall {m :: * -> *}.
(MonadIO m, Evaluation m) =>
Maybe Server
-> Imports -> m (Either (Doc AnsiStyle) (Maybe Server, Env, Ctx))
evalWith Maybe Server
forall a. Maybe a
Nothing Imports
imports
  where
    evalWith :: Maybe Server
-> Imports -> m (Either (Doc AnsiStyle) (Maybe Server, Env, Ctx))
evalWith Maybe Server
s =
      ExceptT (Doc AnsiStyle) m (Maybe Server, Env, Ctx)
-> m (Either (Doc AnsiStyle) (Maybe Server, Env, Ctx))
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT
        (ExceptT (Doc AnsiStyle) m (Maybe Server, Env, Ctx)
 -> m (Either (Doc AnsiStyle) (Maybe Server, Env, Ctx)))
-> (Imports -> ExceptT (Doc AnsiStyle) m (Maybe Server, Env, Ctx))
-> Imports
-> m (Either (Doc AnsiStyle) (Maybe Server, Env, Ctx))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Env, Ctx) -> (Maybe Server, Env, Ctx))
-> ExceptT (Doc AnsiStyle) m (Env, Ctx)
-> ExceptT (Doc AnsiStyle) m (Maybe Server, Env, Ctx)
forall a b.
(a -> b)
-> ExceptT (Doc AnsiStyle) m a -> ExceptT (Doc AnsiStyle) m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(Env
tenv, Ctx
ienv) -> (Maybe Server
s, Env
tenv, Ctx
ienv))
        (ExceptT (Doc AnsiStyle) m (Env, Ctx)
 -> ExceptT (Doc AnsiStyle) m (Maybe Server, Env, Ctx))
-> (Imports -> ExceptT (Doc AnsiStyle) m (Env, Ctx))
-> Imports
-> ExceptT (Doc AnsiStyle) m (Maybe Server, Env, Ctx)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (F ExtOp Ctx -> m (Either InterpreterError Ctx))
-> Imports -> ExceptT (Doc AnsiStyle) m (Env, Ctx)
forall (m :: * -> *).
Monad m =>
(F ExtOp Ctx -> m (Either InterpreterError Ctx))
-> Imports -> ExceptT (Doc AnsiStyle) m (Env, Ctx)
interpretImports ((Doc AnsiStyle -> m ())
-> Maybe Server
-> Maybe String
-> F ExtOp Ctx
-> m (Either InterpreterError Ctx)
forall (m :: * -> *) a.
MonadIO m =>
(Doc AnsiStyle -> m ())
-> Maybe Server
-> Maybe String
-> F ExtOp a
-> m (Either InterpreterError a)
runInterpreterWith Doc AnsiStyle -> m ()
forall (m :: * -> *). Evaluation m => Doc AnsiStyle -> m ()
trace Maybe Server
s Maybe String
forall a. Maybe a
Nothing)

-- | Run an interpreter action non-interactively. Breakpoints are ignored, as
-- there is no way to enter a debugging prompt. Traces, and the breakpoints
-- that are ignored, are reported with the given function. External calls are
-- dispatched to the given server (if any). Relative paths in IO operations are
-- resolved relative to the given directory, if any, and otherwise relative to
-- the working directory.
runInterpreterWith ::
  (MonadIO m) =>
  (Doc AnsiStyle -> m ()) ->
  Maybe FFI.Server ->
  Maybe FilePath ->
  F I.ExtOp a ->
  m (Either I.InterpreterError a)
runInterpreterWith :: forall (m :: * -> *) a.
MonadIO m =>
(Doc AnsiStyle -> m ())
-> Maybe Server
-> Maybe String
-> F ExtOp a
-> m (Either InterpreterError a)
runInterpreterWith Doc AnsiStyle -> m ()
report Maybe Server
s Maybe String
dir F ExtOp a
m = F ExtOp a -> forall r. (a -> r) -> (ExtOp r -> r) -> r
forall (f :: * -> *) a.
F f a -> forall r. (a -> r) -> (f r -> r) -> r
runF F ExtOp a
m (Either InterpreterError a -> m (Either InterpreterError a)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either InterpreterError a -> m (Either InterpreterError a))
-> (a -> Either InterpreterError a)
-> a
-> m (Either InterpreterError a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Either InterpreterError a
forall a b. b -> Either a b
Right) ExtOp (m (Either InterpreterError a))
-> m (Either InterpreterError a)
forall {b}.
ExtOp (m (Either InterpreterError b))
-> m (Either InterpreterError b)
intOp
  where
    intOp :: ExtOp (m (Either InterpreterError b))
-> m (Either InterpreterError b)
intOp (I.ExtOpError InterpreterError
err) = Either InterpreterError b -> m (Either InterpreterError b)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either InterpreterError b -> m (Either InterpreterError b))
-> Either InterpreterError b -> m (Either InterpreterError b)
forall a b. (a -> b) -> a -> b
$ InterpreterError -> Either InterpreterError b
forall a b. a -> Either a b
Left InterpreterError
err
    intOp (I.ExtOpTrace Text
w Doc ()
v m (Either InterpreterError b)
c) = do
      Doc AnsiStyle -> m ()
report (Doc AnsiStyle -> m ()) -> Doc AnsiStyle -> m ()
forall a b. (a -> b) -> a -> b
$ Text -> Doc AnsiStyle
forall ann. Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Text
w Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> Doc AnsiStyle
":" Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann
align (Doc () -> Doc AnsiStyle
forall ann xxx. Doc ann -> Doc xxx
unAnnotate Doc ()
v)
      m (Either InterpreterError b)
c
    intOp (I.ExtOpBreak Loc
_ BreakReason
I.BreakNaN NonEmpty StackFrame
_ m (Either InterpreterError b)
c) = m (Either InterpreterError b)
c
    intOp (I.ExtOpBreak Loc
w BreakReason
_ NonEmpty StackFrame
_ m (Either InterpreterError b)
c) = do
      Doc AnsiStyle -> m ()
report (Doc AnsiStyle -> m ()) -> Doc AnsiStyle -> m ()
forall a b. (a -> b) -> a -> b
$ Text -> Doc AnsiStyle
forall ann. Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (Loc -> Text
forall a. Located a => a -> Text
locText Loc
w) Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> Doc AnsiStyle
": ignoring breakpoint."
      m (Either InterpreterError b)
c
    intOp (I.ExtOpFFI ServerM Value
sm Value -> m (Either InterpreterError b)
c) = (InterpreterError -> m (Either InterpreterError b))
-> (Value -> m (Either InterpreterError b))
-> Either InterpreterError Value
-> m (Either InterpreterError b)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Either InterpreterError b -> m (Either InterpreterError b)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either InterpreterError b -> m (Either InterpreterError b))
-> (InterpreterError -> Either InterpreterError b)
-> InterpreterError
-> m (Either InterpreterError b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. InterpreterError -> Either InterpreterError b
forall a b. a -> Either a b
Left) Value -> m (Either InterpreterError b)
c (Either InterpreterError Value -> m (Either InterpreterError b))
-> m (Either InterpreterError Value)
-> m (Either InterpreterError b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO (Either InterpreterError Value)
-> m (Either InterpreterError Value)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Maybe Server -> ServerM Value -> IO (Either InterpreterError Value)
runFFI Maybe Server
s ServerM Value
sm)
    intOp (I.ExtOpIO IOOp
op Value -> m (Either InterpreterError b)
c) =
      (Text -> m (Either InterpreterError b))
-> (Value -> m (Either InterpreterError b))
-> Either Text Value
-> m (Either InterpreterError b)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Either InterpreterError b -> m (Either InterpreterError b)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either InterpreterError b -> m (Either InterpreterError b))
-> (Text -> Either InterpreterError b)
-> Text
-> m (Either InterpreterError b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. InterpreterError -> Either InterpreterError b
forall a b. a -> Either a b
Left (InterpreterError -> Either InterpreterError b)
-> (Text -> InterpreterError) -> Text -> Either InterpreterError b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> InterpreterError
I.InterpreterError) Value -> m (Either InterpreterError b)
c
        (Either Text Value -> m (Either InterpreterError b))
-> m (Either Text Value) -> m (Either InterpreterError b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO (Either Text Value) -> m (Either Text Value)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Maybe Server -> IOOp -> IO (Either Text Value)
forall (m :: * -> *).
Maybe Server -> IOOp -> IO (Either Text (Value m))
I.doIOOp Maybe Server
s ((IOOp -> IOOp)
-> (String -> IOOp -> IOOp) -> Maybe String -> IOOp -> IOOp
forall b a. b -> (a -> b) -> Maybe a -> b
maybe IOOp -> IOOp
forall a. a -> a
id String -> IOOp -> IOOp
I.ioRelativeTo Maybe String
dir IOOp
op))