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

import Control.Exception
import Control.Monad
import Control.Monad.Except (runExceptT)
import Control.Monad.Free.Church
import Control.Monad.IO.Class (MonadIO, liftIO)
import Data.ByteString.Lazy qualified as BS
import Data.Map qualified as M
import Data.Maybe
import Data.Text.IO qualified as T
import Futhark.Compiler
import Futhark.Data.Reader (readValues)
import Futhark.Eval (interpretImports)
import Futhark.Pipeline
import Futhark.Util.Options
import Futhark.Util.Pretty (AnsiStyle, Doc, align, hPutDoc, hPutDocLn, pretty, unAnnotate, (<+>))
import Language.Futhark
import Language.Futhark.Interpreter qualified as I
import Language.Futhark.Semantic qualified 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
  pr <- InterpreterConfig
-> String -> IO (Either (Doc AnsiStyle) (Env, Ctx))
newInterpreterEnv InterpreterConfig
config String
fp
  (tenv, ienv) <- case pr of
    Left Doc AnsiStyle
err -> do
      Handle -> Doc AnsiStyle -> IO ()
hPutDocLn Handle
stderr Doc AnsiStyle
err
      IO (Env, Ctx)
forall a. IO a
exitFailure
    Right (Env, Ctx)
env -> (Env, Ctx) -> IO (Env, Ctx)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Env, Ctx)
env

  let entry = InterpreterConfig -> Name
interpreterEntryPoint InterpreterConfig
config
  vr <- readValues <$> BS.getContents

  inps <-
    case vr of
      Maybe [Value]
Nothing -> do
        Handle -> Text -> IO ()
T.hPutStrLn Handle
stderr Text
"Incorrectly formatted input data."
        IO [Value]
forall a. IO a
exitFailure
      Just [Value]
vs ->
        [Value] -> IO [Value]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Value]
vs

  (fname, ret) <-
    case M.lookup (T.Term, entry) $ T.envNameMap 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 () NoMode)
-> IO (QualName VName, TypeBase () NoMode)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (QualName VName
fname, StructType -> TypeBase () NoMode
forall dim o. TypeBase dim o -> TypeBase () NoMode
toStructural (StructType -> TypeBase () NoMode)
-> StructType -> TypeBase () NoMode
forall a b. (a -> b) -> a -> b
$ ([(PName, TypeBase Size Diet)], StructType) -> StructType
forall a b. (a, b) -> b
snd (([(PName, TypeBase Size Diet)], StructType) -> StructType)
-> ([(PName, TypeBase Size Diet)], StructType) -> StructType
forall a b. (a -> b) -> a -> b
$ StructType -> ([(PName, TypeBase Size Diet)], StructType)
forall dim o.
TypeBase dim o
-> ([(PName, TypeBase dim Diet)], TypeBase dim NoMode)
unfoldFunType StructType
t)
      Maybe (QualName VName)
_ -> do
        Handle -> Text -> IO ()
T.hPutStrLn Handle
stderr (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
"Invalid entry point: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Name -> Text
forall a. Pretty a => a -> Text
prettyText Name
entry
        IO (QualName VName, TypeBase () NoMode)
forall a. IO a
exitFailure

  case I.interpretFunction ienv (qualLeaf fname) inps of
    Left Text
err -> do
      Handle -> Text -> IO ()
T.hPutStrLn Handle
stderr Text
err
      IO ()
forall a. IO a
exitFailure
    Right F ExtOp Value
run -> do
      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 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]
forall (m :: * -> *). Value m -> Maybe [Value m]
I.fromTuple Value
res, TypeBase () NoMode -> Maybe [TypeBase () NoMode]
forall dim o. TypeBase dim o -> Maybe [TypeBase dim o]
isTupleRecord TypeBase () NoMode
ret) of
            (Just [Value]
vs, Just [TypeBase () NoMode]
ts) -> (Value -> TypeBase () NoMode -> IO ())
-> [Value] -> [TypeBase () NoMode] -> IO ()
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m ()
zipWithM_ Value -> TypeBase () NoMode -> IO ()
putValue [Value]
vs [TypeBase () NoMode]
ts
            (Maybe [Value], Maybe [TypeBase () NoMode])
_ -> Value -> TypeBase () NoMode -> IO ()
putValue Value
res TypeBase () NoMode
ret

putValue :: I.Value -> TypeBase () NoMode -> IO ()
putValue :: Value -> TypeBase () NoMode -> IO ()
putValue Value
v TypeBase () NoMode
t
  | Value -> Bool
forall (m :: * -> *). Value m -> Bool
I.isEmptyArray Value
v = Text -> IO ()
T.putStrLn (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ TypeBase () NoMode -> Value -> Text
forall (m :: * -> *). TypeBase () NoMode -> Value m -> Text
I.prettyEmptyArray TypeBase () NoMode
t Value
v
  | Bool
otherwise = Text -> IO ()
T.putStrLn (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Value -> Text
forall (m :: * -> *). Value m -> Text
I.valueText 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 = nameFromString 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 = False})
      String
"Do not print warnings."
  ]

newInterpreterEnv ::
  InterpreterConfig ->
  FilePath ->
  IO (Either (Doc AnsiStyle) (T.Env, I.Ctx))
newInterpreterEnv :: InterpreterConfig
-> String -> IO (Either (Doc AnsiStyle) (Env, Ctx))
newInterpreterEnv InterpreterConfig
cfg String
file = ExceptT (Doc AnsiStyle) IO (Env, Ctx)
-> IO (Either (Doc AnsiStyle) (Env, Ctx))
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT (Doc AnsiStyle) IO (Env, Ctx)
 -> IO (Either (Doc AnsiStyle) (Env, Ctx)))
-> ExceptT (Doc AnsiStyle) IO (Env, Ctx)
-> IO (Either (Doc AnsiStyle) (Env, Ctx))
forall a b. (a -> b) -> a -> b
$ do
  (ws, imports, _src) <-
    (CompilerError -> Doc AnsiStyle)
-> Either CompilerError (Warnings, Imports, VNameSource)
-> ExceptT (Doc AnsiStyle) IO (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) IO (Warnings, Imports, VNameSource))
-> ExceptT
     (Doc AnsiStyle)
     IO
     (Either CompilerError (Warnings, Imports, VNameSource))
-> ExceptT (Doc AnsiStyle) IO (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)
     IO
     (Either CompilerError (Warnings, Imports, VNameSource))
forall a. IO a -> ExceptT (Doc AnsiStyle) IO 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]
-> String
-> ExceptT CompilerError IO (Warnings, Imports, VNameSource)
forall (m :: * -> *).
(MonadError CompilerError m, MonadIO m) =>
[Name] -> String -> m (Warnings, Imports, VNameSource)
readProgramFile [] 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 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 (interpreterPrintWarnings cfg) $
    liftIO $
      hPutDoc stderr $
        prettyWarnings ws

  interpretImports runInterpreter' imports

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 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 {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) = Either InterpreterError b -> f (Either InterpreterError b)
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either InterpreterError b -> f (Either InterpreterError b))
-> Either InterpreterError b -> f (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 f (Either InterpreterError b)
c) = do
      IO () -> f ()
forall a. IO a -> f a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> f ()) -> IO () -> f ()
forall a b. (a -> b) -> a -> b
$ Handle -> Doc AnsiStyle -> IO ()
hPutDocLn Handle
stderr (Doc AnsiStyle -> IO ()) -> Doc AnsiStyle -> IO ()
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)
      f (Either InterpreterError b)
c
    intOp (I.ExtOpBreak Loc
_ BreakReason
_ NonEmpty StackFrame
_ f (Either InterpreterError b)
c) = f (Either InterpreterError b)
c
    intOp (I.ExtOpFFI {}) = String -> f (Either InterpreterError b)
forall a. HasCallStack => String -> a
error String
"External calls are not yet supported in Run."
    intOp (I.ExtOpIO IOOp
op Value -> f (Either InterpreterError b)
c) =
      (Text -> f (Either InterpreterError b))
-> (Value -> f (Either InterpreterError b))
-> Either Text Value
-> f (Either InterpreterError b)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Either InterpreterError b -> f (Either InterpreterError b)
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either InterpreterError b -> f (Either InterpreterError b))
-> (Text -> Either InterpreterError b)
-> Text
-> f (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 -> f (Either InterpreterError b)
c (Either Text Value -> f (Either InterpreterError b))
-> f (Either Text Value) -> f (Either InterpreterError b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO (Either Text Value) -> f (Either Text Value)
forall a. IO a -> f 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
forall a. Maybe a
Nothing IOOp
op)