module Futhark.CLI.Eval (main) where

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

main :: String -> [String] -> IO ()
main :: FilePath -> [FilePath] -> IO ()
main = forall cfg.
cfg
-> [FunOptDescr cfg]
-> FilePath
-> ([FilePath] -> cfg -> Maybe (IO ()))
-> FilePath
-> [FilePath]
-> IO ()
mainWithOptions InterpreterConfig
interpreterConfig [FunOptDescr InterpreterConfig]
options FilePath
"options... <exprs...>" [FilePath] -> InterpreterConfig -> Maybe (IO ())
run
  where
    run :: [FilePath] -> InterpreterConfig -> Maybe (IO ())
run [] InterpreterConfig
_ = forall a. Maybe a
Nothing
    run [FilePath]
exprs InterpreterConfig
config = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ [FilePath] -> InterpreterConfig -> IO ()
runExprs [FilePath]
exprs InterpreterConfig
config

runExprs :: [String] -> InterpreterConfig -> IO ()
runExprs :: [FilePath] -> InterpreterConfig -> IO ()
runExprs [FilePath]
exprs InterpreterConfig
cfg = do
  let InterpreterConfig Bool
_ Maybe FilePath
file = InterpreterConfig
cfg
  Either (Doc AnsiStyle) (VNameSource, Env, Ctx)
maybe_new_state <- InterpreterConfig
-> Maybe FilePath
-> IO (Either (Doc AnsiStyle) (VNameSource, Env, Ctx))
newFutharkiState InterpreterConfig
cfg Maybe FilePath
file
  (VNameSource
src, Env
env, Ctx
ctx) <- case Either (Doc AnsiStyle) (VNameSource, Env, Ctx)
maybe_new_state of
    Left Doc AnsiStyle
_ -> do
      Handle -> FilePath -> IO ()
hPutStrLn Handle
stderr forall a b. (a -> b) -> a -> b
$ forall a. HasCallStack => Maybe a -> a
fromJust Maybe FilePath
file forall a. Semigroup a => a -> a -> a
<> FilePath
": file not found."
      forall a. ExitCode -> IO a
exitWith forall a b. (a -> b) -> a -> b
$ Int -> ExitCode
ExitFailure Int
2
    Right (VNameSource, Env, Ctx)
s -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (VNameSource, Env, Ctx)
s
  forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (VNameSource -> Env -> Ctx -> FilePath -> IO ()
runExpr VNameSource
src Env
env Ctx
ctx) [FilePath]
exprs

-- Use parseExp, checkExp, then interpretExp.
runExpr :: VNameSource -> T.Env -> I.Ctx -> String -> IO ()
runExpr :: VNameSource -> Env -> Ctx -> FilePath -> IO ()
runExpr VNameSource
src Env
env Ctx
ctx FilePath
str = do
  UncheckedExp
uexp <- case FilePath -> Text -> Either SyntaxError UncheckedExp
parseExp FilePath
"" (FilePath -> Text
T.pack FilePath
str) of
    Left (SyntaxError Loc
_ Text
serr) -> do
      Handle -> Text -> IO ()
T.hPutStrLn Handle
stderr Text
serr
      forall a. ExitCode -> IO a
exitWith forall a b. (a -> b) -> a -> b
$ Int -> ExitCode
ExitFailure Int
1
    Right UncheckedExp
e -> forall (f :: * -> *) a. Applicative f => a -> f a
pure UncheckedExp
e
  Exp
fexp <- case Imports
-> VNameSource
-> Env
-> UncheckedExp
-> (Warnings, Either TypeError ([TypeParam], Exp))
T.checkExp [] VNameSource
src Env
env UncheckedExp
uexp of
    (Warnings
_, Left TypeError
terr) -> do
      Handle -> Doc AnsiStyle -> IO ()
hPutDoc Handle
stderr forall a b. (a -> b) -> a -> b
$ TypeError -> Doc AnsiStyle
I.prettyTypeError TypeError
terr
      forall a. ExitCode -> IO a
exitWith forall a b. (a -> b) -> a -> b
$ Int -> ExitCode
ExitFailure Int
1
    (Warnings
_, Right ([TypeParam]
_, Exp
e)) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Exp
e
  Either InterpreterError Value
pval <- forall (m :: * -> *) a.
MonadIO m =>
F ExtOp a -> m (Either InterpreterError a)
runInterpreterNoBreak forall a b. (a -> b) -> a -> b
$ Ctx -> Exp -> F ExtOp Value
I.interpretExp Ctx
ctx Exp
fexp
  case Either InterpreterError Value
pval of
    Left InterpreterError
err -> do
      Handle -> Doc AnsiStyle -> IO ()
hPutDoc Handle
stderr forall a b. (a -> b) -> a -> b
$ InterpreterError -> Doc AnsiStyle
I.prettyInterpreterError InterpreterError
err
      forall a. ExitCode -> IO a
exitWith forall a b. (a -> b) -> a -> b
$ Int -> ExitCode
ExitFailure Int
1
    Right Value
val -> Doc AnsiStyle -> IO ()
putDoc forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Value m -> Doc a
I.prettyValue Value
val forall a. Semigroup a => a -> a -> a
<> forall ann. Doc ann
hardline

data InterpreterConfig = InterpreterConfig
  { InterpreterConfig -> Bool
interpreterPrintWarnings :: Bool,
    InterpreterConfig -> Maybe FilePath
interpreterFile :: Maybe String
  }

interpreterConfig :: InterpreterConfig
interpreterConfig :: InterpreterConfig
interpreterConfig = Bool -> Maybe FilePath -> InterpreterConfig
InterpreterConfig Bool
True forall a. Maybe a
Nothing

options :: [FunOptDescr InterpreterConfig]
options :: [FunOptDescr InterpreterConfig]
options =
  [ forall a.
FilePath -> [FilePath] -> ArgDescr a -> FilePath -> OptDescr a
Option
      FilePath
"f"
      [FilePath
"file"]
      ( forall a. (FilePath -> a) -> FilePath -> ArgDescr a
ReqArg
          ( \FilePath
entry -> forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ \InterpreterConfig
config ->
              InterpreterConfig
config {interpreterFile :: Maybe FilePath
interpreterFile = forall a. a -> Maybe a
Just FilePath
entry}
          )
          FilePath
"NAME"
      )
      FilePath
"The file to load before evaluating expressions.",
    forall a.
FilePath -> [FilePath] -> ArgDescr a -> FilePath -> OptDescr a
Option
      FilePath
"w"
      [FilePath
"no-warnings"]
      (forall a. a -> ArgDescr a
NoArg forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ \InterpreterConfig
config -> InterpreterConfig
config {interpreterPrintWarnings :: Bool
interpreterPrintWarnings = Bool
False})
      FilePath
"Do not print warnings."
  ]

newFutharkiState ::
  InterpreterConfig ->
  Maybe FilePath ->
  IO (Either (Doc AnsiStyle) (VNameSource, T.Env, I.Ctx))
newFutharkiState :: InterpreterConfig
-> Maybe FilePath
-> IO (Either (Doc AnsiStyle) (VNameSource, Env, Ctx))
newFutharkiState InterpreterConfig
cfg Maybe FilePath
maybe_file = forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT forall a b. (a -> b) -> a -> b
$ do
  (Warnings
ws, Imports
imports, VNameSource
src) <-
    forall err err' a.
(err -> err') -> Either err a -> ExceptT err' IO a
badOnLeft CompilerError -> Doc AnsiStyle
prettyCompilerError
      forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
        ( forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (forall (m :: * -> *).
(MonadError CompilerError m, MonadIO m) =>
[Name] -> [FilePath] -> m (Warnings, Imports, VNameSource)
readProgramFiles [] forall a b. (a -> b) -> a -> b
$ forall a. Maybe a -> [a]
maybeToList Maybe FilePath
maybe_file)
            forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` \(IOException
err :: IOException) ->
              forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall (m :: * -> *) a.
MonadError CompilerError m =>
FilePath -> m a
externalErrorS (forall a. Show a => a -> FilePath
show IOException
err))
        )
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (InterpreterConfig -> Bool
interpreterPrintWarnings InterpreterConfig
cfg) forall a b. (a -> b) -> a -> b
$
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$
      Handle -> Doc AnsiStyle -> IO ()
hPutDoc Handle
stderr forall a b. (a -> b) -> a -> b
$
        Warnings -> Doc AnsiStyle
prettyWarnings Warnings
ws

  Ctx
ictx <-
    forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (\Ctx
ctx -> forall err err' a.
(err -> err') -> Either err a -> ExceptT err' IO a
badOnLeft InterpreterError -> Doc AnsiStyle
I.prettyInterpreterError forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< forall (m :: * -> *) a.
MonadIO m =>
F ExtOp a -> m (Either InterpreterError a)
runInterpreterNoBreak forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ctx -> (FilePath, Prog) -> F ExtOp Ctx
I.interpretImport Ctx
ctx) Ctx
I.initialCtx forall a b. (a -> b) -> a -> b
$
      forall a b. (a -> b) -> [a] -> [b]
map (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FileModule -> Prog
fileProg) Imports
imports

  let (Env
tenv, Ctx
ienv) =
        let (FilePath
iname, FileModule
fm) = forall a. [a] -> a
last Imports
imports
         in ( FileModule -> Env
fileScope FileModule
fm,
              Ctx
ictx {ctxEnv :: Env
I.ctxEnv = Ctx -> Map FilePath Env
I.ctxImports Ctx
ictx forall k a. Ord k => Map k a -> k -> a
M.! FilePath
iname}
            )

  forall (f :: * -> *) a. Applicative f => a -> f a
pure (VNameSource
src, Env
tenv, Ctx
ienv)
  where
    badOnLeft :: (err -> err') -> Either err a -> ExceptT err' IO a
    badOnLeft :: forall err err' a.
(err -> err') -> Either err a -> ExceptT err' IO a
badOnLeft err -> err'
_ (Right a
x) = forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x
    badOnLeft err -> err'
p (Left err
err) = forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ err -> err'
p err
err

runInterpreterNoBreak :: MonadIO m => F I.ExtOp a -> m (Either I.InterpreterError a)
runInterpreterNoBreak :: forall (m :: * -> *) a.
MonadIO m =>
F ExtOp a -> m (Either InterpreterError a)
runInterpreterNoBreak F ExtOp a
m = forall (f :: * -> *) a.
F f a -> forall r. (a -> r) -> (f r -> r) -> r
runF F ExtOp a
m (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. b -> Either a b
Right) forall {f :: * -> *} {b}.
MonadIO f =>
ExtOp (f (Either InterpreterError b))
-> f (Either InterpreterError b)
intOp
  where
    intOp :: ExtOp (f (Either InterpreterError b))
-> f (Either InterpreterError b)
intOp (I.ExtOpError InterpreterError
err) = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left InterpreterError
err
    intOp (I.ExtOpTrace Text
w Doc ()
v f (Either InterpreterError b)
c) = do
      forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Doc AnsiStyle -> IO ()
putDocLn forall a b. (a -> b) -> a -> b
$ forall a ann. Pretty a => a -> Doc ann
pretty Text
w forall a. Semigroup a => a -> a -> a
<> Doc AnsiStyle
":" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall ann. Doc ann -> Doc ann
align (forall ann xxx. Doc ann -> Doc xxx
unAnnotate Doc ()
v)
      f (Either InterpreterError b)
c
    intOp (I.ExtOpBreak Loc
_ BreakReason
_ NonEmpty StackFrame
_ f (Either InterpreterError b)
c) = f (Either InterpreterError b)
c