-- | 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,
    readResults,
    ensureReferenceOutput,
    determineTuning,
    determineCache,
    binaryName,
    futharkServerCfg,
    V.Mismatch,
    V.Value,
    V.valueText,
  )
where

import Codec.Compression.GZip
import Control.Applicative
import Control.Exception (catch)
import Control.Exception.Base qualified as E
import Control.Monad
import Control.Monad.Except (MonadError (..), runExceptT)
import Control.Monad.IO.Class (MonadIO, liftIO)
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 =
  Either FilePath [Value]
-> ([Value] -> Either FilePath [Value])
-> Maybe [Value]
-> Either FilePath [Value]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (FilePath -> Either FilePath [Value]
forall a b. a -> Either a b
Left (FilePath -> Either FilePath [Value])
-> FilePath -> Either FilePath [Value]
forall a b. (a -> b) -> a -> b
$ FilePath
"Cannot parse values from '" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
srcname FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"'") [Value] -> Either FilePath [Value]
forall a b. b -> Either a b
Right (Maybe [Value] -> Either FilePath [Value])
-> (ByteString -> Maybe [Value])
-> ByteString
-> Either FilePath [Value]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Maybe [Value]
V.readValues

-- | 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
(FutharkExe -> FutharkExe -> Bool)
-> (FutharkExe -> FutharkExe -> Bool) -> Eq FutharkExe
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: FutharkExe -> FutharkExe -> Bool
== :: FutharkExe -> FutharkExe -> Bool
$c/= :: FutharkExe -> FutharkExe -> Bool
/= :: FutharkExe -> FutharkExe -> Bool
Eq, Eq FutharkExe
Eq FutharkExe =>
(FutharkExe -> FutharkExe -> Ordering)
-> (FutharkExe -> FutharkExe -> Bool)
-> (FutharkExe -> FutharkExe -> Bool)
-> (FutharkExe -> FutharkExe -> Bool)
-> (FutharkExe -> FutharkExe -> Bool)
-> (FutharkExe -> FutharkExe -> FutharkExe)
-> (FutharkExe -> FutharkExe -> FutharkExe)
-> Ord 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
$ccompare :: FutharkExe -> FutharkExe -> Ordering
compare :: FutharkExe -> FutharkExe -> Ordering
$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
>= :: FutharkExe -> FutharkExe -> Bool
$cmax :: FutharkExe -> FutharkExe -> FutharkExe
max :: FutharkExe -> FutharkExe -> FutharkExe
$cmin :: FutharkExe -> FutharkExe -> FutharkExe
min :: FutharkExe -> FutharkExe -> FutharkExe
Ord, Int -> FutharkExe -> FilePath -> FilePath
[FutharkExe] -> FilePath -> FilePath
FutharkExe -> FilePath
(Int -> FutharkExe -> FilePath -> FilePath)
-> (FutharkExe -> FilePath)
-> ([FutharkExe] -> FilePath -> FilePath)
-> Show FutharkExe
forall a.
(Int -> a -> FilePath -> FilePath)
-> (a -> FilePath) -> ([a] -> FilePath -> FilePath) -> Show a
$cshowsPrec :: Int -> FutharkExe -> FilePath -> FilePath
showsPrec :: Int -> FutharkExe -> FilePath -> FilePath
$cshow :: FutharkExe -> FilePath
show :: FutharkExe -> FilePath
$cshowList :: [FutharkExe] -> FilePath -> FilePath
showList :: [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) = [Value] -> m [Value]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Value]
vs
getValues FutharkExe
futhark FilePath
dir Values
v = do
  ByteString
s <- FutharkExe -> FilePath -> Values -> m ByteString
forall (m :: * -> *).
(MonadFail m, MonadIO m) =>
FutharkExe -> FilePath -> Values -> m ByteString
getValuesBS FutharkExe
futhark FilePath
dir Values
v
  case FilePath -> ByteString -> Either FilePath [Value]
valuesFromByteString (Values -> FilePath
fileName Values
v) ByteString
s of
    Left FilePath
e -> FilePath -> m [Value]
forall a. FilePath -> m a
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail FilePath
e
    Right [Value]
vs -> [Value] -> m [Value]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Value]
vs
  where
    fileName :: Values -> FilePath
fileName Values {} = FilePath
"<values>"
    fileName GenValues {} = FilePath
"<randomly generated>"
    fileName ScriptValues {} = FilePath
"<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 = IO ByteString -> IO (Either DecompressError ByteString)
forall e a. Exception e => IO a -> IO (Either e a)
E.try (IO ByteString -> IO (Either DecompressError ByteString))
-> IO ByteString -> IO (Either DecompressError ByteString)
forall a b. (a -> b) -> a -> b
$ do
  ByteString
s <- FilePath -> IO ByteString
BS.readFile FilePath
file
  ByteString -> IO ByteString
forall a. a -> IO a
E.evaluate (ByteString -> IO ByteString) -> ByteString -> IO ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
decompress ByteString
s

-- | Extract a text representation of some 'Values'.  In the IO monad
-- because this might involve reading from a file.  There is no
-- guarantee that the resulting byte string yields a readable value.
getValuesBS :: (MonadFail m, MonadIO m) => FutharkExe -> FilePath -> Values -> m BS.ByteString
getValuesBS :: forall (m :: * -> *).
(MonadFail m, MonadIO m) =>
FutharkExe -> FilePath -> Values -> m ByteString
getValuesBS FutharkExe
_ FilePath
_ (Values [Value]
vs) =
  ByteString -> m ByteString
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ByteString -> m ByteString) -> ByteString -> m ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
BS.fromStrict (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Text -> ByteString
T.encodeUtf8 (Text -> ByteString) -> Text -> ByteString
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.unlines ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ (Value -> Text) -> [Value] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Value -> Text
V.valueText [Value]
vs
getValuesBS FutharkExe
_ FilePath
dir (InFile FilePath
file) =
  case FilePath -> FilePath
takeExtension FilePath
file of
    FilePath
".gz" -> IO ByteString -> m ByteString
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ByteString -> m ByteString) -> IO ByteString -> m ByteString
forall a b. (a -> b) -> a -> b
$ do
      Either DecompressError ByteString
s <- FilePath -> IO (Either DecompressError ByteString)
readAndDecompress FilePath
file'
      case Either DecompressError ByteString
s of
        Left DecompressError
e -> FilePath -> IO ByteString
forall a. FilePath -> IO a
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail (FilePath -> IO ByteString) -> FilePath -> IO ByteString
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath
forall a. Show a => a -> FilePath
show FilePath
file FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
": " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ DecompressError -> FilePath
forall a. Show a => a -> FilePath
show DecompressError
e
        Right ByteString
s' -> ByteString -> IO ByteString
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ByteString
s'
    FilePath
_ -> IO ByteString -> m ByteString
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ByteString -> m ByteString) -> IO ByteString -> m ByteString
forall a b. (a -> b) -> a -> b
$ FilePath -> IO ByteString
BS.readFile FilePath
file'
  where
    file' :: FilePath
file' = FilePath
dir FilePath -> FilePath -> FilePath
</> FilePath
file
getValuesBS FutharkExe
futhark FilePath
dir (GenValues [GenValue]
gens) =
  [ByteString] -> ByteString
forall a. Monoid a => [a] -> a
mconcat ([ByteString] -> ByteString) -> m [ByteString] -> m ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (GenValue -> m ByteString) -> [GenValue] -> m [ByteString]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (FutharkExe -> FilePath -> GenValue -> m ByteString
forall (m :: * -> *).
MonadIO m =>
FutharkExe -> FilePath -> GenValue -> m ByteString
getGenBS FutharkExe
futhark FilePath
dir) [GenValue]
gens
getValuesBS FutharkExe
_ FilePath
_ (ScriptValues Exp
e) =
  FilePath -> m ByteString
forall a. FilePath -> m a
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail (FilePath -> m ByteString) -> FilePath -> m ByteString
forall a b. (a -> b) -> a -> b
$
    FilePath
"Cannot get values from FutharkScript expression: "
      FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> Text -> FilePath
T.unpack (Exp -> Text
forall a. Pretty a => a -> Text
prettyTextOneLine Exp
e)
getValuesBS FutharkExe
_ FilePath
_ (ScriptFile FilePath
f) =
  FilePath -> m ByteString
forall a. FilePath -> m a
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail (FilePath -> m ByteString) -> FilePath -> m ByteString
forall a b. (a -> b) -> a -> b
$ FilePath
"Cannot get values from FutharkScript file: " FilePath -> FilePath -> FilePath
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 =
  IO (Maybe CmdFailure) -> m ()
forall (m :: * -> *).
(MonadError Text m, MonadIO m) =>
IO (Maybe CmdFailure) -> m ()
cmdMaybe (IO (Maybe CmdFailure) -> m ()) -> IO (Maybe CmdFailure) -> m ()
forall a b. (a -> b) -> a -> b
$ Server -> Text -> 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 <- ExpValue -> [ExpValue]
forall v. Compound v -> [Compound v]
V.unCompound ExpValue
val,
    [(Text, Text)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Text, Text)]
names_and_types Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== [ExpValue] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [ExpValue]
vals,
    Just [m ()]
loads <- ((Text, Text) -> ExpValue -> Maybe (m ()))
-> [(Text, Text)] -> [ExpValue] -> Maybe [m ()]
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM (Text, Text) -> ExpValue -> Maybe (m ())
forall {m :: * -> *}.
(MonadError Text m, MonadIO m) =>
(Text, Text) -> ExpValue -> Maybe (m ())
f [(Text, Text)]
names_and_types [ExpValue]
vals =
      [m ()] -> m ()
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 Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
t1 =
          m () -> Maybe (m ())
forall a. a -> Maybe a
Just (m () -> Maybe (m ())) -> m () -> Maybe (m ())
forall a b. (a -> b) -> a -> b
$ case ValOrVar
sval of
            Script.VVar Text
oldname ->
              IO (Maybe CmdFailure) -> m ()
forall (m :: * -> *).
(MonadError Text m, MonadIO m) =>
IO (Maybe CmdFailure) -> m ()
cmdMaybe (IO (Maybe CmdFailure) -> m ()) -> IO (Maybe CmdFailure) -> m ()
forall a b. (a -> b) -> a -> b
$ Server -> Text -> Text -> IO (Maybe CmdFailure)
cmdRename Server
server Text
oldname Text
v
            Script.VVal Value
sval' ->
              Server -> Text -> Value -> m ()
forall (m :: * -> *).
(MonadError Text m, MonadIO m) =>
Server -> Text -> Value -> m ()
valueAsVar Server
server Text
v Value
sval'
    f (Text, Text)
_ ExpValue
_ = Maybe (m ())
forall a. Maybe a
Nothing
scriptValueAsVars Server
server [(Text, Text)]
names_and_types ExpValue
val = do
  IO (Maybe CmdFailure) -> m ()
forall (m :: * -> *).
(MonadError Text m, MonadIO m) =>
IO (Maybe CmdFailure) -> m ()
cmdMaybe (IO (Maybe CmdFailure) -> m ()) -> IO (Maybe CmdFailure) -> m ()
forall a b. (a -> b) -> a -> b
$ Server -> [Text] -> IO (Maybe CmdFailure)
cmdFree Server
server ([Text] -> IO (Maybe CmdFailure))
-> [Text] -> IO (Maybe CmdFailure)
forall a b. (a -> b) -> a -> b
$ Set Text -> [Text]
forall a. Set a -> [a]
S.toList (Set Text -> [Text]) -> Set Text -> [Text]
forall a b. (a -> b) -> a -> b
$ ExpValue -> Set Text
Script.serverVarsInValue ExpValue
val
  Text -> m ()
forall a. Text -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$
    Text
"Expected value of type: "
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Compound Text -> Text
forall a. Pretty a => a -> Text
prettyTextOneLine ([Compound Text] -> Compound Text
forall v. [Compound v] -> Compound v
V.mkCompound (((Text, Text) -> Compound Text)
-> [(Text, Text)] -> [Compound Text]
forall a b. (a -> b) -> [a] -> [b]
map (Text -> Compound Text
forall v. v -> Compound v
V.ValueAtom (Text -> Compound Text)
-> ((Text, Text) -> Text) -> (Text, Text) -> Compound Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text, Text) -> Text
forall a b. (a, b) -> b
snd) [(Text, Text)]
names_and_types))
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\nBut got value of type:  "
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Compound ScriptValueType -> Text
forall a. Pretty a => a -> Text
prettyTextOneLine ((ScriptValue ValOrVar -> ScriptValueType)
-> ExpValue -> Compound ScriptValueType
forall a b. (a -> b) -> Compound a -> Compound b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ScriptValue ValOrVar -> ScriptValueType
forall v. ScriptValue v -> ScriptValueType
Script.scriptValueType ExpValue
val)
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
notes
  where
    notes :: Text
notes = [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ ((Text, Text) -> Maybe Text) -> [(Text, Text)] -> [Text]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Text, Text) -> Maybe Text
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 =
          Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$
            Text
"\nNote: expected type "
              Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
forall a. Pretty a => a -> Text
prettyText Text
t
              Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" is an opaque tuple that cannot be constructed\n"
              Text -> Text -> Text
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 =
          Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$
            Text
"\nNote: expected type "
              Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
forall a. Pretty a => a -> Text
prettyText Text
t
              Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" is an opaque record that cannot be constructed\n"
              Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"in FutharkScript.  Consider using type annotations to give it a proper name."
      | Bool
otherwise =
          Maybe Text
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 FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
".gz" = do
      Either DecompressError ByteString
s <- IO (Either DecompressError ByteString)
-> m (Either DecompressError ByteString)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either DecompressError ByteString)
 -> m (Either DecompressError ByteString))
-> IO (Either DecompressError ByteString)
-> m (Either DecompressError ByteString)
forall a b. (a -> b) -> a -> b
$ FilePath -> IO (Either DecompressError ByteString)
readAndDecompress (FilePath -> IO (Either DecompressError ByteString))
-> FilePath -> IO (Either DecompressError ByteString)
forall a b. (a -> b) -> a -> b
$ FilePath
dir FilePath -> FilePath -> FilePath
</> FilePath
file
      case Either DecompressError ByteString
s of
        Left DecompressError
e ->
          Text -> m ()
forall a. Text -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ FilePath -> Text
forall a. Show a => a -> Text
showText FilePath
file Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> DecompressError -> Text
forall a. Show a => a -> Text
showText DecompressError
e
        Right ByteString
s' ->
          IO (Maybe CmdFailure) -> m ()
forall (m :: * -> *).
(MonadError Text m, MonadIO m) =>
IO (Maybe CmdFailure) -> m ()
cmdMaybe (IO (Maybe CmdFailure) -> m ())
-> ((FilePath -> Handle -> IO (Maybe CmdFailure))
    -> IO (Maybe CmdFailure))
-> (FilePath -> Handle -> IO (Maybe CmdFailure))
-> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath
-> (FilePath -> Handle -> IO (Maybe CmdFailure))
-> IO (Maybe CmdFailure)
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
FilePath -> (FilePath -> Handle -> m a) -> m a
withSystemTempFile FilePath
"futhark-input" ((FilePath -> Handle -> IO (Maybe CmdFailure)) -> m ())
-> (FilePath -> Handle -> IO (Maybe CmdFailure)) -> m ()
forall a b. (a -> b) -> a -> b
$ \FilePath
tmpf Handle
tmpf_h -> do
            Handle -> ByteString -> IO ()
BS.hPutStr Handle
tmpf_h ByteString
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 =
      IO (Maybe CmdFailure) -> m ()
forall (m :: * -> *).
(MonadError Text m, MonadIO m) =>
IO (Maybe CmdFailure) -> m ()
cmdMaybe (IO (Maybe CmdFailure) -> m ()) -> IO (Maybe CmdFailure) -> m ()
forall a b. (a -> b) -> a -> b
$ Server -> FilePath -> [(Text, Text)] -> IO (Maybe CmdFailure)
cmdRestore Server
server (FilePath
dir FilePath -> FilePath -> FilePath
</> FilePath
file) [(Text, Text)]
names_and_types
valuesAsVars Server
server [(Text, Text)]
names_and_types FutharkExe
futhark FilePath
dir (GenValues [GenValue]
gens) = do
  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([GenValue] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [GenValue]
gens Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== [(Text, Text)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Text, Text)]
names_and_types) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
    Text -> m ()
forall a. Text -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError Text
"Mismatch between number of expected and generated values."
  [FilePath]
gen_fs <- (GenValue -> m FilePath) -> [GenValue] -> m [FilePath]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (FutharkExe -> FilePath -> GenValue -> m FilePath
forall (m :: * -> *).
MonadIO m =>
FutharkExe -> FilePath -> GenValue -> m FilePath
getGenFile FutharkExe
futhark FilePath
dir) [GenValue]
gens
  [(FilePath, (Text, Text))]
-> ((FilePath, (Text, Text)) -> m ()) -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ([FilePath] -> [(Text, Text)] -> [(FilePath, (Text, Text))]
forall a b. [a] -> [b] -> [(a, b)]
zip [FilePath]
gen_fs [(Text, Text)]
names_and_types) (((FilePath, (Text, Text)) -> m ()) -> m ())
-> ((FilePath, (Text, Text)) -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \(FilePath
file, (Text
v, Text
t)) ->
    IO (Maybe CmdFailure) -> m ()
forall (m :: * -> *).
(MonadError Text m, MonadIO m) =>
IO (Maybe CmdFailure) -> m ()
cmdMaybe (IO (Maybe CmdFailure) -> m ()) -> IO (Maybe CmdFailure) -> m ()
forall a b. (a -> b) -> a -> b
$ Server -> FilePath -> [(Text, Text)] -> IO (Maybe CmdFailure)
cmdRestore Server
server (FilePath
dir FilePath -> FilePath -> FilePath
</> FilePath
file) [(Text
v, Text
t)]
valuesAsVars Server
server [(Text, Text)]
names_and_types FutharkExe
_ FilePath
_ (Values [Value]
vs) = do
  let types :: [Text]
types = ((Text, Text) -> Text) -> [(Text, Text)] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Text, Text) -> Text
forall a b. (a, b) -> b
snd [(Text, Text)]
names_and_types
      vs_types :: [Text]
vs_types = (Value -> Text) -> [Value] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (ValueType -> Text
V.valueTypeTextNoDims (ValueType -> Text) -> (Value -> ValueType) -> Value -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> ValueType
V.valueType) [Value]
vs
  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([Text]
types [Text] -> [Text] -> Bool
forall a. Eq a => a -> a -> Bool
== [Text]
vs_types) (m () -> m ()) -> ([Text] -> m ()) -> [Text] -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> m ()
forall a. Text -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Text -> m ()) -> ([Text] -> Text) -> [Text] -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Text
T.unlines ([Text] -> m ()) -> [Text] -> m ()
forall a b. (a -> b) -> a -> b
$
    [ Text
"Expected input of types: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
T.unwords ((Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Text -> Text
forall a. Pretty a => a -> Text
prettyTextOneLine [Text]
types),
      Text
"Provided input of types: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
T.unwords ((Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Text -> Text
forall a. Pretty a => a -> Text
prettyTextOneLine [Text]
vs_types)
    ]
  IO (Maybe CmdFailure) -> m ()
forall (m :: * -> *).
(MonadError Text m, MonadIO m) =>
IO (Maybe CmdFailure) -> m ()
cmdMaybe (IO (Maybe CmdFailure) -> m ())
-> ((FilePath -> Handle -> IO (Maybe CmdFailure))
    -> IO (Maybe CmdFailure))
-> (FilePath -> Handle -> IO (Maybe CmdFailure))
-> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath
-> (FilePath -> Handle -> IO (Maybe CmdFailure))
-> IO (Maybe CmdFailure)
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
FilePath -> (FilePath -> Handle -> m a) -> m a
withSystemTempFile FilePath
"futhark-input" ((FilePath -> Handle -> IO (Maybe CmdFailure)) -> m ())
-> (FilePath -> Handle -> IO (Maybe CmdFailure)) -> m ()
forall a b. (a -> b) -> a -> b
$ \FilePath
tmpf Handle
tmpf_h -> do
    (Value -> IO ()) -> [Value] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Handle -> ByteString -> IO ()
BS.hPutStr Handle
tmpf_h (ByteString -> IO ()) -> (Value -> ByteString) -> Value -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> ByteString
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) =
  Server -> (ScriptServer -> m ()) -> m ()
forall (m :: * -> *) a.
MonadIO m =>
Server -> (ScriptServer -> m a) -> m a
Script.withScriptServer' Server
server ((ScriptServer -> m ()) -> m ()) -> (ScriptServer -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \ScriptServer
server' -> do
    ExpValue
e_v <- EvalBuiltin m -> ScriptServer -> Exp -> m ExpValue
forall (m :: * -> *).
(MonadError Text m, MonadIO m) =>
EvalBuiltin m -> ScriptServer -> Exp -> m ExpValue
Script.evalExp (FilePath -> EvalBuiltin m
forall (m :: * -> *).
(MonadIO m, MonadError Text m) =>
FilePath -> EvalBuiltin m
Script.scriptBuiltin FilePath
dir) ScriptServer
server' Exp
e
    Server -> [(Text, Text)] -> ExpValue -> m ()
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 <-
    (Text -> m Exp) -> (Exp -> m Exp) -> Either Text Exp -> m Exp
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either Text -> m Exp
forall a. Text -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError Exp -> m Exp
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either Text Exp -> m Exp)
-> (Text -> Either Text Exp) -> Text -> m Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Text -> Either Text Exp
Script.parseExpFromText FilePath
f
      (Text -> m Exp) -> m Text -> m Exp
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO Text -> m Text
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (FilePath -> IO Text
T.readFile (FilePath
dir FilePath -> FilePath -> FilePath
</> FilePath
f))
  Server
-> [(Text, Text)] -> FutharkExe -> FilePath -> Values -> m ()
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
  IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
True (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
dir FilePath -> FilePath -> FilePath
</> FilePath
"data"
  Bool
exists_and_proper_size <-
    IO Bool -> m Bool
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> m Bool) -> IO Bool -> m Bool
forall a b. (a -> b) -> a -> b
$
      FilePath -> IOMode -> (Handle -> IO Bool) -> IO Bool
forall r. FilePath -> IOMode -> (Handle -> IO r) -> IO r
withFile (FilePath
dir FilePath -> FilePath -> FilePath
</> FilePath
file) IOMode
ReadMode ((Integer -> Bool) -> IO Integer -> IO Bool
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== GenValue -> Integer
genFileSize GenValue
gen) (IO Integer -> IO Bool)
-> (Handle -> IO Integer) -> Handle -> IO Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Handle -> IO Integer
hFileSize)
        IO Bool -> (IOError -> IO Bool) -> IO Bool
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` \IOError
ex ->
          if IOError -> Bool
isDoesNotExistError IOError
ex
            then Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
            else IOError -> IO Bool
forall a e. Exception e => e -> a
E.throw IOError
ex
  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
exists_and_proper_size (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
    IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ do
      ByteString
s <- FutharkExe -> [GenValue] -> IO ByteString
genValues FutharkExe
futhark [GenValue
gen]
      FilePath -> FilePath -> (FilePath -> Handle -> IO ()) -> IO ()
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) ((FilePath -> Handle -> IO ()) -> IO ())
-> (FilePath -> Handle -> IO ()) -> IO ()
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 (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
dir FilePath -> FilePath -> FilePath
</> FilePath
file
  FilePath -> m FilePath
forall a. a -> m a
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 = IO ByteString -> m ByteString
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ByteString -> m ByteString)
-> (FilePath -> IO ByteString) -> FilePath -> m ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> IO ByteString
BS.readFile (FilePath -> IO ByteString)
-> (FilePath -> FilePath) -> FilePath -> IO ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FilePath
dir </>) (FilePath -> m ByteString) -> m FilePath -> m ByteString
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< FutharkExe -> FilePath -> GenValue -> m FilePath
forall (m :: * -> *).
MonadIO m =>
FutharkExe -> FilePath -> GenValue -> m FilePath
getGenFile FutharkExe
futhark FilePath
dir GenValue
gen

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

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

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

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

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

-- | 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) <- IO (ExitCode, ByteString, ByteString)
-> m (ExitCode, ByteString, ByteString)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (ExitCode, ByteString, ByteString)
 -> m (ExitCode, ByteString, ByteString))
-> IO (ExitCode, ByteString, ByteString)
-> m (ExitCode, ByteString, ByteString)
forall a b. (a -> b) -> a -> b
$ FilePath
-> [FilePath]
-> ByteString
-> IO (ExitCode, ByteString, ByteString)
readProcessWithExitCode FilePath
futhark (FilePath
backend FilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
: [FilePath]
options) ByteString
""
  case ExitCode
futcode of
    ExitFailure Int
127 -> Text -> m ()
forall a. Text -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Text -> Text
forall {a}. (Semigroup a, IsString a) => a -> a
progNotFound (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ FilePath -> Text
T.pack FilePath
futhark
    ExitFailure Int
_ -> Text -> m ()
forall a. Text -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ ByteString -> Text
T.decodeUtf8 ByteString
stderr
    ExitCode
ExitSuccess -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  (ByteString, ByteString) -> m (ByteString, ByteString)
forall a. a -> m a
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] [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ [FilePath]
extra_options
    progNotFound :: a -> a
progNotFound a
s = a
s a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
": command not found"

-- | 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 =
  (Text -> m Value) -> [Text] -> m [Value]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM ((Text -> m Value)
-> (Value -> m Value) -> Either Text Value -> m Value
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either Text -> m Value
forall a. Text -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError Value -> m Value
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either Text Value -> m Value)
-> (Text -> m (Either Text Value)) -> Text -> m Value
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< IO (Either Text Value) -> m (Either Text Value)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either Text Value) -> m (Either Text Value))
-> (Text -> IO (Either Text Value))
-> Text
-> m (Either Text Value)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Server -> Text -> IO (Either Text Value)
getValue Server
server)

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

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

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

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

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

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

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

-- | Determine the @--tuning@ options to pass to the program.  The first
-- argument is the extension of the tuning file, or 'Nothing' if none
-- should be used.
determineTuning :: (MonadIO m) => Maybe FilePath -> FilePath -> m ([String], String)
determineTuning :: forall (m :: * -> *).
MonadIO m =>
Maybe FilePath -> FilePath -> m ([FilePath], FilePath)
determineTuning Maybe FilePath
Nothing FilePath
_ = ([FilePath], FilePath) -> m ([FilePath], FilePath)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([], FilePath
forall a. Monoid a => a
mempty)
determineTuning (Just FilePath
ext) FilePath
program = do
  Bool
exists <- IO Bool -> m Bool
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> m Bool) -> IO Bool -> m Bool
forall a b. (a -> b) -> a -> b
$ FilePath -> IO Bool
doesFileExist (FilePath
program FilePath -> FilePath -> FilePath
<.> FilePath
ext)
  if Bool
exists
    then
      ([FilePath], FilePath) -> m ([FilePath], FilePath)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
        ( [FilePath
"--tuning", FilePath
program FilePath -> FilePath -> FilePath
<.> FilePath
ext],
          FilePath
" (using " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath -> FilePath
takeFileName (FilePath
program FilePath -> FilePath -> FilePath
<.> FilePath
ext) FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
")"
        )
    else ([FilePath], FilePath) -> m ([FilePath], FilePath)
forall a. a -> m a
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"
      IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ FilePath -> ByteString -> IO ()
BS.writeFile FilePath
actualf (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ [ByteString] -> ByteString
forall a. Monoid a => [a] -> a
mconcat ([ByteString] -> ByteString) -> [ByteString] -> ByteString
forall a b. (a -> b) -> a -> b
$ (Value -> ByteString) -> [Value] -> [ByteString]
forall a b. (a -> b) -> [a] -> [b]
map Value -> ByteString
forall a. Binary a => a -> ByteString
Bin.encode [Value]
actual_vs
      IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ FilePath -> ByteString -> IO ()
BS.writeFile FilePath
expectedf (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ [ByteString] -> ByteString
forall a. Monoid a => [a] -> a
mconcat ([ByteString] -> ByteString) -> [ByteString] -> ByteString
forall a b. (a -> b) -> a -> b
$ (Value -> ByteString) -> [Value] -> [ByteString]
forall a b. (a -> b) -> [a] -> [b]
map Value -> ByteString
forall a. Binary a => a -> ByteString
Bin.encode [Value]
expected_vs
      Text -> m ()
forall a. Text -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$
        FilePath -> Text
T.pack FilePath
actualf
          Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" and "
          Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack FilePath
expectedf
          Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" do not match:\n"
          Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Mismatch -> Text
forall a. Show a => a -> Text
showText Mismatch
mismatch
          Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> if [Mismatch] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Mismatch]
mismatches
            then Text
forall a. Monoid a => a
mempty
            else Text
"\n...and " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Pretty a => a -> Text
prettyText ([Mismatch] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Mismatch]
mismatches) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" other mismatches."
    [] ->
      () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

-- | 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 = isEnvVarAtLeast "FUTHARK_COMPILER_DEBUGGING" 1
    }