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

import Control.Exception
import Control.Monad
import Control.Monad.Except
import Control.Monad.Free.Church
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.Pipeline
import Futhark.Util (toPOSIX)
import Futhark.Util.Options
import Futhark.Util.Pretty (AnsiStyle, Doc, hPutDoc)
import Language.Futhark
import Language.Futhark.Interpreter qualified as I
import Language.Futhark.Semantic qualified as T
import Language.Futhark.TypeChecker qualified as T
import System.Exit
import System.FilePath
import System.IO
import Prelude

-- | Run @futhark run@.
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... <program.fut>" [FilePath] -> InterpreterConfig -> Maybe (IO ())
run
  where
    run :: [FilePath] -> InterpreterConfig -> Maybe (IO ())
run [FilePath
prog] InterpreterConfig
config = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ InterpreterConfig -> FilePath -> IO ()
interpret InterpreterConfig
config FilePath
prog
    run [FilePath]
_ InterpreterConfig
_ = forall a. Maybe a
Nothing

interpret :: InterpreterConfig -> FilePath -> IO ()
interpret :: InterpreterConfig -> FilePath -> IO ()
interpret InterpreterConfig
config FilePath
fp = do
  Either (Doc AnsiStyle) (Env, Ctx)
pr <- InterpreterConfig
-> FilePath -> IO (Either (Doc AnsiStyle) (Env, Ctx))
newFutharkiState InterpreterConfig
config FilePath
fp
  (Env
tenv, Ctx
ienv) <- case Either (Doc AnsiStyle) (Env, Ctx)
pr of
    Left Doc AnsiStyle
err -> do
      Handle -> Doc AnsiStyle -> IO ()
hPutDoc Handle
stderr Doc AnsiStyle
err
      forall a. IO a
exitFailure
    Right (Env, Ctx)
env -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (Env, Ctx)
env

  let entry :: Name
entry = InterpreterConfig -> Name
interpreterEntryPoint InterpreterConfig
config
  Maybe [Value]
vr <- ByteString -> Maybe [Value]
readValues forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO ByteString
BS.getContents

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

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

  case Ctx -> VName -> [Value] -> Either Text (F ExtOp Value)
I.interpretFunction Ctx
ienv (forall vn. QualName vn -> vn
qualLeaf QualName VName
fname) [Value]
inps of
    Left Text
err -> do
      Handle -> Text -> IO ()
T.hPutStrLn Handle
stderr Text
err
      forall a. IO a
exitFailure
    Right F ExtOp Value
run -> do
      Either InterpreterError Value
run' <- 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
          forall a. Show a => Handle -> a -> IO ()
hPrint Handle
stderr InterpreterError
err
          forall a. IO a
exitFailure
        Right Value
res ->
          case (forall (m :: * -> *). Value m -> Maybe [Value m]
I.fromTuple Value
res, forall dim as. TypeBase dim as -> Maybe [TypeBase dim as]
isTupleRecord TypeBase () ()
ret) of
            (Just [Value]
vs, Just [TypeBase () ()]
ts) -> 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
  | forall (m :: * -> *). Value m -> Bool
I.isEmptyArray Value
v = Text -> IO ()
T.putStrLn forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). TypeBase () () -> Value m -> Text
I.prettyEmptyArray TypeBase () ()
t Value
v
  | Bool
otherwise = Text -> IO ()
T.putStrLn forall a b. (a -> b) -> a -> b
$ 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 =
  [ forall a.
FilePath -> [FilePath] -> ArgDescr a -> FilePath -> OptDescr a
Option
      FilePath
"e"
      [FilePath
"entry-point"]
      ( 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 {interpreterEntryPoint :: Name
interpreterEntryPoint = FilePath -> Name
nameFromString FilePath
entry}
          )
          FilePath
"NAME"
      )
      FilePath
"The entry point to execute.",
    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 ->
  FilePath ->
  IO (Either (Doc AnsiStyle) (T.Env, I.Ctx))
newFutharkiState :: InterpreterConfig
-> FilePath -> IO (Either (Doc AnsiStyle) (Env, Ctx))
newFutharkiState InterpreterConfig
cfg FilePath
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)
readProgramFile [] FilePath
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

  let imp :: ImportName
imp = FilePath -> ImportName
T.mkInitialImport FilePath
"."
  Ctx
ienv1 <-
    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)
runInterpreter' 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
  (Env
tenv1, Dec
d1, VNameSource
src') <-
    forall err err' a.
(err -> err') -> Either err a -> ExceptT err' IO a
badOnLeft TypeError -> Doc AnsiStyle
T.prettyTypeError forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd 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 forall a b. (a -> b) -> a -> b
$
        FilePath -> UncheckedDec
mkOpen FilePath
"/prelude/prelude"
  (Env
tenv2, Dec
d2, VNameSource
_) <-
    forall err err' a.
(err -> err') -> Either err a -> ExceptT err' IO a
badOnLeft TypeError -> Doc AnsiStyle
T.prettyTypeError forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd 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 forall a b. (a -> b) -> a -> b
$
        FilePath -> UncheckedDec
mkOpen forall a b. (a -> b) -> a -> b
$
          FilePath -> FilePath
toPOSIX forall a b. (a -> b) -> a -> b
$
            FilePath -> FilePath
dropExtension FilePath
file
  Ctx
ienv2 <- forall err err' a.
(err -> err') -> Either err a -> ExceptT err' IO a
badOnLeft InterpreterError -> Doc AnsiStyle
I.prettyInterpreterError forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< 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 <- forall err err' a.
(err -> err') -> Either err a -> ExceptT err' IO a
badOnLeft InterpreterError -> Doc AnsiStyle
I.prettyInterpreterError forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *) a.
MonadIO m =>
F ExtOp a -> m (Either InterpreterError a)
runInterpreter' (Ctx -> Dec -> F ExtOp Ctx
I.interpretDec Ctx
ienv2 Dec
d2)
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (Env
tenv2, Ctx
ienv3)
  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

mkOpen :: FilePath -> UncheckedDec
mkOpen :: FilePath -> UncheckedDec
mkOpen FilePath
f = forall (f :: * -> *) vn. ModExpBase f vn -> SrcLoc -> DecBase f vn
OpenDec (forall (f :: * -> *) vn.
FilePath -> f FilePath -> SrcLoc -> ModExpBase f vn
ModImport FilePath
f forall {k} (a :: k). NoInfo a
NoInfo forall a. Monoid a => a
mempty) 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 = 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 FilePath
w FilePath
v f (Either InterpreterError b)
c) = do
      forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Handle -> FilePath -> IO ()
hPutStrLn Handle
stderr forall a b. (a -> b) -> a -> b
$ FilePath
w forall a. [a] -> [a] -> [a]
++ FilePath
": " forall a. [a] -> [a] -> [a]
++ FilePath
v
      f (Either InterpreterError b)
c
    intOp (I.ExtOpBreak Loc
_ BreakReason
_ NonEmpty StackFrame
_ f (Either InterpreterError b)
c) = f (Either InterpreterError b)
c