-- | 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.Spec,
    valuesFromByteString,
    FutharkExe (..),
    getValues,
    getValuesBS,
    valuesAsVars,
    V.compareValues,
    checkResult,
    testRunReferenceOutput,
    getExpectedResult,
    compileProgram,
    runProgram,
    readResults,
    ensureReferenceOutput,
    determineTuning,
    determineCache,
    binaryName,
    futharkServerCfg,
    V.Mismatch,
    V.Value,
    V.valueText,
  )
where

import Codec.Compression.GZip
import Codec.Compression.Zlib.Internal (DecompressError)
import Control.Applicative
import Control.Exception (catch)
import Control.Exception.Base qualified as E
import Control.Monad
import Control.Monad.Except
import Data.Binary qualified as Bin
import Data.ByteString qualified as SBS
import Data.ByteString.Lazy qualified as BS
import Data.Char
import Data.Maybe
import Data.Set qualified as S
import Data.Text qualified as T
import Data.Text.Encoding qualified as T
import Data.Text.IO qualified as T
import Futhark.Script qualified as Script
import Futhark.Server
import Futhark.Server.Values
import Futhark.Test.Spec
import Futhark.Test.Values qualified as V
import Futhark.Util (isEnvVarAtLeast, pmapIO)
import Futhark.Util.Pretty (prettyText, prettyTextOneLine)
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 =
  forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ FilePath
"Cannot parse values from '" forall a. [a] -> [a] -> [a]
++ FilePath
srcname forall a. [a] -> [a] -> [a]
++ FilePath
"'") forall a b. b -> Either a b
Right forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Maybe [Value]
V.readValues

-- | The @futhark@ executable we are using.  This is merely a wrapper
-- around the underlying file path, because we will be using a lot of
-- different file paths here, and it is easy to mix them up.
newtype FutharkExe = FutharkExe FilePath
  deriving (FutharkExe -> FutharkExe -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: FutharkExe -> FutharkExe -> Bool
$c/= :: FutharkExe -> FutharkExe -> Bool
== :: FutharkExe -> FutharkExe -> Bool
$c== :: FutharkExe -> FutharkExe -> Bool
Eq, Eq FutharkExe
FutharkExe -> FutharkExe -> Bool
FutharkExe -> FutharkExe -> Ordering
FutharkExe -> FutharkExe -> FutharkExe
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: FutharkExe -> FutharkExe -> FutharkExe
$cmin :: FutharkExe -> FutharkExe -> FutharkExe
max :: FutharkExe -> FutharkExe -> FutharkExe
$cmax :: FutharkExe -> FutharkExe -> FutharkExe
>= :: FutharkExe -> FutharkExe -> Bool
$c>= :: FutharkExe -> FutharkExe -> Bool
> :: FutharkExe -> FutharkExe -> Bool
$c> :: FutharkExe -> FutharkExe -> Bool
<= :: FutharkExe -> FutharkExe -> Bool
$c<= :: FutharkExe -> FutharkExe -> Bool
< :: FutharkExe -> FutharkExe -> Bool
$c< :: FutharkExe -> FutharkExe -> Bool
compare :: FutharkExe -> FutharkExe -> Ordering
$ccompare :: FutharkExe -> FutharkExe -> Ordering
Ord, Int -> FutharkExe -> FilePath -> FilePath
[FutharkExe] -> FilePath -> FilePath
FutharkExe -> FilePath
forall a.
(Int -> a -> FilePath -> FilePath)
-> (a -> FilePath) -> ([a] -> FilePath -> FilePath) -> Show a
showList :: [FutharkExe] -> FilePath -> FilePath
$cshowList :: [FutharkExe] -> FilePath -> FilePath
show :: FutharkExe -> FilePath
$cshow :: FutharkExe -> FilePath
showsPrec :: Int -> FutharkExe -> FilePath -> FilePath
$cshowsPrec :: Int -> FutharkExe -> FilePath -> FilePath
Show)

-- | 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) = forall (f :: * -> *) a. Applicative f => a -> f a
pure [Value]
vs
getValues FutharkExe
futhark FilePath
dir Values
v = do
  ByteString
s <- forall (m :: * -> *).
(MonadFail m, MonadIO m) =>
FutharkExe -> FilePath -> Values -> m ByteString
getValuesBS FutharkExe
futhark FilePath
dir Values
v
  case FilePath -> ByteString -> Either FilePath [Value]
valuesFromByteString (Values -> FilePath
fileName Values
v) ByteString
s of
    Left FilePath
e -> forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail FilePath
e
    Right [Value]
vs -> 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
"<FutharkScript 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 = forall e a. Exception e => IO a -> IO (Either e a)
E.try forall a b. (a -> b) -> a -> b
$ do
  ByteString
s <- FilePath -> IO ByteString
BS.readFile FilePath
file
  forall a. a -> IO a
E.evaluate forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
decompress ByteString
s

-- | Extract a prettyString 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) =
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
BS.fromStrict forall a b. (a -> b) -> a -> b
$ Text -> ByteString
T.encodeUtf8 forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.unlines forall a b. (a -> b) -> a -> b
$ 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" -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
      Either DecompressError ByteString
s <- FilePath -> IO (Either DecompressError ByteString)
readAndDecompress FilePath
file'
      case Either DecompressError ByteString
s of
        Left DecompressError
e -> forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> FilePath
show FilePath
file forall a. [a] -> [a] -> [a]
++ FilePath
": " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> FilePath
show DecompressError
e
        Right ByteString
s' -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ByteString
s'
    FilePath
_ -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO 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) =
  forall a. Monoid a => [a] -> a
mconcat forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall (m :: * -> *).
MonadIO m =>
FutharkExe -> FilePath -> GenValue -> m ByteString
getGenBS FutharkExe
futhark FilePath
dir) [GenValue]
gens
getValuesBS FutharkExe
_ FilePath
_ (ScriptValues Exp
e) =
  forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail forall a b. (a -> b) -> a -> b
$
    FilePath
"Cannot get values from FutharkScript expression: "
      forall a. Semigroup a => a -> a -> a
<> Text -> FilePath
T.unpack (forall a. Pretty a => a -> Text
prettyTextOneLine Exp
e)
getValuesBS FutharkExe
_ FilePath
_ (ScriptFile FilePath
f) =
  forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail forall a b. (a -> b) -> a -> b
$ FilePath
"Cannot get values from FutharkScript file: " forall a. Semigroup a => a -> a -> a
<> FilePath
f

valueAsVar ::
  (MonadError T.Text m, MonadIO m) =>
  Server ->
  VarName ->
  V.Value ->
  m ()
valueAsVar :: forall (m :: * -> *).
(MonadError Text m, MonadIO m) =>
Server -> Text -> Value -> m ()
valueAsVar Server
server Text
v Value
val =
  forall (m :: * -> *).
(MonadError Text m, MonadIO m) =>
IO (Maybe CmdFailure) -> m ()
cmdMaybe forall a b. (a -> b) -> a -> b
$ Server -> Text -> Value -> IO (Maybe CmdFailure)
putValue Server
server Text
v Value
val

-- Frees the expression on error.
scriptValueAsVars ::
  (MonadError T.Text m, MonadIO m) =>
  Server ->
  [(VarName, TypeName)] ->
  Script.ExpValue ->
  m ()
scriptValueAsVars :: forall (m :: * -> *).
(MonadError Text m, MonadIO m) =>
Server -> [(Text, Text)] -> ExpValue -> m ()
scriptValueAsVars Server
server [(Text, Text)]
names_and_types ExpValue
val
  | [ExpValue]
vals <- forall v. Compound v -> [Compound v]
V.unCompound ExpValue
val,
    forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Text, Text)]
names_and_types forall a. Eq a => a -> a -> Bool
== forall (t :: * -> *) a. Foldable t => t a -> Int
length [ExpValue]
vals,
    Just [m ()]
loads <- forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM forall {m :: * -> *}.
(MonadError Text m, MonadIO m) =>
(Text, Text) -> ExpValue -> Maybe (m ())
f [(Text, Text)]
names_and_types [ExpValue]
vals =
      forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ [m ()]
loads
  where
    f :: (Text, Text) -> ExpValue -> Maybe (m ())
f (Text
v, Text
t0) (V.ValueAtom (Script.SValue Text
t1 ValOrVar
sval))
      | Text
t0 forall a. Eq a => a -> a -> Bool
== Text
t1 =
          forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ case ValOrVar
sval of
            Script.VVar Text
oldname ->
              forall (m :: * -> *).
(MonadError Text m, MonadIO m) =>
IO (Maybe CmdFailure) -> m ()
cmdMaybe forall a b. (a -> b) -> a -> b
$ Server -> Text -> Text -> IO (Maybe CmdFailure)
cmdRename Server
server Text
oldname Text
v
            Script.VVal Value
sval' ->
              forall (m :: * -> *).
(MonadError Text m, MonadIO m) =>
Server -> Text -> Value -> m ()
valueAsVar Server
server Text
v Value
sval'
    f (Text, Text)
_ ExpValue
_ = forall a. Maybe a
Nothing
scriptValueAsVars Server
server [(Text, Text)]
names_and_types ExpValue
val = do
  forall (m :: * -> *).
(MonadError Text m, MonadIO m) =>
IO (Maybe CmdFailure) -> m ()
cmdMaybe forall a b. (a -> b) -> a -> b
$ Server -> [Text] -> IO (Maybe CmdFailure)
cmdFree Server
server forall a b. (a -> b) -> a -> b
$ forall a. Set a -> [a]
S.toList forall a b. (a -> b) -> a -> b
$ ExpValue -> Set Text
Script.serverVarsInValue ExpValue
val
  forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$
    Text
"Expected value of type: "
      forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
prettyTextOneLine (forall v. [Compound v] -> Compound v
V.mkCompound (forall a b. (a -> b) -> [a] -> [b]
map (forall v. v -> Compound v
V.ValueAtom forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) [(Text, Text)]
names_and_types))
      forall a. Semigroup a => a -> a -> a
<> Text
"\nBut got value of type:  "
      forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
prettyTextOneLine (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall v. ScriptValue v -> ScriptValueType
Script.scriptValueType ExpValue
val)
      forall a. Semigroup a => a -> a -> a
<> Text
notes
  where
    notes :: Text
notes = forall a. Monoid a => [a] -> a
mconcat forall a b. (a -> b) -> a -> b
$ forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe forall {a}. (a, Text) -> Maybe Text
note [(Text, Text)]
names_and_types
    note :: (a, Text) -> Maybe Text
note (a
_, Text
t)
      | Text
"(" Text -> Text -> Bool
`T.isPrefixOf` Text
t =
          forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$
            Text
"\nNote: expected type "
              forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
prettyText Text
t
              forall a. Semigroup a => a -> a -> a
<> Text
" is an opaque tuple that cannot be constructed\n"
              forall a. Semigroup a => a -> a -> a
<> Text
"in FutharkScript.  Consider using type annotations to give it a proper name."
      | Text
"{" Text -> Text -> Bool
`T.isPrefixOf` Text
t =
          forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$
            Text
"\nNote: expected type "
              forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
prettyText Text
t
              forall a. Semigroup a => a -> a -> a
<> Text
" is an opaque record that cannot be constructed\n"
              forall a. Semigroup a => a -> a -> a
<> Text
"in FutharkScript.  Consider using type annotations to give it a proper name."
      | Bool
otherwise =
          forall a. Maybe a
Nothing

-- | Make the provided 'Values' available as server-side variables.
-- This may involve arbitrary server-side computation.  Error
-- detection... dubious.
valuesAsVars ::
  (MonadError T.Text m, MonadIO m) =>
  Server ->
  [(VarName, TypeName)] ->
  FutharkExe ->
  FilePath ->
  Values ->
  m ()
valuesAsVars :: forall (m :: * -> *).
(MonadError Text m, MonadIO m) =>
Server
-> [(Text, Text)] -> FutharkExe -> FilePath -> Values -> m ()
valuesAsVars Server
server [(Text, Text)]
names_and_types FutharkExe
_ FilePath
dir (InFile FilePath
file)
  | FilePath -> FilePath
takeExtension FilePath
file forall a. Eq a => a -> a -> Bool
== FilePath
".gz" = do
      Either DecompressError ByteString
s <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ FilePath -> IO (Either DecompressError ByteString)
readAndDecompress forall a b. (a -> b) -> a -> b
$ FilePath
dir FilePath -> FilePath -> FilePath
</> FilePath
file
      case Either DecompressError ByteString
s of
        Left DecompressError
e ->
          forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ FilePath -> Text
T.pack forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> FilePath
show FilePath
file forall a. Semigroup a => a -> a -> a
<> FilePath
": " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> FilePath
show DecompressError
e
        Right ByteString
s' ->
          forall (m :: * -> *).
(MonadError Text m, MonadIO m) =>
IO (Maybe CmdFailure) -> m ()
cmdMaybe forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
FilePath -> (FilePath -> Handle -> m a) -> m a
withSystemTempFile FilePath
"futhark-input" forall a b. (a -> b) -> a -> b
$ \FilePath
tmpf Handle
tmpf_h -> do
            Handle -> ByteString -> IO ()
BS.hPutStr Handle
tmpf_h ByteString
s'
            Handle -> IO ()
hClose Handle
tmpf_h
            Server -> FilePath -> [(Text, Text)] -> IO (Maybe CmdFailure)
cmdRestore Server
server FilePath
tmpf [(Text, Text)]
names_and_types
  | Bool
otherwise =
      forall (m :: * -> *).
(MonadError Text m, MonadIO m) =>
IO (Maybe CmdFailure) -> m ()
cmdMaybe 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
valuesAsVars Server
server [(Text, Text)]
names_and_types FutharkExe
futhark FilePath
dir (GenValues [GenValue]
gens) = do
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Int
length [GenValue]
gens forall a. Eq a => a -> a -> Bool
== forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Text, Text)]
names_and_types) forall a b. (a -> b) -> a -> b
$
    forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError Text
"Mismatch between number of expected and generated values."
  [FilePath]
gen_fs <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall (m :: * -> *).
MonadIO m =>
FutharkExe -> FilePath -> GenValue -> m FilePath
getGenFile FutharkExe
futhark FilePath
dir) [GenValue]
gens
  forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (forall a b. [a] -> [b] -> [(a, b)]
zip [FilePath]
gen_fs [(Text, Text)]
names_and_types) forall a b. (a -> b) -> a -> b
$ \(FilePath
file, (Text
v, Text
t)) ->
    forall (m :: * -> *).
(MonadError Text m, MonadIO m) =>
IO (Maybe CmdFailure) -> m ()
cmdMaybe 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)]
valuesAsVars Server
server [(Text, Text)]
names_and_types FutharkExe
_ FilePath
_ (Values [Value]
vs) = do
  let types :: [Text]
types = forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd [(Text, Text)]
names_and_types
      vs_types :: [Text]
vs_types = forall a b. (a -> b) -> [a] -> [b]
map (ValueType -> Text
V.valueTypeTextNoDims forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> ValueType
V.valueType) [Value]
vs
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([Text]
types forall a. Eq a => a -> a -> Bool
== [Text]
vs_types) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Text
T.unlines forall a b. (a -> b) -> a -> b
$
    [ Text
"Expected input of types: " forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
T.unwords (forall a b. (a -> b) -> [a] -> [b]
map forall a. Pretty a => a -> Text
prettyTextOneLine [Text]
types),
      Text
"Provided input of types: " forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
T.unwords (forall a b. (a -> b) -> [a] -> [b]
map forall a. Pretty a => a -> Text
prettyTextOneLine [Text]
vs_types)
    ]
  forall (m :: * -> *).
(MonadError Text m, MonadIO m) =>
IO (Maybe CmdFailure) -> m ()
cmdMaybe forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
FilePath -> (FilePath -> Handle -> m a) -> m a
withSystemTempFile FilePath
"futhark-input" forall a b. (a -> b) -> a -> b
$ \FilePath
tmpf Handle
tmpf_h -> do
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Handle -> ByteString -> IO ()
BS.hPutStr Handle
tmpf_h forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Binary a => a -> ByteString
Bin.encode) [Value]
vs
    Handle -> IO ()
hClose Handle
tmpf_h
    Server -> FilePath -> [(Text, Text)] -> IO (Maybe CmdFailure)
cmdRestore Server
server FilePath
tmpf [(Text, Text)]
names_and_types
valuesAsVars Server
server [(Text, Text)]
names_and_types FutharkExe
_ FilePath
_ (ScriptValues Exp
e) =
  forall (m :: * -> *) a.
MonadIO m =>
Server -> (ScriptServer -> m a) -> m a
Script.withScriptServer' Server
server forall a b. (a -> b) -> a -> b
$ \ScriptServer
server' -> do
    ExpValue
e_v <- forall (m :: * -> *).
(MonadError Text m, MonadIO m) =>
EvalBuiltin m -> ScriptServer -> Exp -> m ExpValue
Script.evalExp forall {e} {m :: * -> *} {p} {a}.
(MonadError e m, Semigroup e, IsString e) =>
e -> p -> m a
noBuiltin ScriptServer
server' Exp
e
    forall (m :: * -> *).
(MonadError Text m, MonadIO m) =>
Server -> [(Text, Text)] -> ExpValue -> m ()
scriptValueAsVars Server
server [(Text, Text)]
names_and_types ExpValue
e_v
  where
    noBuiltin :: e -> p -> m a
noBuiltin e
f p
_ = do
      forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ e
"Unknown builtin procedure: " forall a. Semigroup a => a -> a -> a
<> e
f
valuesAsVars Server
server [(Text, Text)]
names_and_types FutharkExe
futhark FilePath
dir (ScriptFile FilePath
f) = do
  Exp
e <-
    forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Text -> Either Text Exp
Script.parseExpFromText FilePath
f
      forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (FilePath -> IO Text
T.readFile (FilePath
dir FilePath -> FilePath -> FilePath
</> FilePath
f))
  forall (m :: * -> *).
(MonadError Text m, MonadIO m) =>
Server
-> [(Text, Text)] -> FutharkExe -> FilePath -> Values -> m ()
valuesAsVars Server
server [(Text, Text)]
names_and_types FutharkExe
futhark FilePath
dir (Exp -> Values
ScriptValues Exp
e)

-- | 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
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
True forall a b. (a -> b) -> a -> b
$ FilePath
dir FilePath -> FilePath -> FilePath
</> FilePath
"data"
  Bool
exists_and_proper_size <-
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$
      forall r. FilePath -> IOMode -> (Handle -> IO r) -> IO r
withFile (FilePath
dir FilePath -> FilePath -> FilePath
</> FilePath
file) IOMode
ReadMode (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. Eq a => a -> a -> Bool
== GenValue -> Integer
genFileSize GenValue
gen) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Handle -> IO Integer
hFileSize)
        forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` \IOError
ex ->
          if IOError -> Bool
isDoesNotExistError IOError
ex
            then forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
            else forall a e. Exception e => e -> a
E.throw IOError
ex
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
exists_and_proper_size forall a b. (a -> b) -> a -> b
$
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
      ByteString
s <- FutharkExe -> [GenValue] -> IO ByteString
genValues FutharkExe
futhark [GenValue
gen]
      forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
FilePath -> FilePath -> (FilePath -> Handle -> m a) -> m a
withTempFile (FilePath
dir FilePath -> FilePath -> FilePath
</> FilePath
"data") (GenValue -> FilePath
genFileName GenValue
gen) forall a b. (a -> b) -> a -> b
$ \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 forall a b. (a -> b) -> a -> b
$ FilePath
dir FilePath -> FilePath -> FilePath
</> FilePath
file
  forall (f :: * -> *) a. Applicative f => a -> f a
pure FilePath
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 = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> IO ByteString
BS.readFile forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FilePath
dir </>) forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< 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
  (ExitCode
code, ByteString
stdout, ByteString
stderr) <- FilePath
-> [FilePath]
-> ByteString
-> IO (ExitCode, ByteString, ByteString)
readProcessWithExitCode FilePath
futhark (FilePath
"dataset" forall a. a -> [a] -> [a]
: [FilePath]
args) forall a. Monoid a => a
mempty
  case ExitCode
code of
    ExitCode
ExitSuccess ->
      forall (f :: * -> *) a. Applicative f => a -> f a
pure ByteString
stdout
    ExitFailure Int
e ->
      forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail forall a b. (a -> b) -> a -> b
$
        FilePath
"'futhark dataset' failed with exit code "
          forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> FilePath
show Int
e
          forall a. [a] -> [a] -> [a]
++ FilePath
" and stderr:\n"
          forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map (Int -> Char
chr forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral) (ByteString -> [Word8]
SBS.unpack ByteString
stderr)
  where
    args :: [FilePath]
args = FilePath
"-b" forall a. a -> [a] -> [a]
: forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap GenValue -> [FilePath]
argForGen [GenValue]
gens
    argForGen :: GenValue -> [FilePath]
argForGen GenValue
g = [FilePath
"-g", GenValue -> FilePath
genValueType GenValue
g]

genFileName :: GenValue -> FilePath
genFileName :: GenValue -> FilePath
genFileName GenValue
gen = GenValue -> FilePath
genValueType GenValue
gen forall 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 forall a. Num a => a -> a -> a
+ Int
1 forall a. Num a => a -> a -> a
+ Int
1 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)) =
      forall a. Integral a => a -> Integer
toInteger forall a b. (a -> b) -> a -> b
$
        Int
header_size
          forall a. Num a => a -> a -> a
+ forall (t :: * -> *) a. Foldable t => t a -> Int
length [Int]
ds forall a. Num a => a -> a -> a
* Int
8
          forall a. Num a => a -> a -> a
+ forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
product [Int]
ds forall a. Num a => a -> a -> a
* PrimType -> Int
V.primTypeBytes PrimType
t
    genSize (GenPrim Value
v) =
      forall a. Integral a => a -> Integer
toInteger forall a b. (a -> b) -> a -> b
$ Int
header_size forall a. Num a => a -> a -> a
+ forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
product (Value -> [Int]
V.valueShape Value
v) 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
      forall a. Semigroup a => a -> a -> a
<> FilePath
":"
      forall a. Semigroup a => a -> a -> a
<> Text -> FilePath
T.unpack Text
entry
      forall a. Semigroup a => a -> a -> a
<> FilePath
"-"
      forall a. Semigroup a => a -> a -> a
<> forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
clean (TestRun -> FilePath
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))) ->
      forall values. Maybe values -> ExpectedResult values
Succeeds forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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) ->
      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 :: ExpectedResult Success
runExpectedResult =
                forall values. Maybe values -> ExpectedResult values
Succeeds forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. Values -> Success
SuccessValues forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Values
InFile forall a b. (a -> b) -> a -> b
$
                  FilePath -> Text -> TestRun -> FilePath
testRunReferenceOutput FilePath
prog Text
entry TestRun
tr
            }
    Succeeds Maybe Success
Nothing ->
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall values. Maybe values -> ExpectedResult values
Succeeds forall a. Maybe a
Nothing
    RunTimeFailure ExpectedError
err ->
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall values. ExpectedError -> ExpectedResult values
RunTimeFailure ExpectedError
err

-- | The name we use for compiled programs.
binaryName :: FilePath -> FilePath
binaryName :: FilePath -> FilePath
binaryName = FilePath -> FilePath
dropExtension

-- | @compileProgram extra_options futhark backend program@ compiles
-- @program@ with the command @futhark backend extra-options...@, and
-- returns stdout and stderr of the compiler.  Throws an IO exception
-- containing stderr if compilation fails.
compileProgram ::
  (MonadIO m, MonadError [T.Text] m) =>
  [String] ->
  FutharkExe ->
  String ->
  FilePath ->
  m (SBS.ByteString, SBS.ByteString)
compileProgram :: forall (m :: * -> *).
(MonadIO m, MonadError [Text] m) =>
[FilePath]
-> FutharkExe -> FilePath -> FilePath -> m (ByteString, ByteString)
compileProgram [FilePath]
extra_options (FutharkExe FilePath
futhark) FilePath
backend FilePath
program = do
  (ExitCode
futcode, ByteString
stdout, ByteString
stderr) <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ FilePath
-> [FilePath]
-> ByteString
-> IO (ExitCode, ByteString, ByteString)
readProcessWithExitCode FilePath
futhark (FilePath
backend forall a. a -> [a] -> [a]
: [FilePath]
options) ByteString
""
  case ExitCode
futcode of
    ExitFailure Int
127 -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError [forall {a}. (Semigroup a, IsString a) => a -> a
progNotFound forall a b. (a -> b) -> a -> b
$ FilePath -> Text
T.pack FilePath
futhark]
    ExitFailure Int
_ -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError [ByteString -> Text
T.decodeUtf8 ByteString
stderr]
    ExitCode
ExitSuccess -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (ByteString
stdout, ByteString
stderr)
  where
    binOutputf :: FilePath
binOutputf = FilePath -> FilePath
binaryName FilePath
program
    options :: [FilePath]
options = [FilePath
program, FilePath
"-o", FilePath
binOutputf] forall a. [a] -> [a] -> [a]
++ [FilePath]
extra_options
    progNotFound :: a -> a
progNotFound a
s = a
s forall a. Semigroup a => a -> a -> a
<> a
": command not found"

-- | @runProgram futhark runner extra_options prog entry input@ runs the
-- Futhark program @prog@ (which must have the @.fut@ suffix),
-- executing the @entry@ entry point and providing @input@ on stdin.
-- The program must have been compiled in advance with
-- 'compileProgram'.  If @runner@ is non-null, then it is used as
-- "interpreter" for the compiled program (e.g. @python@ when using
-- the Python backends).  The @extra_options@ are passed to the
-- program.
runProgram ::
  FutharkExe ->
  FilePath ->
  [String] ->
  String ->
  T.Text ->
  Values ->
  IO (ExitCode, SBS.ByteString, SBS.ByteString)
runProgram :: FutharkExe
-> FilePath
-> [FilePath]
-> FilePath
-> Text
-> Values
-> IO (ExitCode, ByteString, ByteString)
runProgram FutharkExe
futhark FilePath
runner [FilePath]
extra_options FilePath
prog Text
entry Values
input = do
  let progbin :: FilePath
progbin = FilePath -> FilePath
binaryName FilePath
prog
      dir :: FilePath
dir = FilePath -> FilePath
takeDirectory FilePath
prog
      binpath :: FilePath
binpath = FilePath
"." FilePath -> FilePath -> FilePath
</> FilePath
progbin
      entry_options :: [FilePath]
entry_options = [FilePath
"-e", Text -> FilePath
T.unpack Text
entry]

      (FilePath
to_run, [FilePath]
to_run_args)
        | forall (t :: * -> *) a. Foldable t => t a -> Bool
null FilePath
runner = (FilePath
binpath, [FilePath]
entry_options forall a. [a] -> [a] -> [a]
++ [FilePath]
extra_options)
        | Bool
otherwise = (FilePath
runner, FilePath
binpath forall a. a -> [a] -> [a]
: [FilePath]
entry_options forall a. [a] -> [a] -> [a]
++ [FilePath]
extra_options)

  ByteString
input' <- forall (m :: * -> *).
(MonadFail m, MonadIO m) =>
FutharkExe -> FilePath -> Values -> m ByteString
getValuesBS FutharkExe
futhark FilePath
dir Values
input
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ FilePath
-> [FilePath]
-> ByteString
-> IO (ExitCode, ByteString, ByteString)
readProcessWithExitCode FilePath
to_run [FilePath]
to_run_args forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
BS.toStrict ByteString
input'

-- | Read the given variables from a running server.
readResults ::
  (MonadIO m, MonadError T.Text m) =>
  Server ->
  [VarName] ->
  m [V.Value]
readResults :: forall (m :: * -> *).
(MonadIO m, MonadError Text m) =>
Server -> [Text] -> m [Value]
readResults Server
server =
  forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall (f :: * -> *) a. Applicative f => a -> f a
pure forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. Server -> Text -> IO (Either Text Value)
getValue Server
server)

-- | 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
  [(Text, TestRun)]
missing <- forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM forall {m :: * -> *}. MonadIO m => (Text, TestRun) -> m Bool
isReferenceMissing forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap InputOutputs -> [(Text, TestRun)]
entryAndRuns [InputOutputs]
ios

  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Text, TestRun)]
missing) forall a b. (a -> b) -> a -> b
$ do
    forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
(MonadIO m, MonadError [Text] m) =>
[FilePath]
-> FutharkExe -> FilePath -> FilePath -> m (ByteString, ByteString)
compileProgram [] FutharkExe
futhark FilePath
compiler FilePath
prog

    [Either [Text] ()]
res <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$
      forall a b c. (a -> b -> c) -> b -> a -> c
flip (forall a b. Maybe Int -> (a -> IO b) -> [a] -> IO [b]
pmapIO Maybe Int
concurrency) [(Text, TestRun)]
missing forall a b. (a -> b) -> a -> b
$ \(Text
entry, TestRun
tr) -> do
        (ExitCode
code, ByteString
stdout, ByteString
stderr) <- FutharkExe
-> FilePath
-> [FilePath]
-> FilePath
-> Text
-> Values
-> IO (ExitCode, ByteString, ByteString)
runProgram FutharkExe
futhark FilePath
"" [FilePath
"-b"] FilePath
prog Text
entry forall a b. (a -> b) -> a -> b
$ TestRun -> Values
runInput TestRun
tr
        case ExitCode
code of
          ExitFailure Int
e ->
            forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
              forall a b. a -> Either a b
Left
                [ FilePath -> Text
T.pack forall a b. (a -> b) -> a -> b
$
                    FilePath
"Reference dataset generation failed with exit code "
                      forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> FilePath
show Int
e
                      forall a. [a] -> [a] -> [a]
++ FilePath
" and stderr:\n"
                      forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map (Int -> Char
chr forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral) (ByteString -> [Word8]
SBS.unpack ByteString
stderr)
                ]
          ExitCode
ExitSuccess -> do
            let f :: FilePath
f = (Text, TestRun) -> FilePath
file (Text
entry, TestRun
tr)
            forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
True forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath
takeDirectory FilePath
f
            FilePath -> ByteString -> IO ()
SBS.writeFile FilePath
f ByteString
stdout
            forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right ()

    case forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ [Either [Text] ()]
res of
      Left [Text]
err -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError [Text]
err
      Right () -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  where
    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) = 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 =
          forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$
            (forall a. Ord a => a -> a -> 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)) forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> FilePath -> IO UTCTime
getModificationTime FilePath
prog)
              forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` (\IOError
e -> if IOError -> Bool
isDoesNotExistError IOError
e then forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True else forall a e. Exception e => e -> a
E.throw IOError
e)
      | Bool
otherwise =
          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
_ = forall (f :: * -> *) a. Applicative f => a -> f a
pure ([], forall a. Monoid a => a
mempty)
determineTuning (Just FilePath
ext) FilePath
program = do
  Bool
exists <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ FilePath -> IO Bool
doesFileExist (FilePath
program FilePath -> FilePath -> FilePath
<.> FilePath
ext)
  if Bool
exists
    then
      forall (f :: * -> *) a. Applicative f => a -> f a
pure
        ( [FilePath
"--tuning", FilePath
program FilePath -> FilePath -> FilePath
<.> FilePath
ext],
          FilePath
" (using " forall a. Semigroup a => a -> a -> a
<> FilePath -> FilePath
takeFileName (FilePath
program FilePath -> FilePath -> FilePath
<.> FilePath
ext) forall a. Semigroup a => a -> a -> a
<> FilePath
")"
        )
    else forall (f :: * -> *) a. Applicative f => a -> f a
pure ([], FilePath
" (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"
      forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ FilePath -> ByteString -> IO ()
BS.writeFile FilePath
actualf forall a b. (a -> b) -> a -> b
$ forall a. Monoid a => [a] -> a
mconcat forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a. Binary a => a -> ByteString
Bin.encode [Value]
actual_vs
      forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ FilePath -> ByteString -> IO ()
BS.writeFile FilePath
expectedf forall a b. (a -> b) -> a -> b
$ forall a. Monoid a => [a] -> a
mconcat forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a. Binary a => a -> ByteString
Bin.encode [Value]
expected_vs
      forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$
        FilePath -> Text
T.pack FilePath
actualf
          forall a. Semigroup a => a -> a -> a
<> Text
" and "
          forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack FilePath
expectedf
          forall a. Semigroup a => a -> a -> a
<> Text
" do not match:\n"
          forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack (forall a. Show a => a -> FilePath
show Mismatch
mismatch)
          forall a. Semigroup a => a -> a -> a
<> if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Mismatch]
mismatches
            then forall a. Monoid a => a
mempty
            else Text
"\n...and " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
prettyText (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Mismatch]
mismatches) forall a. Semigroup a => a -> a -> a
<> Text
" other mismatches."
    [] ->
      forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

-- | Create a Futhark server configuration suitable for use when
-- testing/benchmarking Futhark programs.
futharkServerCfg :: FilePath -> [String] -> ServerCfg
futharkServerCfg :: FilePath -> [FilePath] -> ServerCfg
futharkServerCfg FilePath
prog [FilePath]
opts =
  (FilePath -> [FilePath] -> ServerCfg
newServerCfg FilePath
prog [FilePath]
opts)
    { cfgDebug :: Bool
cfgDebug = FilePath -> Int -> Bool
isEnvVarAtLeast FilePath
"FUTHARK_COMPILER_DEBUGGING" Int
1
    }