Script.hs

-- | @futhark script@
module Futhark.CLI.Script (main) where

import Control.Monad.Except
import Control.Monad.IO.Class (MonadIO)
import Data.Binary qualified as Bin
import Data.ByteString.Lazy.Char8 qualified as BS
import Data.Char (chr)
import Data.Text qualified as T
import Data.Text.IO qualified as T
import Futhark.CLI.Literate
  ( Options (..),
    initialOptions,
    prepareServer,
    scriptCommandLineOptions,
  )
import Futhark.Script
import Futhark.Test.Values (Compound (..))
import Futhark.Util.Options
import Futhark.Util.Pretty (prettyText)
import System.Exit
import System.IO

commandLineOptions :: [FunOptDescr Options]
commandLineOptions =
  scriptCommandLineOptions
    ++ [ Option
           "D"
           ["debug"]
           ( NoArg $ Right $ \config ->
               config
                 { scriptExtraOptions = "-D" : scriptExtraOptions config,
                   scriptVerbose = scriptVerbose config + 1
                 }
           )
           "Enable debugging.",
         Option
           "L"
           ["log"]
           ( NoArg $ Right $ \config ->
               config
                 { scriptExtraOptions = "-L" : scriptExtraOptions config,
                   scriptVerbose = scriptVerbose config + 1
                 }
           )
           "Enable logging.",
         Option
           "b"
           ["binary"]
           (NoArg $ Right $ \config -> config {scriptBinary = True})
           "Produce binary output.",
         Option
           "f"
           ["file"]
           ( ReqArg
               (\f -> Right $ \config -> config {scriptExps = scriptExps config ++ [Left f]})
               "FILE"
           )
           "Run FutharkScript from this file.",
         Option
           "e"
           ["expression"]
           ( ReqArg
               (\s -> Right $ \config -> config {scriptExps = scriptExps config ++ [Right (T.pack s)]})
               "EXP"
           )
           "Run this expression."
       ]

parseScriptFile :: FilePath -> IO Exp
parseScriptFile f = do
  s <- T.readFile f
  case parseExpFromText f s of
    Left e -> do
      T.hPutStrLn stderr e
      exitFailure
    Right e -> pure e

getExp :: Either FilePath T.Text -> IO Exp
getExp (Left f) = parseScriptFile f
getExp (Right s) = case parseExpFromText "command line option" s of
  Left e -> do
    T.hPutStrLn stderr e
    exitFailure
  Right e -> pure e

-- A few extra procedures that are not handled by scriptBuiltin.
extScriptBuiltin :: (MonadError T.Text m, MonadIO m) => EvalBuiltin m
extScriptBuiltin server "store" vs
  | [fv, v@(ValueAtom (SValue _ _))] <- vs = do
      fv' <- getHaskellValue server fv
      case fv' of
        Just path -> do
          let path' = map (chr . fromIntegral) (path :: [Bin.Word8])
          storeExpValue server path' v
          pure $ ValueTuple []
        _ -> bad
  | otherwise = bad
  where
    bad =
      throwError $
        "$store does not accept arguments of types: "
          <> T.intercalate ", " (map (prettyText . fmap scriptValueType) vs)
extScriptBuiltin server f vs =
  scriptBuiltin "." server f vs

-- | Run @futhark script@.
main :: String -> [String] -> IO ()
main = mainWithOptions initialOptions commandLineOptions "PROGRAM [EXP]" $ \args opts ->
  case args of
    [prog, script] -> Just $ main' prog opts $ scriptExps opts ++ [Right $ T.pack script]
    [prog] -> Just $ main' prog opts $ scriptExps opts
    _ -> Nothing
  where
    main' prog opts scripts = do
      scripts' <- mapM getExp scripts
      prepareServer prog opts $ \s -> do
        r <-
          runExceptT $ do
            vs <- mapM (evalExp extScriptBuiltin s) scripts'
            case reverse vs of
              [] -> pure Nothing
              v : _ -> Just <$> getExpValue s v <* freeValue s v
        case r of
          Left e -> do
            T.hPutStrLn stderr e
            exitFailure
          Right Nothing ->
            pure ()
          Right (Just v) ->
            if scriptBinary opts
              then case v of
                ValueAtom v' -> BS.putStr $ Bin.encode v'
                _ ->
                  T.hPutStrLn
                    stderr
                    "Result value cannot be represented in binary format."
              else T.putStrLn $ prettyText v