{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}

-- | @futhark run@
module Futhark.CLI.Run (main) where

import Control.Exception
import Control.Monad
import Control.Monad.Except
import Control.Monad.Free.Church
import qualified Data.Map as M
import Data.Maybe
import qualified Data.Text.IO as T
import Futhark.Compiler
import Futhark.Pipeline
import Futhark.Util (toPOSIX)
import Futhark.Util.Options
import Language.Futhark
import qualified Language.Futhark.Interpreter as I
import Language.Futhark.Parser hiding (EOF)
import qualified Language.Futhark.Semantic as T
import qualified Language.Futhark.TypeChecker as T
import System.Exit
import System.FilePath
import System.IO
import Prelude

-- | Run @futhark run@.
main :: String -> [String] -> IO ()
main :: String -> [String] -> IO ()
main = InterpreterConfig
-> [FunOptDescr InterpreterConfig]
-> String
-> ([String] -> InterpreterConfig -> Maybe (IO ()))
-> String
-> [String]
-> IO ()
forall cfg.
cfg
-> [FunOptDescr cfg]
-> String
-> ([String] -> cfg -> Maybe (IO ()))
-> String
-> [String]
-> IO ()
mainWithOptions InterpreterConfig
interpreterConfig [FunOptDescr InterpreterConfig]
options String
"options... <program.fut>" [String] -> InterpreterConfig -> Maybe (IO ())
run
  where
    run :: [String] -> InterpreterConfig -> Maybe (IO ())
run [String
prog] InterpreterConfig
config = IO () -> Maybe (IO ())
forall a. a -> Maybe a
Just (IO () -> Maybe (IO ())) -> IO () -> Maybe (IO ())
forall a b. (a -> b) -> a -> b
$ InterpreterConfig -> String -> IO ()
interpret InterpreterConfig
config String
prog
    run [String]
_ InterpreterConfig
_ = Maybe (IO ())
forall a. Maybe a
Nothing

interpret :: InterpreterConfig -> FilePath -> IO ()
interpret :: InterpreterConfig -> String -> IO ()
interpret InterpreterConfig
config String
fp = do
  Either String (Env, Ctx)
pr <- InterpreterConfig -> String -> IO (Either String (Env, Ctx))
newFutharkiState InterpreterConfig
config String
fp
  (Env
tenv, Ctx
ienv) <- case Either String (Env, Ctx)
pr of
    Left String
err -> do
      Handle -> String -> IO ()
hPutStrLn Handle
stderr String
err
      IO (Env, Ctx)
forall a. IO a
exitFailure
    Right (Env, Ctx)
env -> (Env, Ctx) -> IO (Env, Ctx)
forall (m :: * -> *) a. Monad m => a -> m a
return (Env, Ctx)
env

  let entry :: Name
entry = InterpreterConfig -> Name
interpreterEntryPoint InterpreterConfig
config
  Either ParseError [Value]
vr <- String -> Text -> Either ParseError [Value]
parseValues String
"stdin" (Text -> Either ParseError [Value])
-> IO Text -> IO (Either ParseError [Value])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO Text
T.getContents

  [Value]
inps <-
    case Either ParseError [Value]
vr of
      Left ParseError
err -> do
        Handle -> String -> IO ()
hPutStrLn Handle
stderr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Error when reading input: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ParseError -> String
forall a. Show a => a -> String
show ParseError
err
        IO [Value]
forall a. IO a
exitFailure
      Right [Value]
vs ->
        [Value] -> IO [Value]
forall (m :: * -> *) a. Monad m => a -> m a
return [Value]
vs

  (QualName VName
fname, TypeBase () ()
ret) <-
    case (Namespace, Name)
-> Map (Namespace, Name) (QualName VName) -> Maybe (QualName VName)
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (Namespace
T.Term, Name
entry) (Map (Namespace, Name) (QualName VName) -> Maybe (QualName VName))
-> Map (Namespace, Name) (QualName VName) -> Maybe (QualName VName)
forall a b. (a -> b) -> a -> b
$ Env -> Map (Namespace, Name) (QualName VName)
T.envNameMap Env
tenv of
      Just QualName VName
fname
        | Just (T.BoundV [TypeParam]
_ StructType
t) <- VName -> Map VName BoundV -> Maybe BoundV
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (QualName VName -> VName
forall vn. QualName vn -> vn
qualLeaf QualName VName
fname) (Map VName BoundV -> Maybe BoundV)
-> Map VName BoundV -> Maybe BoundV
forall a b. (a -> b) -> a -> b
$ Env -> Map VName BoundV
T.envVtable Env
tenv ->
          (QualName VName, TypeBase () ())
-> IO (QualName VName, TypeBase () ())
forall (m :: * -> *) a. Monad m => a -> m a
return (QualName VName
fname, StructType -> TypeBase () ()
forall dim as. TypeBase dim as -> TypeBase () ()
toStructural (StructType -> TypeBase () ()) -> StructType -> TypeBase () ()
forall a b. (a -> b) -> a -> b
$ ([StructType], StructType) -> StructType
forall a b. (a, b) -> b
snd (([StructType], StructType) -> StructType)
-> ([StructType], StructType) -> StructType
forall a b. (a -> b) -> a -> b
$ StructType -> ([StructType], StructType)
forall dim as.
TypeBase dim as -> ([TypeBase dim as], TypeBase dim as)
unfoldFunType StructType
t)
      Maybe (QualName VName)
_ -> do
        Handle -> String -> IO ()
hPutStrLn Handle
stderr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Invalid entry point: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
forall a. Pretty a => a -> String
pretty Name
entry
        IO (QualName VName, TypeBase () ())
forall a. IO a
exitFailure

  case Ctx -> VName -> [Value] -> Either String (F ExtOp Value)
I.interpretFunction Ctx
ienv (QualName VName -> VName
forall vn. QualName vn -> vn
qualLeaf QualName VName
fname) [Value]
inps of
    Left String
err -> do
      Handle -> String -> IO ()
hPutStrLn Handle
stderr String
err
      IO ()
forall a. IO a
exitFailure
    Right F ExtOp Value
run -> do
      Either InterpreterError Value
run' <- F ExtOp Value -> IO (Either InterpreterError Value)
forall (m :: * -> *) a.
MonadIO m =>
F ExtOp a -> m (Either InterpreterError a)
runInterpreter' F ExtOp Value
run
      case Either InterpreterError Value
run' of
        Left InterpreterError
err -> do
          Handle -> InterpreterError -> IO ()
forall a. Show a => Handle -> a -> IO ()
hPrint Handle
stderr InterpreterError
err
          IO ()
forall a. IO a
exitFailure
        Right Value
res ->
          case (Value -> Maybe [Value]
I.fromTuple Value
res, TypeBase () () -> Maybe [TypeBase () ()]
forall dim as. TypeBase dim as -> Maybe [TypeBase dim as]
isTupleRecord TypeBase () ()
ret) of
            (Just [Value]
vs, Just [TypeBase () ()]
ts) -> (Value -> TypeBase () () -> IO ())
-> [Value] -> [TypeBase () ()] -> IO ()
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m ()
zipWithM_ Value -> TypeBase () () -> IO ()
putValue [Value]
vs [TypeBase () ()]
ts
            (Maybe [Value], Maybe [TypeBase () ()])
_ -> Value -> TypeBase () () -> IO ()
putValue Value
res TypeBase () ()
ret

putValue :: I.Value -> TypeBase () () -> IO ()
putValue :: Value -> TypeBase () () -> IO ()
putValue Value
v TypeBase () ()
t
  | Value -> Bool
I.isEmptyArray Value
v = String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ TypeBase () () -> Value -> String
I.prettyEmptyArray TypeBase () ()
t Value
v
  | Bool
otherwise = String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ Value -> String
forall a. Pretty a => a -> String
pretty Value
v

data InterpreterConfig = InterpreterConfig
  { InterpreterConfig -> Name
interpreterEntryPoint :: Name,
    InterpreterConfig -> Bool
interpreterPrintWarnings :: Bool
  }

interpreterConfig :: InterpreterConfig
interpreterConfig :: InterpreterConfig
interpreterConfig = Name -> Bool -> InterpreterConfig
InterpreterConfig Name
defaultEntryPoint Bool
True

options :: [FunOptDescr InterpreterConfig]
options :: [FunOptDescr InterpreterConfig]
options =
  [ String
-> [String]
-> ArgDescr
     (Either (IO ()) (InterpreterConfig -> InterpreterConfig))
-> String
-> FunOptDescr InterpreterConfig
forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
Option
      String
"e"
      [String
"entry-point"]
      ( (String -> Either (IO ()) (InterpreterConfig -> InterpreterConfig))
-> String
-> ArgDescr
     (Either (IO ()) (InterpreterConfig -> InterpreterConfig))
forall a. (String -> a) -> String -> ArgDescr a
ReqArg
          ( \String
entry -> (InterpreterConfig -> InterpreterConfig)
-> Either (IO ()) (InterpreterConfig -> InterpreterConfig)
forall a b. b -> Either a b
Right ((InterpreterConfig -> InterpreterConfig)
 -> Either (IO ()) (InterpreterConfig -> InterpreterConfig))
-> (InterpreterConfig -> InterpreterConfig)
-> Either (IO ()) (InterpreterConfig -> InterpreterConfig)
forall a b. (a -> b) -> a -> b
$ \InterpreterConfig
config ->
              InterpreterConfig
config {interpreterEntryPoint :: Name
interpreterEntryPoint = String -> Name
nameFromString String
entry}
          )
          String
"NAME"
      )
      String
"The entry point to execute.",
    String
-> [String]
-> ArgDescr
     (Either (IO ()) (InterpreterConfig -> InterpreterConfig))
-> String
-> FunOptDescr InterpreterConfig
forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
Option
      String
"w"
      [String
"no-warnings"]
      (Either (IO ()) (InterpreterConfig -> InterpreterConfig)
-> ArgDescr
     (Either (IO ()) (InterpreterConfig -> InterpreterConfig))
forall a. a -> ArgDescr a
NoArg (Either (IO ()) (InterpreterConfig -> InterpreterConfig)
 -> ArgDescr
      (Either (IO ()) (InterpreterConfig -> InterpreterConfig)))
-> Either (IO ()) (InterpreterConfig -> InterpreterConfig)
-> ArgDescr
     (Either (IO ()) (InterpreterConfig -> InterpreterConfig))
forall a b. (a -> b) -> a -> b
$ (InterpreterConfig -> InterpreterConfig)
-> Either (IO ()) (InterpreterConfig -> InterpreterConfig)
forall a b. b -> Either a b
Right ((InterpreterConfig -> InterpreterConfig)
 -> Either (IO ()) (InterpreterConfig -> InterpreterConfig))
-> (InterpreterConfig -> InterpreterConfig)
-> Either (IO ()) (InterpreterConfig -> InterpreterConfig)
forall a b. (a -> b) -> a -> b
$ \InterpreterConfig
config -> InterpreterConfig
config {interpreterPrintWarnings :: Bool
interpreterPrintWarnings = Bool
False})
      String
"Do not print warnings."
  ]

newFutharkiState ::
  InterpreterConfig ->
  FilePath ->
  IO (Either String (T.Env, I.Ctx))
newFutharkiState :: InterpreterConfig -> String -> IO (Either String (Env, Ctx))
newFutharkiState InterpreterConfig
cfg String
file = ExceptT String IO (Env, Ctx) -> IO (Either String (Env, Ctx))
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT String IO (Env, Ctx) -> IO (Either String (Env, Ctx)))
-> ExceptT String IO (Env, Ctx) -> IO (Either String (Env, Ctx))
forall a b. (a -> b) -> a -> b
$ do
  (Warnings
ws, Imports
imports, VNameSource
src) <-
    (CompilerError -> String)
-> Either CompilerError (Warnings, Imports, VNameSource)
-> ExceptT String IO (Warnings, Imports, VNameSource)
forall err a.
(err -> String) -> Either err a -> ExceptT String IO a
badOnLeft CompilerError -> String
forall a. Show a => a -> String
show
      (Either CompilerError (Warnings, Imports, VNameSource)
 -> ExceptT String IO (Warnings, Imports, VNameSource))
-> ExceptT
     String IO (Either CompilerError (Warnings, Imports, VNameSource))
-> ExceptT String IO (Warnings, Imports, VNameSource)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO (Either CompilerError (Warnings, Imports, VNameSource))
-> ExceptT
     String IO (Either CompilerError (Warnings, Imports, VNameSource))
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]
-> String
-> ExceptT CompilerError IO (Warnings, Imports, VNameSource)
forall (m :: * -> *).
(MonadError CompilerError m, MonadIO m) =>
[Name] -> String -> m (Warnings, Imports, VNameSource)
readProgram [] String
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 (m :: * -> *) a. Monad m => a -> m a
return (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))
        )
  Bool -> ExceptT String IO () -> ExceptT String IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (InterpreterConfig -> Bool
interpreterPrintWarnings InterpreterConfig
cfg) (ExceptT String IO () -> ExceptT String IO ())
-> ExceptT String IO () -> ExceptT String IO ()
forall a b. (a -> b) -> a -> b
$
    IO () -> ExceptT String IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT String IO ()) -> IO () -> ExceptT String IO ()
forall a b. (a -> b) -> a -> b
$ Handle -> String -> IO ()
hPutStr Handle
stderr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ Warnings -> String
forall a. Pretty a => a -> String
pretty Warnings
ws

  let imp :: ImportName
imp = String -> ImportName
T.mkInitialImport String
"."
  Ctx
ienv1 <-
    (Ctx -> (String, Prog) -> ExceptT String IO Ctx)
-> Ctx -> [(String, Prog)] -> ExceptT String IO Ctx
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (\Ctx
ctx -> (InterpreterError -> String)
-> Either InterpreterError Ctx -> ExceptT String IO Ctx
forall err a.
(err -> String) -> Either err a -> ExceptT String IO a
badOnLeft InterpreterError -> String
forall a. Show a => a -> String
show (Either InterpreterError Ctx -> ExceptT String IO Ctx)
-> ((String, Prog)
    -> ExceptT String IO (Either InterpreterError Ctx))
-> (String, Prog)
-> ExceptT String IO Ctx
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< F ExtOp Ctx -> ExceptT String IO (Either InterpreterError Ctx)
forall (m :: * -> *) a.
MonadIO m =>
F ExtOp a -> m (Either InterpreterError a)
runInterpreter' (F ExtOp Ctx -> ExceptT String IO (Either InterpreterError Ctx))
-> ((String, Prog) -> F ExtOp Ctx)
-> (String, Prog)
-> ExceptT String IO (Either InterpreterError Ctx)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ctx -> (String, Prog) -> F ExtOp Ctx
I.interpretImport Ctx
ctx) Ctx
I.initialCtx ([(String, Prog)] -> ExceptT String IO Ctx)
-> [(String, Prog)] -> ExceptT String IO Ctx
forall a b. (a -> b) -> a -> b
$
      ((String, FileModule) -> (String, Prog))
-> Imports -> [(String, Prog)]
forall a b. (a -> b) -> [a] -> [b]
map ((FileModule -> Prog) -> (String, FileModule) -> (String, Prog)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FileModule -> Prog
fileProg) Imports
imports
  (Env
tenv1, Dec
d1, VNameSource
src') <-
    (TypeError -> String)
-> Either TypeError (Env, Dec, VNameSource)
-> ExceptT String IO (Env, Dec, VNameSource)
forall err a.
(err -> String) -> Either err a -> ExceptT String IO a
badOnLeft TypeError -> String
forall a. Pretty a => a -> String
pretty (Either TypeError (Env, Dec, VNameSource)
 -> ExceptT String IO (Env, Dec, VNameSource))
-> Either TypeError (Env, Dec, VNameSource)
-> ExceptT String IO (Env, Dec, VNameSource)
forall a b. (a -> b) -> a -> b
$
      (Warnings, Either TypeError (Env, Dec, VNameSource))
-> Either TypeError (Env, Dec, VNameSource)
forall a b. (a, b) -> b
snd ((Warnings, Either TypeError (Env, Dec, VNameSource))
 -> Either TypeError (Env, Dec, VNameSource))
-> (Warnings, Either TypeError (Env, Dec, VNameSource))
-> Either TypeError (Env, Dec, VNameSource)
forall a b. (a -> b) -> a -> b
$
        Imports
-> VNameSource
-> Env
-> ImportName
-> UncheckedDec
-> (Warnings, Either TypeError (Env, Dec, VNameSource))
T.checkDec Imports
imports VNameSource
src Env
T.initialEnv ImportName
imp (UncheckedDec
 -> (Warnings, Either TypeError (Env, Dec, VNameSource)))
-> UncheckedDec
-> (Warnings, Either TypeError (Env, Dec, VNameSource))
forall a b. (a -> b) -> a -> b
$
          String -> UncheckedDec
mkOpen String
"/prelude/prelude"
  (Env
tenv2, Dec
d2, VNameSource
_) <-
    (TypeError -> String)
-> Either TypeError (Env, Dec, VNameSource)
-> ExceptT String IO (Env, Dec, VNameSource)
forall err a.
(err -> String) -> Either err a -> ExceptT String IO a
badOnLeft TypeError -> String
forall a. Pretty a => a -> String
pretty (Either TypeError (Env, Dec, VNameSource)
 -> ExceptT String IO (Env, Dec, VNameSource))
-> Either TypeError (Env, Dec, VNameSource)
-> ExceptT String IO (Env, Dec, VNameSource)
forall a b. (a -> b) -> a -> b
$
      (Warnings, Either TypeError (Env, Dec, VNameSource))
-> Either TypeError (Env, Dec, VNameSource)
forall a b. (a, b) -> b
snd ((Warnings, Either TypeError (Env, Dec, VNameSource))
 -> Either TypeError (Env, Dec, VNameSource))
-> (Warnings, Either TypeError (Env, Dec, VNameSource))
-> Either TypeError (Env, Dec, VNameSource)
forall a b. (a -> b) -> a -> b
$
        Imports
-> VNameSource
-> Env
-> ImportName
-> UncheckedDec
-> (Warnings, Either TypeError (Env, Dec, VNameSource))
T.checkDec Imports
imports VNameSource
src' Env
tenv1 ImportName
imp (UncheckedDec
 -> (Warnings, Either TypeError (Env, Dec, VNameSource)))
-> UncheckedDec
-> (Warnings, Either TypeError (Env, Dec, VNameSource))
forall a b. (a -> b) -> a -> b
$
          String -> UncheckedDec
mkOpen (String -> UncheckedDec) -> String -> UncheckedDec
forall a b. (a -> b) -> a -> b
$ String -> String
toPOSIX (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String -> String
dropExtension String
file
  Ctx
ienv2 <- (InterpreterError -> String)
-> Either InterpreterError Ctx -> ExceptT String IO Ctx
forall err a.
(err -> String) -> Either err a -> ExceptT String IO a
badOnLeft InterpreterError -> String
forall a. Show a => a -> String
show (Either InterpreterError Ctx -> ExceptT String IO Ctx)
-> ExceptT String IO (Either InterpreterError Ctx)
-> ExceptT String IO Ctx
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< F ExtOp Ctx -> ExceptT String IO (Either InterpreterError Ctx)
forall (m :: * -> *) a.
MonadIO m =>
F ExtOp a -> m (Either InterpreterError a)
runInterpreter' (Ctx -> Dec -> F ExtOp Ctx
I.interpretDec Ctx
ienv1 Dec
d1)
  Ctx
ienv3 <- (InterpreterError -> String)
-> Either InterpreterError Ctx -> ExceptT String IO Ctx
forall err a.
(err -> String) -> Either err a -> ExceptT String IO a
badOnLeft InterpreterError -> String
forall a. Show a => a -> String
show (Either InterpreterError Ctx -> ExceptT String IO Ctx)
-> ExceptT String IO (Either InterpreterError Ctx)
-> ExceptT String IO Ctx
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< F ExtOp Ctx -> ExceptT String IO (Either InterpreterError Ctx)
forall (m :: * -> *) a.
MonadIO m =>
F ExtOp a -> m (Either InterpreterError a)
runInterpreter' (Ctx -> Dec -> F ExtOp Ctx
I.interpretDec Ctx
ienv2 Dec
d2)
  (Env, Ctx) -> ExceptT String IO (Env, Ctx)
forall (m :: * -> *) a. Monad m => a -> m a
return (Env
tenv2, Ctx
ienv3)
  where
    badOnLeft :: (err -> String) -> Either err a -> ExceptT String IO a
    badOnLeft :: forall err a.
(err -> String) -> Either err a -> ExceptT String IO a
badOnLeft err -> String
_ (Right a
x) = a -> ExceptT String IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
x
    badOnLeft err -> String
p (Left err
err) = String -> ExceptT String IO a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (String -> ExceptT String IO a) -> String -> ExceptT String IO a
forall a b. (a -> b) -> a -> b
$ err -> String
p err
err

mkOpen :: FilePath -> UncheckedDec
mkOpen :: String -> UncheckedDec
mkOpen String
f = ModExpBase NoInfo Name -> SrcLoc -> UncheckedDec
forall (f :: * -> *) vn. ModExpBase f vn -> SrcLoc -> DecBase f vn
OpenDec (String -> NoInfo String -> SrcLoc -> ModExpBase NoInfo Name
forall (f :: * -> *) vn.
String -> f String -> SrcLoc -> ModExpBase f vn
ModImport String
f NoInfo String
forall a. NoInfo a
NoInfo SrcLoc
forall a. Monoid a => a
mempty) SrcLoc
forall a. Monoid a => a
mempty

runInterpreter' :: MonadIO m => F I.ExtOp a -> m (Either I.InterpreterError a)
runInterpreter' :: forall (m :: * -> *) a.
MonadIO m =>
F ExtOp a -> m (Either InterpreterError a)
runInterpreter' 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 (m :: * -> *) a. Monad m => a -> m a
return (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 {m :: * -> *} {b}.
MonadIO m =>
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 (m :: * -> *) a. Monad m => a -> m a
return (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 Loc
w String
v m (Either InterpreterError b)
c) = do
      IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Trace at " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Loc -> String
forall a. Located a => a -> String
locStr Loc
w String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
v
      m (Either InterpreterError b)
c
    intOp (I.ExtOpBreak BreakReason
_ NonEmpty StackFrame
_ m (Either InterpreterError b)
c) = m (Either InterpreterError b)
c