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

    import Control.Exception
    import Control.Monad
    import Control.Monad.Except (ExceptT, runExceptT, throwError)
    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.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))
    newFutharkiState 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 () ())
    -> IO (QualName VName, TypeBase () ())
    forall a. a -> IO a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure (QualName VName
    fname, StructType -> TypeBase () ()
    forall dim as. TypeBase dim as -> TypeBase () ()
    toStructural (StructType -> TypeBase () ()) -> StructType -> TypeBase () ()
    forall a b. (a -> b) -> a -> b
    $ ([TypeBase Size Diet], StructType) -> StructType
    forall a b. (a, b) -> b
    snd (([TypeBase Size Diet], StructType) -> StructType)
    -> ([TypeBase Size Diet], StructType) -> StructType
    forall a b. (a -> b) -> a -> b
    $ StructType -> ([TypeBase Size Diet], StructType)
    forall dim as.
    TypeBase dim as -> ([TypeBase dim Diet], TypeBase dim NoUniqueness)
    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 () ())
    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 () () -> 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
    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 () () -> Value -> Text
    forall (m :: * -> *). TypeBase () () -> Value m -> Text
    I.prettyEmptyArray TypeBase () ()
    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."
      ]

    newFutharkiState ::
      InterpreterConfig ->
      FilePath ->
      IO (Either (Doc AnsiStyle) (T.Env, I.Ctx))
    newFutharkiState :: InterpreterConfig
    -> String -> IO (Either (Doc AnsiStyle) (Env, Ctx))
    newFutharkiState 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 err' a.
    (err -> err') -> Either err a -> ExceptT err' IO 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

      let loadImport Ctx
    ctx =
            (InterpreterError -> Doc AnsiStyle)
    -> Either InterpreterError Ctx -> ExceptT (Doc AnsiStyle) IO Ctx
    forall err err' a.
    (err -> err') -> Either err a -> ExceptT err' IO a
    badOnLeft InterpreterError -> Doc AnsiStyle
    I.prettyInterpreterError
              (Either InterpreterError Ctx -> ExceptT (Doc AnsiStyle) IO Ctx)
    -> ((ImportName, Prog)
        -> ExceptT (Doc AnsiStyle) IO (Either InterpreterError Ctx))
    -> (ImportName, Prog)
    -> ExceptT (Doc AnsiStyle) IO Ctx
    forall (m :: * -> *) b c a.
    Monad m =>
    (b -> m c) -> (a -> m b) -> a -> m c
    <=< F ExtOp Ctx
    -> ExceptT (Doc AnsiStyle) IO (Either InterpreterError Ctx)
    forall (m :: * -> *) a.
    MonadIO m =>
    F ExtOp a -> m (Either InterpreterError a)
    runInterpreter' (F ExtOp Ctx
     -> ExceptT (Doc AnsiStyle) IO (Either InterpreterError Ctx))
    -> ((ImportName, Prog) -> F ExtOp Ctx)
    -> (ImportName, Prog)
    -> ExceptT (Doc AnsiStyle) IO (Either InterpreterError Ctx)
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Ctx -> (ImportName, Prog) -> F ExtOp Ctx
    I.interpretImport Ctx
    ctx

      ictx <- foldM loadImport I.initialCtx $ map (fmap fileProg) imports
      let (tenv, ienv) =
            let (iname, fm) = last imports
             in ( fileScope fm,
                  ictx {I.ctxEnv = I.ctxImports ictx M.! iname}
                )

      pure (tenv, 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) = a -> ExceptT err' IO a
    forall a. a -> ExceptT err' IO a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure a
    x
        badOnLeft err -> err'
    p (Left err
    err) = err' -> ExceptT err' IO a
    forall a. err' -> ExceptT err' IO a
    forall e (m :: * -> *) a. MonadError e m => e -> m a
    throwError (err' -> ExceptT err' IO a) -> err' -> ExceptT err' IO a
    forall a b. (a -> b) -> a -> b
    $ err -> err'
    p err
    err

    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