-- | Facilities for reading Futhark test programs.  A Futhark test
-- program is an ordinary Futhark program where an initial comment
-- block specifies input- and output-sets.
module Futhark.Test
  ( module Futhark.Test.Property,
    module Futhark.Test.Spec,
    valuesFromByteString,
    FutharkExe (..),
    getValues,
    getValuesBS,
    valuesAsVars,
    V.compareValues,
    checkResult,
    testRunReferenceOutput,
    getExpectedResult,
    compileProgram,
    readResults,
    ensureReferenceOutput,
    determineTuning,
    determineCache,
    binaryName,
    futharkServerCfg,
    V.Mismatch,
    V.Value,
    V.valueText,
  )
where

import Codec.Compression.GZip
import Control.Applicative
import Control.Exception (catch)
import Control.Exception.Base qualified as E
import Control.Monad
import Control.Monad.Except (ExceptT (..), MonadError (..), liftEither, runExceptT, withExceptT)
import Control.Monad.Free.Church (F)
import Control.Monad.IO.Class (MonadIO, liftIO)
import Data.Bifunctor (first)
import Data.Binary qualified as Bin
import Data.ByteString qualified as SBS
import Data.ByteString.Lazy qualified as BS
import Data.Char
import Data.Either (fromRight)
import Data.Map qualified as M
import Data.Maybe
import Data.Text qualified as T
import Data.Text.Encoding qualified as T
import Data.Text.IO qualified as T
import Futhark.Compiler (readProgramFilesExceptKnown)
import Futhark.Error (prettyCompilerError)
import Futhark.Eval (externaliseLast, interpretImports, runInterpreterWith)
import Futhark.FreshNames (VNameSource)
import Futhark.Server
import Futhark.Server.Values
import Futhark.Test.Compile
import Futhark.Test.Property
import Futhark.Test.Spec
import Futhark.Test.Values qualified as V
import Futhark.Util (ensureCacheDirectory, nubOrd, pmapIO, showText)
import Futhark.Util.Pretty (docText, prettyText, prettyTextOneLine)
import Language.Futhark
  ( DecBase (..),
    EntryParam (..),
    EntryPoint (..),
    EntryType (..),
    Exp,
    Info (..),
    Name,
    ProgBase (..),
    StructType,
    UncheckedExp,
    ValBindBase (..),
    baseName,
    isTupleRecord,
    nameToText,
    noSizes,
    typeOf,
  )
import Language.Futhark.Core (nameFromText)
import Language.Futhark.Interpreter qualified as I
import Language.Futhark.Interpreter.FFI.Push qualified as FFI
import Language.Futhark.Interpreter.FFI.ServerM qualified as FFI
import Language.Futhark.Interpreter.Values qualified as IV
import Language.Futhark.Parser (SyntaxError (..), parseExp)
import Language.Futhark.Semantic (Env, FileModule (..), Imports)
import Language.Futhark.Tuple (areTupleFields)
import Language.Futhark.TypeChecker (checkExp, prettyTypeError)
import System.Directory
import System.Exit
import System.FilePath
import System.IO (IOMode (..), hClose, hFileSize, withFile)
import System.IO.Error
import System.IO.Temp
import System.Process.ByteString (readProcessWithExitCode)
import Prelude

-- | Try to parse a several values from a byte string.  The 'String'
-- parameter is used for error messages.
valuesFromByteString :: String -> BS.ByteString -> Either String [V.Value]
valuesFromByteString :: FilePath -> ByteString -> Either FilePath [Value]
valuesFromByteString FilePath
srcname =
  Either FilePath [Value]
-> ([Value] -> Either FilePath [Value])
-> Maybe [Value]
-> Either FilePath [Value]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (FilePath -> Either FilePath [Value]
forall a b. a -> Either a b
Left (FilePath -> Either FilePath [Value])
-> FilePath -> Either FilePath [Value]
forall a b. (a -> b) -> a -> b
$ FilePath
"Cannot parse values from '" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
srcname FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"'") [Value] -> Either FilePath [Value]
forall a b. b -> Either a b
Right (Maybe [Value] -> Either FilePath [Value])
-> (ByteString -> Maybe [Value])
-> ByteString
-> Either FilePath [Value]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Maybe [Value]
V.readValues

-- | Get the actual core Futhark values corresponding to a 'Values'
-- specification.  The first 'FilePath' is the path of the @futhark@
-- executable, and the second is the directory which file paths are
-- read relative to.
getValues :: (MonadFail m, MonadIO m) => FutharkExe -> FilePath -> Values -> m [V.Value]
getValues :: forall (m :: * -> *).
(MonadFail m, MonadIO m) =>
FutharkExe -> FilePath -> Values -> m [Value]
getValues FutharkExe
_ FilePath
_ (Values [Value]
vs) = [Value] -> m [Value]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Value]
vs
getValues FutharkExe
futhark FilePath
dir Values
v = do
  s <- FutharkExe -> FilePath -> Values -> m ByteString
forall (m :: * -> *).
(MonadFail m, MonadIO m) =>
FutharkExe -> FilePath -> Values -> m ByteString
getValuesBS FutharkExe
futhark FilePath
dir Values
v
  case valuesFromByteString (fileName v) s of
    Left FilePath
e -> FilePath -> m [Value]
forall a. FilePath -> m a
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail FilePath
e
    Right [Value]
vs -> [Value] -> m [Value]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Value]
vs
  where
    fileName :: Values -> FilePath
fileName Values {} = FilePath
"<values>"
    fileName GenValues {} = FilePath
"<randomly generated>"
    fileName ScriptValues {} = FilePath
"<script expression>"
    fileName (InFile FilePath
f) = FilePath
f
    fileName (ScriptFile FilePath
f) = FilePath
f

readAndDecompress :: FilePath -> IO (Either DecompressError BS.ByteString)
readAndDecompress :: FilePath -> IO (Either DecompressError ByteString)
readAndDecompress FilePath
file = IO ByteString -> IO (Either DecompressError ByteString)
forall e a. Exception e => IO a -> IO (Either e a)
E.try (IO ByteString -> IO (Either DecompressError ByteString))
-> IO ByteString -> IO (Either DecompressError ByteString)
forall a b. (a -> b) -> a -> b
$ do
  s <- FilePath -> IO ByteString
BS.readFile FilePath
file
  E.evaluate $ decompress s

-- | Extract a text representation of some 'Values'.  In the IO monad
-- because this might involve reading from a file.  There is no
-- guarantee that the resulting byte string yields a readable value.
getValuesBS :: (MonadFail m, MonadIO m) => FutharkExe -> FilePath -> Values -> m BS.ByteString
getValuesBS :: forall (m :: * -> *).
(MonadFail m, MonadIO m) =>
FutharkExe -> FilePath -> Values -> m ByteString
getValuesBS FutharkExe
_ FilePath
_ (Values [Value]
vs) =
  ByteString -> m ByteString
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ByteString -> m ByteString) -> ByteString -> m ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
BS.fromStrict (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Text -> ByteString
T.encodeUtf8 (Text -> ByteString) -> Text -> ByteString
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.unlines ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ (Value -> Text) -> [Value] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Value -> Text
V.valueText [Value]
vs
getValuesBS FutharkExe
_ FilePath
dir (InFile FilePath
file) =
  case FilePath -> FilePath
takeExtension FilePath
file of
    FilePath
".gz" -> IO ByteString -> m ByteString
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ByteString -> m ByteString) -> IO ByteString -> m ByteString
forall a b. (a -> b) -> a -> b
$ do
      s <- FilePath -> IO (Either DecompressError ByteString)
readAndDecompress FilePath
file'
      case s of
        Left DecompressError
e -> FilePath -> IO ByteString
forall a. FilePath -> IO a
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail (FilePath -> IO ByteString) -> FilePath -> IO ByteString
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath
forall a. Show a => a -> FilePath
show FilePath
file FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
": " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ DecompressError -> FilePath
forall a. Show a => a -> FilePath
show DecompressError
e
        Right ByteString
s' -> ByteString -> IO ByteString
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ByteString
s'
    FilePath
_ -> IO ByteString -> m ByteString
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ByteString -> m ByteString) -> IO ByteString -> m ByteString
forall a b. (a -> b) -> a -> b
$ FilePath -> IO ByteString
BS.readFile FilePath
file'
  where
    file' :: FilePath
file' = FilePath
dir FilePath -> FilePath -> FilePath
</> FilePath
file
getValuesBS FutharkExe
futhark FilePath
dir (GenValues [GenValue]
gens) =
  [ByteString] -> ByteString
forall a. Monoid a => [a] -> a
mconcat ([ByteString] -> ByteString) -> m [ByteString] -> m ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (GenValue -> m ByteString) -> [GenValue] -> m [ByteString]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (FutharkExe -> FilePath -> GenValue -> m ByteString
forall (m :: * -> *).
MonadIO m =>
FutharkExe -> FilePath -> GenValue -> m ByteString
getGenBS FutharkExe
futhark FilePath
dir) [GenValue]
gens
getValuesBS FutharkExe
_ FilePath
_ (ScriptValues UncheckedExp
e) =
  FilePath -> m ByteString
forall a. FilePath -> m a
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail (FilePath -> m ByteString) -> FilePath -> m ByteString
forall a b. (a -> b) -> a -> b
$
    FilePath
"Cannot get values from script expression: "
      FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> Text -> FilePath
T.unpack (UncheckedExp -> Text
forall a. Pretty a => a -> Text
prettyTextOneLine UncheckedExp
e)
getValuesBS FutharkExe
_ FilePath
_ (ScriptFile FilePath
f) =
  FilePath -> m ByteString
forall a. FilePath -> m a
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail (FilePath -> m ByteString) -> FilePath -> m ByteString
forall a b. (a -> b) -> a -> b
$ FilePath
"Cannot get values from script file: " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
f

-- | Run an interpreter action that produces test input. Calls to entry points
-- are dispatched to the server, files are read relative to the given directory,
-- and traces and breakpoints are ignored.
runScript :: FFI.Server -> FilePath -> F I.ExtOp a -> IO (Either I.InterpreterError a)
runScript :: forall a.
Server -> FilePath -> F ExtOp a -> IO (Either InterpreterError a)
runScript Server
server FilePath
dir = (Doc AnsiStyle -> IO ())
-> Maybe Server
-> Maybe FilePath
-> F ExtOp a
-> IO (Either InterpreterError a)
forall (m :: * -> *) a.
MonadIO m =>
(Doc AnsiStyle -> m ())
-> Maybe Server
-> Maybe FilePath
-> F ExtOp a
-> m (Either InterpreterError a)
runInterpreterWith (IO () -> Doc AnsiStyle -> IO ()
forall a b. a -> b -> a
const (IO () -> Doc AnsiStyle -> IO ())
-> IO () -> Doc AnsiStyle -> IO ()
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) (Server -> Maybe Server
forall a. a -> Maybe a
Just Server
server) (FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
dir)

-- | The entry points of the program (the last import).
programEntryPoints :: Imports -> M.Map Name EntryPoint
programEntryPoints :: Imports -> Map Name EntryPoint
programEntryPoints Imports
imports =
  [(Name, EntryPoint)] -> Map Name EntryPoint
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList
    [ (VName -> Name
baseName (VName -> Name) -> VName -> Name
forall a b. (a -> b) -> a -> b
$ ValBindBase Info VName -> VName
forall (f :: * -> *) vn. ValBindBase f vn -> vn
valBindName ValBindBase Info VName
vb, EntryPoint
ep)
    | ValDec ValBindBase Info VName
vb <- (DecBase Info VName -> DecBase Info VName)
-> [DecBase Info VName] -> [DecBase Info VName]
forall a b. (a -> b) -> [a] -> [b]
map DecBase Info VName -> DecBase Info VName
forall {f :: * -> *} {vn}. DecBase f vn -> DecBase f vn
unLocal ([DecBase Info VName] -> [DecBase Info VName])
-> [DecBase Info VName] -> [DecBase Info VName]
forall a b. (a -> b) -> a -> b
$ ProgBase Info VName -> [DecBase Info VName]
forall (f :: * -> *) vn. ProgBase f vn -> [DecBase f vn]
progDecs (ProgBase Info VName -> [DecBase Info VName])
-> ProgBase Info VName -> [DecBase Info VName]
forall a b. (a -> b) -> a -> b
$ FileModule -> ProgBase Info VName
fileProg (FileModule -> ProgBase Info VName)
-> FileModule -> ProgBase Info VName
forall a b. (a -> b) -> a -> b
$ (ImportName, FileModule) -> FileModule
forall a b. (a, b) -> b
snd ((ImportName, FileModule) -> FileModule)
-> (ImportName, FileModule) -> FileModule
forall a b. (a -> b) -> a -> b
$ Imports -> (ImportName, FileModule)
forall a. HasCallStack => [a] -> a
last Imports
imports,
      Just (Info EntryPoint
ep) <- [ValBindBase Info VName -> Maybe (Info EntryPoint)
forall (f :: * -> *) vn. ValBindBase f vn -> Maybe (f EntryPoint)
valBindEntryPoint ValBindBase Info VName
vb]
    ]
  where
    unLocal :: DecBase f vn -> DecBase f vn
unLocal (LocalDec DecBase f vn
dec SrcLoc
_) = DecBase f vn -> DecBase f vn
unLocal DecBase f vn
dec
    unLocal DecBase f vn
dec = DecBase f vn
dec

-- | Read, type check and interpret the program, with its entry points run on
-- the server. Produces what is needed to type check and evaluate script
-- expressions in the context of the program, as well as the parameter types of
-- the given entry point.
scriptContext ::
  FFI.Server ->
  FilePath ->
  Name ->
  ExceptT T.Text IO (VNameSource, Env, I.Ctx, [StructType])
scriptContext :: Server
-> FilePath
-> Name
-> ExceptT Text IO (VNameSource, Env, Ctx, [StructType])
scriptContext Server
server FilePath
prog Name
entry = do
  (_, imports, src) <-
    (CompilerError -> Text)
-> ExceptT CompilerError IO (Warnings, Imports, VNameSource)
-> ExceptT Text IO (Warnings, Imports, VNameSource)
forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT (Doc AnsiStyle -> Text
forall a. Doc a -> Text
docText (Doc AnsiStyle -> Text)
-> (CompilerError -> Doc AnsiStyle) -> CompilerError -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CompilerError -> Doc AnsiStyle
prettyCompilerError) (ExceptT CompilerError IO (Warnings, Imports, VNameSource)
 -> ExceptT Text IO (Warnings, Imports, VNameSource))
-> ExceptT CompilerError IO (Warnings, Imports, VNameSource)
-> ExceptT Text IO (Warnings, Imports, VNameSource)
forall a b. (a -> b) -> a -> b
$
      [Name]
-> VFS
-> [FilePath]
-> ExceptT CompilerError IO (Warnings, Imports, VNameSource)
forall (m :: * -> *).
(MonadError CompilerError m, MonadIO m) =>
[Name] -> VFS -> [FilePath] -> m (Warnings, Imports, VNameSource)
readProgramFilesExceptKnown [] VFS
forall a. Monoid a => a
mempty [FilePath
prog]
  (scope, ctx) <-
    withExceptT docText . interpretImports (runScript server $ takeDirectory prog) $
      externaliseLast imports
  ep <-
    maybe (throwError $ "Unknown entry point: " <> nameToText entry) pure $
      M.lookup entry $
        programEntryPoints imports
  pure (src, scope, ctx, map (entryType . entryParamType) $ entryParams ep)

-- | Split the result of a script expression into the inputs of an entry point
-- with these parameters: a tuple with an element for each, unless there is only
-- one.
splitInputs :: [p] -> (a -> Maybe [a]) -> a -> Maybe [a]
splitInputs :: forall p a. [p] -> (a -> Maybe [a]) -> a -> Maybe [a]
splitInputs [p
_] a -> Maybe [a]
_ a
x = [a] -> Maybe [a]
forall a. a -> Maybe a
Just [a
x]
splitInputs [p]
_ a -> Maybe [a]
untuple a
x = a -> Maybe [a]
untuple a
x

-- | Type check a script expression, which must provide the inputs of an entry
-- point with these parameter types.
checkScriptExp :: VNameSource -> Env -> [StructType] -> UncheckedExp -> Either T.Text Exp
checkScriptExp :: VNameSource
-> Env
-> [StructType]
-> UncheckedExp
-> Either Text (ExpBase Info VName)
checkScriptExp VNameSource
src Env
scope [StructType]
param_ts UncheckedExp
e =
  case Imports
-> VNameSource
-> Env
-> UncheckedExp
-> (Warnings, Either TypeError ([TypeParam], ExpBase Info VName))
checkExp [] VNameSource
src Env
scope UncheckedExp
e of
    (Warnings
_, Left TypeError
terr) ->
      Text -> Either Text (ExpBase Info VName)
forall a b. a -> Either a b
Left (Text -> Either Text (ExpBase Info VName))
-> Text -> Either Text (ExpBase Info VName)
forall a b. (a -> b) -> a -> b
$ Doc AnsiStyle -> Text
forall a. Doc a -> Text
docText (Doc AnsiStyle -> Text) -> Doc AnsiStyle -> Text
forall a b. (a -> b) -> a -> b
$ TypeError -> Doc AnsiStyle
prettyTypeError TypeError
terr
    (Warnings
_, Right (TypeParam
_ : [TypeParam]
_, ExpBase Info VName
fexp)) ->
      Text -> Either Text (ExpBase Info VName)
forall a b. a -> Either a b
Left (Text -> Either Text (ExpBase Info VName))
-> Text -> Either Text (ExpBase Info VName)
forall a b. (a -> b) -> a -> b
$ Text
"Ambiguous type of expression: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> StructType -> Text
forall a. Pretty a => a -> Text
prettyText (ExpBase Info VName -> StructType
typeOf ExpBase Info VName
fexp)
    (Warnings
_, Right ([], ExpBase Info VName
fexp))
      | ((StructType -> TypeBase () NoMode)
-> [StructType] -> [TypeBase () NoMode]
forall a b. (a -> b) -> [a] -> [b]
map StructType -> TypeBase () NoMode
forall o. TypeBase (ExpBase Info VName) o -> TypeBase () o
noSizes ([StructType] -> [TypeBase () NoMode])
-> Maybe [StructType] -> Maybe [TypeBase () NoMode]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [StructType]
-> (StructType -> Maybe [StructType])
-> StructType
-> Maybe [StructType]
forall p a. [p] -> (a -> Maybe [a]) -> a -> Maybe [a]
splitInputs [StructType]
param_ts StructType -> Maybe [StructType]
forall dim o. TypeBase dim o -> Maybe [TypeBase dim o]
isTupleRecord StructType
t) Maybe [TypeBase () NoMode] -> Maybe [TypeBase () NoMode] -> Bool
forall a. Eq a => a -> a -> Bool
== [TypeBase () NoMode] -> Maybe [TypeBase () NoMode]
forall a. a -> Maybe a
Just ((StructType -> TypeBase () NoMode)
-> [StructType] -> [TypeBase () NoMode]
forall a b. (a -> b) -> [a] -> [b]
map StructType -> TypeBase () NoMode
forall o. TypeBase (ExpBase Info VName) o -> TypeBase () o
noSizes [StructType]
param_ts) ->
          ExpBase Info VName -> Either Text (ExpBase Info VName)
forall a b. b -> Either a b
Right ExpBase Info VName
fexp
      | Bool
otherwise ->
          Text -> Either Text (ExpBase Info VName)
forall a b. a -> Either a b
Left (Text -> Either Text (ExpBase Info VName))
-> ([Text] -> Text) -> [Text] -> Either Text (ExpBase Info VName)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Text
T.unlines ([Text] -> Either Text (ExpBase Info VName))
-> [Text] -> Either Text (ExpBase Info VName)
forall a b. (a -> b) -> a -> b
$
            [ Text
"Expected input of types: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
T.unwords ((StructType -> Text) -> [StructType] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (TypeBase () NoMode -> Text
forall a. Pretty a => a -> Text
prettyTextOneLine (TypeBase () NoMode -> Text)
-> (StructType -> TypeBase () NoMode) -> StructType -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StructType -> TypeBase () NoMode
forall o. TypeBase (ExpBase Info VName) o -> TypeBase () o
noSizes) [StructType]
param_ts),
              Text
"Provided input of type: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> TypeBase () NoMode -> Text
forall a. Pretty a => a -> Text
prettyTextOneLine (StructType -> TypeBase () NoMode
forall o. TypeBase (ExpBase Info VName) o -> TypeBase () o
noSizes StructType
t)
            ]
      where
        t :: StructType
t = ExpBase Info VName -> StructType
typeOf ExpBase Info VName
fexp

-- | Evaluate a script expression with the interpreter, and make the result
-- available as server-side variables for the inputs of the given entry point.
-- If the entry point has more than one parameter, the value must be a tuple
-- with an element for each. The expression is evaluated in the context of the
-- program, with its entry points run on the server. Returns the variable of
-- each input, taken from the given names: one per input, except that inputs
-- provided with the same server-side value share a variable, named after the
-- first of them.
scriptValuesAsVars ::
  (MonadError T.Text m, MonadIO m) =>
  Server ->
  EntryName ->
  [VarName] ->
  FilePath ->
  UncheckedExp ->
  m [VarName]
scriptValuesAsVars :: forall (m :: * -> *).
(MonadError Text m, MonadIO m) =>
Server -> Text -> [Text] -> FilePath -> UncheckedExp -> m [Text]
scriptValuesAsVars Server
server Text
entry [Text]
names FilePath
prog UncheckedExp
e = do
  ffi_server <- IO Server -> m Server
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Server -> m Server) -> IO Server -> m Server
forall a b. (a -> b) -> a -> b
$ Server -> IO Server
FFI.newServer Server
server
  let entry' = Text -> Name
nameFromText Text
entry
      onServer = (Either FilePath c -> Either Text c)
-> IO (Either FilePath c) -> IO (Either Text c)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((FilePath -> Text) -> Either FilePath c -> Either Text c
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first FilePath -> Text
T.pack) (IO (Either FilePath c) -> IO (Either Text c))
-> (ServerM c -> IO (Either FilePath c))
-> ServerM c
-> IO (Either Text c)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Server -> ServerM c -> IO (Either FilePath c)
forall a. Server -> ServerM a -> IO (Either FilePath a)
FFI.runServerM Server
ffi_server
  r <- liftIO . runExceptT $ do
    (src, scope, ctx, param_ts) <- scriptContext ffi_server prog entry'
    fexp <- liftEither $ checkScriptExp src scope param_ts e
    v <-
      withExceptT (docText . I.prettyInterpreterError) . ExceptT $
        runScript ffi_server (takeDirectory prog) (I.interpretExp ctx fexp)
    -- The type check ensures that the value can be split.
    ExceptT . onServer . FFI.putArgs entry' . fromMaybe [] $
      splitInputs param_ts IV.fromTuple v
  -- Anything not adopted as an input is garbage, now that the interpreter is
  -- done - and if something failed, that is everything.
  released <- liftIO . onServer . FFI.release $ zip (fromRight [] r) names
  liftEither $ r *> released

-- | Make the provided 'Values' available as server-side variables, for use
-- as the inputs of the given entry point, and return the variable of each
-- input. These are the given names, except that several inputs may share a
-- variable (see 'scriptValuesAsVars').  This may involve arbitrary
-- server-side computation.  Error detection... dubious.  The 'FilePath' is
-- the program, relative to which other file paths are read.
valuesAsVars ::
  (MonadError T.Text m, MonadIO m) =>
  Server ->
  EntryName ->
  [(VarName, TypeName)] ->
  FutharkExe ->
  FilePath ->
  Values ->
  m [VarName]
valuesAsVars :: forall (m :: * -> *).
(MonadError Text m, MonadIO m) =>
Server
-> Text
-> [(Text, Text)]
-> FutharkExe
-> FilePath
-> Values
-> m [Text]
valuesAsVars Server
server Text
entry [(Text, Text)]
names_and_types FutharkExe
futhark FilePath
prog Values
values =
  case Values
values of
    InFile FilePath
file
      | FilePath -> FilePath
takeExtension FilePath
file FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
".gz" -> do
          s <- IO (Either DecompressError ByteString)
-> m (Either DecompressError ByteString)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either DecompressError ByteString)
 -> m (Either DecompressError ByteString))
-> IO (Either DecompressError ByteString)
-> m (Either DecompressError ByteString)
forall a b. (a -> b) -> a -> b
$ FilePath -> IO (Either DecompressError ByteString)
readAndDecompress (FilePath -> IO (Either DecompressError ByteString))
-> FilePath -> IO (Either DecompressError ByteString)
forall a b. (a -> b) -> a -> b
$ FilePath
dir FilePath -> FilePath -> FilePath
</> FilePath
file
          case s of
            Left DecompressError
e -> Text -> m ()
forall a. Text -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ FilePath -> Text
forall a. Show a => a -> Text
showText FilePath
file Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> DecompressError -> Text
forall a. Show a => a -> Text
showText DecompressError
e
            Right ByteString
s' -> ByteString -> m ()
forall {m :: * -> *}.
(MonadError Text m, MonadIO m) =>
ByteString -> m ()
restoreBytes ByteString
s'
          pure names
      | Bool
otherwise -> do
          IO (Maybe CmdFailure) -> m ()
forall (m :: * -> *).
(MonadError Text m, MonadIO m) =>
IO (Maybe CmdFailure) -> m ()
cmdMaybe (IO (Maybe CmdFailure) -> m ()) -> IO (Maybe CmdFailure) -> m ()
forall a b. (a -> b) -> a -> b
$ Server -> FilePath -> [(Text, Text)] -> IO (Maybe CmdFailure)
cmdRestore Server
server (FilePath
dir FilePath -> FilePath -> FilePath
</> FilePath
file) [(Text, Text)]
names_and_types
          [Text] -> m [Text]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Text]
names
    GenValues [GenValue]
gens -> do
      Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([GenValue] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [GenValue]
gens Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== [(Text, Text)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Text, Text)]
names_and_types) (m () -> m ()) -> ([Text] -> m ()) -> [Text] -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> m ()
forall a. Text -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Text -> m ()) -> ([Text] -> Text) -> [Text] -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Text
T.unlines ([Text] -> m ()) -> [Text] -> m ()
forall a b. (a -> b) -> a -> b
$
        [ Text
"Expected "
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
showText ([(Text, Text)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Text, Text)]
names_and_types)
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" input values of types",
          Text
"  " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
T.unwords (((Text, Text) -> Text) -> [(Text, Text)] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Text, Text) -> Text
forall a b. (a, b) -> b
snd [(Text, Text)]
names_and_types),
          Text
"Provided "
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
showText ([GenValue] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [GenValue]
gens)
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" input values of types",
          Text
"  " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
T.unwords ((GenValue -> Text) -> [GenValue] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map GenValue -> Text
genValueType [GenValue]
gens)
        ]
      gen_fs <- (GenValue -> m FilePath) -> [GenValue] -> m [FilePath]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (FutharkExe -> FilePath -> GenValue -> m FilePath
forall (m :: * -> *).
MonadIO m =>
FutharkExe -> FilePath -> GenValue -> m FilePath
getGenFile FutharkExe
futhark FilePath
dir) [GenValue]
gens
      forM_ (zip gen_fs names_and_types) $ \(FilePath
file, (Text
v, Text
t)) ->
        IO (Maybe CmdFailure) -> m ()
forall (m :: * -> *).
(MonadError Text m, MonadIO m) =>
IO (Maybe CmdFailure) -> m ()
cmdMaybe (IO (Maybe CmdFailure) -> m ()) -> IO (Maybe CmdFailure) -> m ()
forall a b. (a -> b) -> a -> b
$ Server -> FilePath -> [(Text, Text)] -> IO (Maybe CmdFailure)
cmdRestore Server
server (FilePath
dir FilePath -> FilePath -> FilePath
</> FilePath
file) [(Text
v, Text
t)]
      pure names
    Values [Value]
vs -> do
      let types :: [Text]
types = ((Text, Text) -> Text) -> [(Text, Text)] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Text, Text) -> Text
forall a b. (a, b) -> b
snd [(Text, Text)]
names_and_types
          vs_types :: [Text]
vs_types = (Value -> Text) -> [Value] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (ValueType -> Text
V.valueTypeTextNoDims (ValueType -> Text) -> (Value -> ValueType) -> Value -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> ValueType
V.valueType) [Value]
vs
      Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([Text]
types [Text] -> [Text] -> Bool
forall a. Eq a => a -> a -> Bool
== [Text]
vs_types) (m () -> m ()) -> ([Text] -> m ()) -> [Text] -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> m ()
forall a. Text -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Text -> m ()) -> ([Text] -> Text) -> [Text] -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Text
T.unlines ([Text] -> m ()) -> [Text] -> m ()
forall a b. (a -> b) -> a -> b
$
        [ Text
"Expected input of types: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
T.unwords ((Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Text -> Text
forall a. Pretty a => a -> Text
prettyTextOneLine [Text]
types),
          Text
"Provided input of types: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
T.unwords ((Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Text -> Text
forall a. Pretty a => a -> Text
prettyTextOneLine [Text]
vs_types)
        ]
      ByteString -> m ()
forall {m :: * -> *}.
(MonadError Text m, MonadIO m) =>
ByteString -> m ()
restoreBytes (ByteString -> m ()) -> ByteString -> m ()
forall a b. (a -> b) -> a -> b
$ [ByteString] -> ByteString
forall a. Monoid a => [a] -> a
mconcat ([ByteString] -> ByteString) -> [ByteString] -> ByteString
forall a b. (a -> b) -> a -> b
$ (Value -> ByteString) -> [Value] -> [ByteString]
forall a b. (a -> b) -> [a] -> [b]
map Value -> ByteString
forall a. Binary a => a -> ByteString
Bin.encode [Value]
vs
      [Text] -> m [Text]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Text]
names
    ScriptValues UncheckedExp
e ->
      Server -> Text -> [Text] -> FilePath -> UncheckedExp -> m [Text]
forall (m :: * -> *).
(MonadError Text m, MonadIO m) =>
Server -> Text -> [Text] -> FilePath -> UncheckedExp -> m [Text]
scriptValuesAsVars Server
server Text
entry [Text]
names FilePath
prog UncheckedExp
e
    ScriptFile FilePath
f -> do
      let f' :: FilePath
f' = FilePath
dir FilePath -> FilePath -> FilePath
</> FilePath
f
      e <-
        (SyntaxError -> m UncheckedExp)
-> (UncheckedExp -> m UncheckedExp)
-> Either SyntaxError UncheckedExp
-> m UncheckedExp
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (\(SyntaxError Loc
_ Text
err) -> Text -> m UncheckedExp
forall a. Text -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError Text
err) UncheckedExp -> m UncheckedExp
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either SyntaxError UncheckedExp -> m UncheckedExp)
-> (Text -> Either SyntaxError UncheckedExp)
-> Text
-> m UncheckedExp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Text -> Either SyntaxError UncheckedExp
parseExp FilePath
f'
          (Text -> m UncheckedExp) -> m Text -> m UncheckedExp
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO Text -> m Text
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (FilePath -> IO Text
T.readFile FilePath
f')
      scriptValuesAsVars server entry names prog e
  where
    dir :: FilePath
dir = FilePath -> FilePath
takeDirectory FilePath
prog
    names :: [Text]
names = ((Text, Text) -> Text) -> [(Text, Text)] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Text, Text) -> Text
forall a b. (a, b) -> a
fst [(Text, Text)]
names_and_types
    restoreBytes :: ByteString -> m ()
restoreBytes ByteString
bytes =
      IO (Maybe CmdFailure) -> m ()
forall (m :: * -> *).
(MonadError Text m, MonadIO m) =>
IO (Maybe CmdFailure) -> m ()
cmdMaybe (IO (Maybe CmdFailure) -> m ())
-> ((FilePath -> Handle -> IO (Maybe CmdFailure))
    -> IO (Maybe CmdFailure))
-> (FilePath -> Handle -> IO (Maybe CmdFailure))
-> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath
-> (FilePath -> Handle -> IO (Maybe CmdFailure))
-> IO (Maybe CmdFailure)
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
FilePath -> (FilePath -> Handle -> m a) -> m a
withSystemTempFile FilePath
"futhark-input" ((FilePath -> Handle -> IO (Maybe CmdFailure)) -> m ())
-> (FilePath -> Handle -> IO (Maybe CmdFailure)) -> m ()
forall a b. (a -> b) -> a -> b
$ \FilePath
tmpf Handle
tmpf_h -> do
        Handle -> ByteString -> IO ()
BS.hPutStr Handle
tmpf_h ByteString
bytes
        Handle -> IO ()
hClose Handle
tmpf_h
        Server -> FilePath -> [(Text, Text)] -> IO (Maybe CmdFailure)
cmdRestore Server
server FilePath
tmpf [(Text, Text)]
names_and_types

-- | There is a risk of race conditions when multiple programs have
-- identical 'GenValues'.  In such cases, multiple threads in 'futhark
-- test' might attempt to create the same file (or read from it, while
-- something else is constructing it).  This leads to a mess.  To
-- avoid this, we create a temporary file, and only when it is
-- complete do we move it into place.  It would be better if we could
-- use file locking, but that does not work on some file systems.  The
-- approach here seems robust enough for now, but certainly it could
-- be made even better.  The race condition that remains should mostly
-- result in duplicate work, not crashes or data corruption.
getGenFile :: (MonadIO m) => FutharkExe -> FilePath -> GenValue -> m FilePath
getGenFile :: forall (m :: * -> *).
MonadIO m =>
FutharkExe -> FilePath -> GenValue -> m FilePath
getGenFile FutharkExe
futhark FilePath
dir GenValue
gen = do
  IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ FilePath -> IO ()
ensureCacheDirectory (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
dir FilePath -> FilePath -> FilePath
</> FilePath
"data"
  exists_and_proper_size <-
    IO Bool -> m Bool
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> m Bool) -> IO Bool -> m Bool
forall a b. (a -> b) -> a -> b
$
      FilePath -> IOMode -> (Handle -> IO Bool) -> IO Bool
forall r. FilePath -> IOMode -> (Handle -> IO r) -> IO r
withFile (FilePath
dir FilePath -> FilePath -> FilePath
</> FilePath
file) IOMode
ReadMode ((Integer -> Bool) -> IO Integer -> IO Bool
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== GenValue -> Integer
genFileSize GenValue
gen) (IO Integer -> IO Bool)
-> (Handle -> IO Integer) -> Handle -> IO Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Handle -> IO Integer
hFileSize)
        IO Bool -> (IOError -> IO Bool) -> IO Bool
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` \IOError
ex ->
          if IOError -> Bool
isDoesNotExistError IOError
ex
            then Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
            else IOError -> IO Bool
forall a e. (HasCallStack, Exception e) => e -> a
E.throw IOError
ex
  unless exists_and_proper_size $
    liftIO $ do
      s <- genValues futhark [gen]
      withTempFile (dir </> "data") (genFileName gen) $ \FilePath
tmpfile Handle
h -> do
        Handle -> IO ()
hClose Handle
h -- We will be writing and reading this ourselves.
        FilePath -> ByteString -> IO ()
SBS.writeFile FilePath
tmpfile ByteString
s
        FilePath -> FilePath -> IO ()
renameFile FilePath
tmpfile (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
dir FilePath -> FilePath -> FilePath
</> FilePath
file
  pure file
  where
    file :: FilePath
file = FilePath
"data" FilePath -> FilePath -> FilePath
</> GenValue -> FilePath
genFileName GenValue
gen

getGenBS :: (MonadIO m) => FutharkExe -> FilePath -> GenValue -> m BS.ByteString
getGenBS :: forall (m :: * -> *).
MonadIO m =>
FutharkExe -> FilePath -> GenValue -> m ByteString
getGenBS FutharkExe
futhark FilePath
dir GenValue
gen = IO ByteString -> m ByteString
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ByteString -> m ByteString)
-> (FilePath -> IO ByteString) -> FilePath -> m ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> IO ByteString
BS.readFile (FilePath -> IO ByteString)
-> (FilePath -> FilePath) -> FilePath -> IO ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FilePath
dir FilePath -> FilePath -> FilePath
</>) (FilePath -> m ByteString) -> m FilePath -> m ByteString
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< FutharkExe -> FilePath -> GenValue -> m FilePath
forall (m :: * -> *).
MonadIO m =>
FutharkExe -> FilePath -> GenValue -> m FilePath
getGenFile FutharkExe
futhark FilePath
dir GenValue
gen

genValues :: FutharkExe -> [GenValue] -> IO SBS.ByteString
genValues :: FutharkExe -> [GenValue] -> IO ByteString
genValues (FutharkExe FilePath
futhark) [GenValue]
gens = do
  (code, stdout, stderr) <-
    FilePath
-> [FilePath]
-> ByteString
-> IO (ExitCode, ByteString, ByteString)
readProcessWithExitCode FilePath
futhark (FilePath
"dataset" FilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
: (Text -> FilePath) -> [Text] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map Text -> FilePath
T.unpack [Text]
args) ByteString
forall a. Monoid a => a
mempty
  case code of
    ExitCode
ExitSuccess ->
      ByteString -> IO ByteString
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ByteString
stdout
    ExitFailure Int
e ->
      FilePath -> IO ByteString
forall a. FilePath -> IO a
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail (FilePath -> IO ByteString) -> FilePath -> IO ByteString
forall a b. (a -> b) -> a -> b
$
        FilePath
"'futhark dataset' failed with exit code "
          FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Int -> FilePath
forall a. Show a => a -> FilePath
show Int
e
          FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" and stderr:\n"
          FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ (Word8 -> Char) -> [Word8] -> FilePath
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Char
chr (Int -> Char) -> (Word8 -> Int) -> Word8 -> Char
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral) (ByteString -> [Word8]
SBS.unpack ByteString
stderr)
  where
    args :: [Text]
args = Text
"-b" Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: (GenValue -> [Text]) -> [GenValue] -> [Text]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap GenValue -> [Text]
argForGen [GenValue]
gens
    argForGen :: GenValue -> [Text]
argForGen GenValue
g = [Text
"-g", GenValue -> Text
genValueType GenValue
g]

genFileName :: GenValue -> FilePath
genFileName :: GenValue -> FilePath
genFileName GenValue
gen = Text -> FilePath
T.unpack (GenValue -> Text
genValueType GenValue
gen) FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
".in"

-- | Compute the expected size of the file.  We use this to check
-- whether an existing file is broken/truncated.
genFileSize :: GenValue -> Integer
genFileSize :: GenValue -> Integer
genFileSize = GenValue -> Integer
genSize
  where
    header_size :: Int
header_size = Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
4 -- 'b' <version> <num_dims> <type>
    genSize :: GenValue -> Integer
genSize (GenValue (V.ValueType [Int]
ds PrimType
t)) =
      Int -> Integer
forall a. Integral a => a -> Integer
toInteger (Int -> Integer) -> Int -> Integer
forall a b. (a -> b) -> a -> b
$
        Int
header_size
          Int -> Int -> Int
forall a. Num a => a -> a -> a
+ [Int] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Int]
ds Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
8
          Int -> Int -> Int
forall a. Num a => a -> a -> a
+ [Int] -> Int
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
product [Int]
ds Int -> Int -> Int
forall a. Num a => a -> a -> a
* PrimType -> Int
V.primTypeBytes PrimType
t
    genSize (GenPrim Value
v) =
      Int -> Integer
forall a. Integral a => a -> Integer
toInteger (Int -> Integer) -> Int -> Integer
forall a b. (a -> b) -> a -> b
$ Int
header_size Int -> Int -> Int
forall a. Num a => a -> a -> a
+ [Int] -> Int
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
product (Value -> [Int]
V.valueShape Value
v) Int -> Int -> Int
forall a. Num a => a -> a -> a
* PrimType -> Int
V.primTypeBytes (Value -> PrimType
V.valueElemType Value
v)

-- | When/if generating a reference output file for this run, what
-- should it be called?  Includes the "data/" folder.
testRunReferenceOutput :: FilePath -> T.Text -> TestRun -> FilePath
testRunReferenceOutput :: FilePath -> Text -> TestRun -> FilePath
testRunReferenceOutput FilePath
prog Text
entry TestRun
tr =
  FilePath
"data"
    FilePath -> FilePath -> FilePath
</> FilePath -> FilePath
takeBaseName FilePath
prog
      FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
":"
      FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> Text -> FilePath
T.unpack Text
entry
      FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
"-"
      FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> (Char -> Char) -> FilePath -> FilePath
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
clean (Text -> FilePath
T.unpack (TestRun -> Text
runDescription TestRun
tr))
        FilePath -> FilePath -> FilePath
<.> FilePath
"out"
  where
    clean :: Char -> Char
clean Char
'/' = Char
'_' -- Would this ever happen?
    clean Char
' ' = Char
'_'
    clean Char
c = Char
c

-- | Get the values corresponding to an expected result, if any.
getExpectedResult ::
  (MonadFail m, MonadIO m) =>
  FutharkExe ->
  FilePath ->
  T.Text ->
  TestRun ->
  m (ExpectedResult [V.Value])
getExpectedResult :: forall (m :: * -> *).
(MonadFail m, MonadIO m) =>
FutharkExe
-> FilePath -> Text -> TestRun -> m (ExpectedResult [Value])
getExpectedResult FutharkExe
futhark FilePath
prog Text
entry TestRun
tr =
  case TestRun -> ExpectedResult Success
runExpectedResult TestRun
tr of
    (Succeeds (Just (SuccessValues Values
vals))) ->
      Maybe [Value] -> ExpectedResult [Value]
forall values. Maybe values -> ExpectedResult values
Succeeds (Maybe [Value] -> ExpectedResult [Value])
-> ([Value] -> Maybe [Value]) -> [Value] -> ExpectedResult [Value]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Value] -> Maybe [Value]
forall a. a -> Maybe a
Just ([Value] -> ExpectedResult [Value])
-> m [Value] -> m (ExpectedResult [Value])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FutharkExe -> FilePath -> Values -> m [Value]
forall (m :: * -> *).
(MonadFail m, MonadIO m) =>
FutharkExe -> FilePath -> Values -> m [Value]
getValues FutharkExe
futhark (FilePath -> FilePath
takeDirectory FilePath
prog) Values
vals
    Succeeds (Just Success
SuccessGenerateValues) ->
      FutharkExe
-> FilePath -> Text -> TestRun -> m (ExpectedResult [Value])
forall (m :: * -> *).
(MonadFail m, MonadIO m) =>
FutharkExe
-> FilePath -> Text -> TestRun -> m (ExpectedResult [Value])
getExpectedResult FutharkExe
futhark FilePath
prog Text
entry TestRun
tr'
      where
        tr' :: TestRun
tr' =
          TestRun
tr
            { runExpectedResult =
                Succeeds . Just . SuccessValues . InFile $
                  testRunReferenceOutput prog entry tr
            }
    Succeeds Maybe Success
Nothing ->
      ExpectedResult [Value] -> m (ExpectedResult [Value])
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ExpectedResult [Value] -> m (ExpectedResult [Value]))
-> ExpectedResult [Value] -> m (ExpectedResult [Value])
forall a b. (a -> b) -> a -> b
$ Maybe [Value] -> ExpectedResult [Value]
forall values. Maybe values -> ExpectedResult values
Succeeds Maybe [Value]
forall a. Maybe a
Nothing
    RunTimeFailure ExpectedError
err ->
      ExpectedResult [Value] -> m (ExpectedResult [Value])
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ExpectedResult [Value] -> m (ExpectedResult [Value]))
-> ExpectedResult [Value] -> m (ExpectedResult [Value])
forall a b. (a -> b) -> a -> b
$ ExpectedError -> ExpectedResult [Value]
forall values. ExpectedError -> ExpectedResult values
RunTimeFailure ExpectedError
err

getValueM :: (MonadIO m, MonadError T.Text m) => Server -> VarName -> m V.Value
getValueM :: forall (m :: * -> *).
(MonadIO m, MonadError Text m) =>
Server -> Text -> m Value
getValueM Server
server = (Text -> m Value)
-> (Value -> m Value) -> Either Text Value -> m Value
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either Text -> m Value
forall a. Text -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError Value -> m Value
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either Text Value -> m Value)
-> (Text -> m (Either Text Value)) -> Text -> m Value
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< IO (Either Text Value) -> m (Either Text Value)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either Text Value) -> m (Either Text Value))
-> (Text -> IO (Either Text Value))
-> Text
-> m (Either Text Value)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Server -> Text -> IO (Either Text Value)
getValue Server
server

-- Retrieve components of tuple.
getTupleElems ::
  (MonadIO m, MonadError T.Text m) =>
  Server ->
  VarName ->
  Int ->
  m [V.Value]
getTupleElems :: forall (m :: * -> *).
(MonadIO m, MonadError Text m) =>
Server -> Text -> Int -> m [Value]
getTupleElems Server
server Text
v Int
k = do
  -- We construct intermediate variables for the elements that we free at the
  -- end. However, they are leaked if we have a failure along the way, and
  -- getValueM may fail. This is not a big problem in practice we hope, as a
  -- failing test results in the server being shut down soon after.
  let is :: [Int]
is = [Int
0 .. Int
k Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1]
      elem_vs :: [Text]
elem_vs = [Text
v Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"_elem" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
showText Int
i | Int
i <- [Int]
is]
  [(Int, Text)] -> ((Int, Text) -> m ()) -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ([Int] -> [Text] -> [(Int, Text)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int]
is [Text]
elem_vs) (((Int, Text) -> m ()) -> m ()) -> ((Int, Text) -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \(Int
i, Text
elem_v) ->
    IO (Maybe CmdFailure) -> m ()
forall (m :: * -> *).
(MonadError Text m, MonadIO m) =>
IO (Maybe CmdFailure) -> m ()
cmdMaybe (IO (Maybe CmdFailure) -> m ()) -> IO (Maybe CmdFailure) -> m ()
forall a b. (a -> b) -> a -> b
$ Server -> Text -> Text -> Text -> IO (Maybe CmdFailure)
cmdProject Server
server Text
elem_v Text
v (Int -> Text
forall a. Show a => a -> Text
showText Int
i)
  (Text -> m Value) -> [Text] -> m [Value]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Server -> Text -> m Value
forall (m :: * -> *).
(MonadIO m, MonadError Text m) =>
Server -> Text -> m Value
getValueM Server
server) [Text]
elem_vs m [Value] -> m () -> m [Value]
forall a b. m a -> m b -> m a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* IO (Maybe CmdFailure) -> m ()
forall (m :: * -> *).
(MonadError Text m, MonadIO m) =>
IO (Maybe CmdFailure) -> m ()
cmdMaybe (Server -> [Text] -> IO (Maybe CmdFailure)
cmdFree Server
server [Text]
elem_vs)

isServerTuple ::
  (MonadIO m) =>
  Server ->
  TypeName ->
  m (Maybe [TypeName])
isServerTuple :: forall (m :: * -> *).
MonadIO m =>
Server -> Text -> m (Maybe [Text])
isServerTuple Server
server Text
v_t = do
  x <- IO (Either CmdFailure [Field]) -> m (Either CmdFailure [Field])
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either CmdFailure [Field]) -> m (Either CmdFailure [Field]))
-> IO (Either CmdFailure [Field]) -> m (Either CmdFailure [Field])
forall a b. (a -> b) -> a -> b
$ Server -> Text -> IO (Either CmdFailure [Field])
cmdFields Server
server Text
v_t
  case x of
    Right [Field]
fields -> do
      let onField :: Field -> (Name, Text)
onField Field
f = (Text -> Name
nameFromText (Text -> Name) -> Text -> Name
forall a b. (a -> b) -> a -> b
$ Field -> Text
fieldName Field
f, Field -> Text
fieldType Field
f)
      case Map Name Text -> Maybe [Text]
forall a. Map Name a -> Maybe [a]
areTupleFields (Map Name Text -> Maybe [Text]) -> Map Name Text -> Maybe [Text]
forall a b. (a -> b) -> a -> b
$ [(Name, Text)] -> Map Name Text
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(Name, Text)] -> Map Name Text)
-> [(Name, Text)] -> Map Name Text
forall a b. (a -> b) -> a -> b
$ (Field -> (Name, Text)) -> [Field] -> [(Name, Text)]
forall a b. (a -> b) -> [a] -> [b]
map Field -> (Name, Text)
onField [Field]
fields of
        Just [Text]
ts -> Maybe [Text] -> m (Maybe [Text])
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe [Text] -> m (Maybe [Text]))
-> Maybe [Text] -> m (Maybe [Text])
forall a b. (a -> b) -> a -> b
$ [Text] -> Maybe [Text]
forall a. a -> Maybe a
Just [Text]
ts
        Maybe [Text]
Nothing -> Maybe [Text] -> m (Maybe [Text])
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe [Text]
forall a. Maybe a
Nothing
    Left CmdFailure
_ -> Maybe [Text] -> m (Maybe [Text])
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe [Text]
forall a. Maybe a
Nothing

-- | Read the given variable from a running server. As a special case, if the
-- result is a tuple, we unpack it and return the elements individually.
readResults ::
  (MonadIO m, MonadError T.Text m) =>
  Server ->
  (VarName, TypeName) ->
  m [V.Value]
readResults :: forall (m :: * -> *).
(MonadIO m, MonadError Text m) =>
Server -> (Text, Text) -> m [Value]
readResults Server
server (Text
v, Text
v_t) = do
  maybe_elems <- Server -> Text -> m (Maybe [Text])
forall (m :: * -> *).
MonadIO m =>
Server -> Text -> m (Maybe [Text])
isServerTuple Server
server Text
v_t
  case maybe_elems of
    Just [Text]
ts ->
      Server -> Text -> Int -> m [Value]
forall (m :: * -> *).
(MonadIO m, MonadError Text m) =>
Server -> Text -> Int -> m [Value]
getTupleElems Server
server Text
v (Int -> m [Value]) -> Int -> m [Value]
forall a b. (a -> b) -> a -> b
$ [Text] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Text]
ts
    Maybe [Text]
Nothing ->
      Value -> [Value]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> [Value]) -> m Value -> m [Value]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Server -> Text -> m Value
forall (m :: * -> *).
(MonadIO m, MonadError Text m) =>
Server -> Text -> m Value
getValueM Server
server Text
v

-- | Call an entry point. Returns server variable storing the result.
callEntry ::
  (MonadIO m, MonadError T.Text m) =>
  FutharkExe ->
  Server ->
  FilePath ->
  EntryName ->
  Values ->
  m VarName
callEntry :: forall (m :: * -> *).
(MonadIO m, MonadError Text m) =>
FutharkExe -> Server -> FilePath -> Text -> Values -> m Text
callEntry FutharkExe
futhark Server
server FilePath
prog Text
entry Values
input = do
  input_types <- IO (Either CmdFailure [InputType]) -> m [InputType]
forall (m :: * -> *) a.
(MonadError Text m, MonadIO m) =>
IO (Either CmdFailure a) -> m a
cmdEither (IO (Either CmdFailure [InputType]) -> m [InputType])
-> IO (Either CmdFailure [InputType]) -> m [InputType]
forall a b. (a -> b) -> a -> b
$ Server -> Text -> IO (Either CmdFailure [InputType])
cmdInputs Server
server Text
entry
  let out = Text
"out"
      ins = [Text
"in" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
showText Int
i | Int
i <- [Int
0 .. [InputType] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [InputType]
input_types Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1]]
      ins_and_types = [Text] -> [Text] -> [(Text, Text)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Text]
ins ((InputType -> Text) -> [InputType] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map InputType -> Text
inputType [InputType]
input_types)
  ins' <- valuesAsVars server entry ins_and_types futhark prog input
  _ <- cmdEither $ cmdCall server entry out ins'
  cmdMaybe $ cmdFree server $ nubOrd ins'
  pure out

-- | Ensure that any reference output files exist, or create them (by
-- compiling the program with the reference compiler and running it on
-- the input) if necessary.
ensureReferenceOutput ::
  (MonadIO m, MonadError T.Text m) =>
  Maybe Int ->
  FutharkExe ->
  String ->
  FilePath ->
  [InputOutputs] ->
  m ()
ensureReferenceOutput :: forall (m :: * -> *).
(MonadIO m, MonadError Text m) =>
Maybe Int
-> FutharkExe -> FilePath -> FilePath -> [InputOutputs] -> m ()
ensureReferenceOutput Maybe Int
concurrency FutharkExe
futhark FilePath
compiler FilePath
prog [InputOutputs]
ios = do
  missing <- ((Text, TestRun) -> m Bool)
-> [(Text, TestRun)] -> m [(Text, TestRun)]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM (Text, TestRun) -> m Bool
forall {m :: * -> *}. MonadIO m => (Text, TestRun) -> m Bool
isReferenceMissing ([(Text, TestRun)] -> m [(Text, TestRun)])
-> [(Text, TestRun)] -> m [(Text, TestRun)]
forall a b. (a -> b) -> a -> b
$ (InputOutputs -> [(Text, TestRun)])
-> [InputOutputs] -> [(Text, TestRun)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap InputOutputs -> [(Text, TestRun)]
entryAndRuns [InputOutputs]
ios

  unless (null missing) $ do
    void $ compileProgram ["--server"] futhark compiler prog

    res <- liftIO . flip (pmapIO concurrency) missing $ \(Text
entry, TestRun
tr) ->
      ServerCfg -> (Server -> IO (Either Text ())) -> IO (Either Text ())
forall a. ServerCfg -> (Server -> IO a) -> IO a
withServer ServerCfg
server_cfg ((Server -> IO (Either Text ())) -> IO (Either Text ()))
-> (Server -> IO (Either Text ())) -> IO (Either Text ())
forall a b. (a -> b) -> a -> b
$ \Server
server -> ExceptT Text IO () -> IO (Either Text ())
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT Text IO () -> IO (Either Text ()))
-> ExceptT Text IO () -> IO (Either Text ())
forall a b. (a -> b) -> a -> b
$ do
        out <- FutharkExe
-> Server -> FilePath -> Text -> Values -> ExceptT Text IO Text
forall (m :: * -> *).
(MonadIO m, MonadError Text m) =>
FutharkExe -> Server -> FilePath -> Text -> Values -> m Text
callEntry FutharkExe
futhark Server
server FilePath
prog Text
entry (Values -> ExceptT Text IO Text) -> Values -> ExceptT Text IO Text
forall a b. (a -> b) -> a -> b
$ TestRun -> Values
runInput TestRun
tr
        let f = Text -> TestRun -> FilePath
file Text
entry TestRun
tr
        liftIO $ ensureCacheDirectory $ takeDirectory f
        cmdMaybe $ cmdStore server f [out]
        cmdMaybe $ cmdFree server [out]
    either throwError (const (pure ())) (sequence_ res)
  where
    server_cfg :: ServerCfg
server_cfg = FilePath -> [FilePath] -> ServerCfg
futharkServerCfg (FilePath
"." FilePath -> FilePath -> FilePath
</> FilePath -> FilePath
dropExtension FilePath
prog) []

    file :: Text -> TestRun -> FilePath
file Text
entry TestRun
tr =
      FilePath -> FilePath
takeDirectory FilePath
prog FilePath -> FilePath -> FilePath
</> FilePath -> Text -> TestRun -> FilePath
testRunReferenceOutput FilePath
prog Text
entry TestRun
tr

    entryAndRuns :: InputOutputs -> [(Text, TestRun)]
entryAndRuns (InputOutputs Text
entry [TestRun]
rts) = (TestRun -> (Text, TestRun)) -> [TestRun] -> [(Text, TestRun)]
forall a b. (a -> b) -> [a] -> [b]
map (Text
entry,) [TestRun]
rts

    isReferenceMissing :: (Text, TestRun) -> m Bool
isReferenceMissing (Text
entry, TestRun
tr)
      | Succeeds (Just Success
SuccessGenerateValues) <- TestRun -> ExpectedResult Success
runExpectedResult TestRun
tr =
          IO Bool -> m Bool
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> m Bool) -> IO Bool -> m Bool
forall a b. (a -> b) -> a -> b
$
            (UTCTime -> UTCTime -> Bool
forall a. Ord a => a -> a -> Bool
(<) (UTCTime -> UTCTime -> Bool) -> IO UTCTime -> IO (UTCTime -> Bool)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> IO UTCTime
getModificationTime (Text -> TestRun -> FilePath
file Text
entry TestRun
tr) IO (UTCTime -> Bool) -> IO UTCTime -> IO Bool
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> FilePath -> IO UTCTime
getModificationTime FilePath
prog)
              IO Bool -> (IOError -> IO Bool) -> IO Bool
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` (\IOError
e -> if IOError -> Bool
isDoesNotExistError IOError
e then Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True else IOError -> IO Bool
forall a e. (HasCallStack, Exception e) => e -> a
E.throw IOError
e)
      | Bool
otherwise =
          Bool -> m Bool
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False

-- | Determine the @--tuning@ options to pass to the program.  The first
-- argument is the extension of the tuning file, or 'Nothing' if none
-- should be used.
determineTuning :: (MonadIO m) => Maybe FilePath -> FilePath -> m ([String], String)
determineTuning :: forall (m :: * -> *).
MonadIO m =>
Maybe FilePath -> FilePath -> m ([FilePath], FilePath)
determineTuning Maybe FilePath
Nothing FilePath
_ = ([FilePath], FilePath) -> m ([FilePath], FilePath)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([], FilePath
forall a. Monoid a => a
mempty)
determineTuning (Just FilePath
ext) FilePath
program = do
  exists <- IO Bool -> m Bool
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> m Bool) -> IO Bool -> m Bool
forall a b. (a -> b) -> a -> b
$ FilePath -> IO Bool
doesFileExist (FilePath
program FilePath -> FilePath -> FilePath
<.> FilePath
ext)
  if exists
    then
      pure
        ( ["--tuning", program <.> ext],
          " (using " <> takeFileName (program <.> ext) <> ")"
        )
    else pure ([], " (no tuning file)")

-- | Determine the @--cache-file@ options to pass to the program.  The
-- first argument is the extension of the cache file, or 'Nothing' if
-- none should be used.
determineCache :: Maybe FilePath -> FilePath -> [String]
determineCache :: Maybe FilePath -> FilePath -> [FilePath]
determineCache Maybe FilePath
Nothing FilePath
_ = []
determineCache (Just FilePath
ext) FilePath
program = [FilePath
"--cache-file", FilePath
program FilePath -> FilePath -> FilePath
<.> FilePath
ext]

-- | Check that the result is as expected, and write files and throw
-- an error if not.
checkResult ::
  (MonadError T.Text m, MonadIO m) =>
  FilePath ->
  [V.Value] ->
  [V.Value] ->
  m ()
checkResult :: forall (m :: * -> *).
(MonadError Text m, MonadIO m) =>
FilePath -> [Value] -> [Value] -> m ()
checkResult FilePath
program [Value]
expected_vs [Value]
actual_vs =
  case Tolerance -> [Value] -> [Value] -> [Mismatch]
V.compareSeveralValues (Double -> Tolerance
V.Tolerance Double
0.002) [Value]
actual_vs [Value]
expected_vs of
    Mismatch
mismatch : [Mismatch]
mismatches -> do
      let actualf :: FilePath
actualf = FilePath
program FilePath -> FilePath -> FilePath
<.> FilePath
"actual"
          expectedf :: FilePath
expectedf = FilePath
program FilePath -> FilePath -> FilePath
<.> FilePath
"expected"
      IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ FilePath -> ByteString -> IO ()
BS.writeFile FilePath
actualf (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ [ByteString] -> ByteString
forall a. Monoid a => [a] -> a
mconcat ([ByteString] -> ByteString) -> [ByteString] -> ByteString
forall a b. (a -> b) -> a -> b
$ (Value -> ByteString) -> [Value] -> [ByteString]
forall a b. (a -> b) -> [a] -> [b]
map Value -> ByteString
forall a. Binary a => a -> ByteString
Bin.encode [Value]
actual_vs
      IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ FilePath -> ByteString -> IO ()
BS.writeFile FilePath
expectedf (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ [ByteString] -> ByteString
forall a. Monoid a => [a] -> a
mconcat ([ByteString] -> ByteString) -> [ByteString] -> ByteString
forall a b. (a -> b) -> a -> b
$ (Value -> ByteString) -> [Value] -> [ByteString]
forall a b. (a -> b) -> [a] -> [b]
map Value -> ByteString
forall a. Binary a => a -> ByteString
Bin.encode [Value]
expected_vs
      Text -> m ()
forall a. Text -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$
        FilePath -> Text
T.pack FilePath
actualf
          Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" and "
          Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack FilePath
expectedf
          Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" do not match:\n"
          Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Mismatch -> Text
forall a. Show a => a -> Text
showText Mismatch
mismatch
          Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> if [Mismatch] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Mismatch]
mismatches
            then Text
forall a. Monoid a => a
mempty
            else Text
"\n...and " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Pretty a => a -> Text
prettyText ([Mismatch] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Mismatch]
mismatches) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" other mismatches."
    [] ->
      () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()