-- | 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, showText)
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
$ forall a. Show a => a -> Text
showText FilePath
file forall a. Semigroup a => a -> a -> a
<> Text
": " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showText 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
dir (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 (m :: * -> *).
(MonadIO m, MonadError Text m) =>
FilePath -> EvalBuiltin m
Script.scriptBuiltin FilePath
dir) 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
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]
: forall a b. (a -> b) -> [a] -> [b]
map Text -> FilePath
T.unpack [Text]
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 :: [Text]
args = Text
"-b" forall a. a -> [a] -> [a]
: 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) 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 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 (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))) ->
      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
<> forall a. Show a => a -> Text
showText 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
    }