{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TupleSections #-}

-- | 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
  ( testSpecFromFile,
    testSpecFromFileOrDie,
    testSpecsFromPaths,
    testSpecsFromPathsOrDie,
    valuesFromByteString,
    FutharkExe (..),
    getValues,
    getValuesBS,
    withValuesFile,
    checkValueTypes,
    compareValues,
    checkResult,
    testRunReferenceOutput,
    getExpectedResult,
    compileProgram,
    runProgram,
    readResults,
    ensureReferenceOutput,
    determineTuning,
    binaryName,
    Mismatch,
    ProgramTest (..),
    StructureTest (..),
    StructurePipeline (..),
    WarningTest (..),
    TestAction (..),
    ExpectedError (..),
    InputOutputs (..),
    TestRun (..),
    ExpectedResult (..),
    Success (..),
    Values (..),
    Value,
  )
where

import Codec.Compression.GZip
import Codec.Compression.Zlib.Internal (DecompressError)
import Control.Applicative
import Control.Exception (catch)
import qualified Control.Exception.Base as E
import Control.Monad
import Control.Monad.Except
import qualified Data.Binary as Bin
import qualified Data.ByteString as SBS
import qualified Data.ByteString.Lazy as BS
import Data.Char
import Data.Functor
import Data.List (foldl')
import qualified Data.Map.Strict as M
import Data.Maybe
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import qualified Data.Text.IO as T
import Data.Void
import Futhark.Analysis.Metrics.Type
import Futhark.IR.Primitive (floatByteSize, intByteSize)
import Futhark.Server
import Futhark.Test.Values
import Futhark.Test.Values.Parser
import Futhark.Util (directoryContents, pmapIO)
import Futhark.Util.Pretty (pretty, prettyText)
import Language.Futhark.Prop (primByteSize, primValueType)
import Language.Futhark.Syntax (PrimType (..), PrimValue (..))
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 Text.Megaparsec hiding (many, some)
import Text.Megaparsec.Char
import Text.Regex.TDFA
import Prelude

-- | Description of a test to be carried out on a Futhark program.
-- The Futhark program is stored separately.
data ProgramTest = ProgramTest
  { ProgramTest -> Text
testDescription ::
      T.Text,
    ProgramTest -> [Text]
testTags ::
      [T.Text],
    ProgramTest -> TestAction
testAction ::
      TestAction
  }
  deriving (Int -> ProgramTest -> ShowS
[ProgramTest] -> ShowS
ProgramTest -> String
(Int -> ProgramTest -> ShowS)
-> (ProgramTest -> String)
-> ([ProgramTest] -> ShowS)
-> Show ProgramTest
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ProgramTest] -> ShowS
$cshowList :: [ProgramTest] -> ShowS
show :: ProgramTest -> String
$cshow :: ProgramTest -> String
showsPrec :: Int -> ProgramTest -> ShowS
$cshowsPrec :: Int -> ProgramTest -> ShowS
Show)

-- | How to test a program.
data TestAction
  = CompileTimeFailure ExpectedError
  | RunCases [InputOutputs] [StructureTest] [WarningTest]
  deriving (Int -> TestAction -> ShowS
[TestAction] -> ShowS
TestAction -> String
(Int -> TestAction -> ShowS)
-> (TestAction -> String)
-> ([TestAction] -> ShowS)
-> Show TestAction
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TestAction] -> ShowS
$cshowList :: [TestAction] -> ShowS
show :: TestAction -> String
$cshow :: TestAction -> String
showsPrec :: Int -> TestAction -> ShowS
$cshowsPrec :: Int -> TestAction -> ShowS
Show)

-- | Input and output pairs for some entry point(s).
data InputOutputs = InputOutputs
  { InputOutputs -> Text
iosEntryPoint :: T.Text,
    InputOutputs -> [TestRun]
iosTestRuns :: [TestRun]
  }
  deriving (Int -> InputOutputs -> ShowS
[InputOutputs] -> ShowS
InputOutputs -> String
(Int -> InputOutputs -> ShowS)
-> (InputOutputs -> String)
-> ([InputOutputs] -> ShowS)
-> Show InputOutputs
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [InputOutputs] -> ShowS
$cshowList :: [InputOutputs] -> ShowS
show :: InputOutputs -> String
$cshow :: InputOutputs -> String
showsPrec :: Int -> InputOutputs -> ShowS
$cshowsPrec :: Int -> InputOutputs -> ShowS
Show)

-- | The error expected for a negative test.
data ExpectedError
  = AnyError
  | ThisError T.Text Regex

instance Show ExpectedError where
  show :: ExpectedError -> String
show ExpectedError
AnyError = String
"AnyError"
  show (ThisError Text
r Regex
_) = String
"ThisError " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Text -> String
forall a. Show a => a -> String
show Text
r

-- | How a program can be transformed.
data StructurePipeline
  = KernelsPipeline
  | SOACSPipeline
  | SequentialCpuPipeline
  | GpuPipeline
  | NoPipeline
  deriving (Int -> StructurePipeline -> ShowS
[StructurePipeline] -> ShowS
StructurePipeline -> String
(Int -> StructurePipeline -> ShowS)
-> (StructurePipeline -> String)
-> ([StructurePipeline] -> ShowS)
-> Show StructurePipeline
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [StructurePipeline] -> ShowS
$cshowList :: [StructurePipeline] -> ShowS
show :: StructurePipeline -> String
$cshow :: StructurePipeline -> String
showsPrec :: Int -> StructurePipeline -> ShowS
$cshowsPrec :: Int -> StructurePipeline -> ShowS
Show)

-- | A structure test specifies a compilation pipeline, as well as
-- metrics for the program coming out the other end.
data StructureTest = StructureTest StructurePipeline AstMetrics
  deriving (Int -> StructureTest -> ShowS
[StructureTest] -> ShowS
StructureTest -> String
(Int -> StructureTest -> ShowS)
-> (StructureTest -> String)
-> ([StructureTest] -> ShowS)
-> Show StructureTest
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [StructureTest] -> ShowS
$cshowList :: [StructureTest] -> ShowS
show :: StructureTest -> String
$cshow :: StructureTest -> String
showsPrec :: Int -> StructureTest -> ShowS
$cshowsPrec :: Int -> StructureTest -> ShowS
Show)

-- | A warning test requires that a warning matching the regular
-- expression is produced.  The program must also compile succesfully.
data WarningTest = ExpectedWarning T.Text Regex

instance Show WarningTest where
  show :: WarningTest -> String
show (ExpectedWarning Text
r Regex
_) = String
"ExpectedWarning " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Text -> String
T.unpack Text
r

-- | A condition for execution, input, and expected result.
data TestRun = TestRun
  { TestRun -> [String]
runTags :: [String],
    TestRun -> Values
runInput :: Values,
    TestRun -> ExpectedResult Success
runExpectedResult :: ExpectedResult Success,
    TestRun -> Int
runIndex :: Int,
    TestRun -> String
runDescription :: String
  }
  deriving (Int -> TestRun -> ShowS
[TestRun] -> ShowS
TestRun -> String
(Int -> TestRun -> ShowS)
-> (TestRun -> String) -> ([TestRun] -> ShowS) -> Show TestRun
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TestRun] -> ShowS
$cshowList :: [TestRun] -> ShowS
show :: TestRun -> String
$cshow :: TestRun -> String
showsPrec :: Int -> TestRun -> ShowS
$cshowsPrec :: Int -> TestRun -> ShowS
Show)

-- | Several Values - either literally, or by reference to a file, or
-- to be generated on demand.
data Values
  = Values [Value]
  | InFile FilePath
  | GenValues [GenValue]
  deriving (Int -> Values -> ShowS
[Values] -> ShowS
Values -> String
(Int -> Values -> ShowS)
-> (Values -> String) -> ([Values] -> ShowS) -> Show Values
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Values] -> ShowS
$cshowList :: [Values] -> ShowS
show :: Values -> String
$cshow :: Values -> String
showsPrec :: Int -> Values -> ShowS
$cshowsPrec :: Int -> Values -> ShowS
Show)

data GenValue
  = -- | Generate a value of the given rank and primitive
    -- type.  Scalars are considered 0-ary arrays.
    GenValue ValueType
  | -- | A fixed non-randomised primitive value.
    GenPrim PrimValue
  deriving (Int -> GenValue -> ShowS
[GenValue] -> ShowS
GenValue -> String
(Int -> GenValue -> ShowS)
-> (GenValue -> String) -> ([GenValue] -> ShowS) -> Show GenValue
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [GenValue] -> ShowS
$cshowList :: [GenValue] -> ShowS
show :: GenValue -> String
$cshow :: GenValue -> String
showsPrec :: Int -> GenValue -> ShowS
$cshowsPrec :: Int -> GenValue -> ShowS
Show)

-- | A prettyprinted representation of type of value produced by a
-- 'GenValue'.
genValueType :: GenValue -> String
genValueType :: GenValue -> String
genValueType (GenValue (ValueType [Int]
ds PrimType
t)) =
  (Int -> String) -> [Int] -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\Int
d -> String
"[" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
d String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"]") [Int]
ds String -> ShowS
forall a. [a] -> [a] -> [a]
++ PrimType -> String
forall a. Pretty a => a -> String
pretty PrimType
t
genValueType (GenPrim PrimValue
v) =
  PrimValue -> String
forall a. Pretty a => a -> String
pretty PrimValue
v

-- | How a test case is expected to terminate.
data ExpectedResult values
  = -- | Execution suceeds, with or without
    -- expected result values.
    Succeeds (Maybe values)
  | -- | Execution fails with this error.
    RunTimeFailure ExpectedError
  deriving (Int -> ExpectedResult values -> ShowS
[ExpectedResult values] -> ShowS
ExpectedResult values -> String
(Int -> ExpectedResult values -> ShowS)
-> (ExpectedResult values -> String)
-> ([ExpectedResult values] -> ShowS)
-> Show (ExpectedResult values)
forall values. Show values => Int -> ExpectedResult values -> ShowS
forall values. Show values => [ExpectedResult values] -> ShowS
forall values. Show values => ExpectedResult values -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ExpectedResult values] -> ShowS
$cshowList :: forall values. Show values => [ExpectedResult values] -> ShowS
show :: ExpectedResult values -> String
$cshow :: forall values. Show values => ExpectedResult values -> String
showsPrec :: Int -> ExpectedResult values -> ShowS
$cshowsPrec :: forall values. Show values => Int -> ExpectedResult values -> ShowS
Show)

-- | The result expected from a succesful execution.
data Success
  = -- | These values are expected.
    SuccessValues Values
  | -- | Compute expected values from executing a known-good
    -- reference implementation.
    SuccessGenerateValues
  deriving (Int -> Success -> ShowS
[Success] -> ShowS
Success -> String
(Int -> Success -> ShowS)
-> (Success -> String) -> ([Success] -> ShowS) -> Show Success
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Success] -> ShowS
$cshowList :: [Success] -> ShowS
show :: Success -> String
$cshow :: Success -> String
showsPrec :: Int -> Success -> ShowS
$cshowsPrec :: Int -> Success -> ShowS
Show)

type Parser = Parsec Void T.Text

postlexeme :: Parser ()
postlexeme :: Parser ()
postlexeme = ParsecT Void Text Identity (Maybe ()) -> Parser ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ParsecT Void Text Identity (Maybe ()) -> Parser ())
-> ParsecT Void Text Identity (Maybe ()) -> Parser ()
forall a b. (a -> b) -> a -> b
$ Parser ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
hspace Parser ()
-> ParsecT Void Text Identity (Maybe ())
-> ParsecT Void Text Identity (Maybe ())
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser () -> ParsecT Void Text Identity (Maybe ())
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (Parser () -> Parser ()
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (Parser () -> Parser ()) -> Parser () -> Parser ()
forall a b. (a -> b) -> a -> b
$ ParsecT Void Text Identity Text
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Tokens s)
eol ParsecT Void Text Identity Text
-> ParsecT Void Text Identity Text
-> ParsecT Void Text Identity Text
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT Void Text Identity Text
"--" ParsecT Void Text Identity Text -> Parser () -> Parser ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser ()
postlexeme)

lexeme :: Parser a -> Parser a
lexeme :: Parser a -> Parser a
lexeme Parser a
p = Parser a
p Parser a -> Parser () -> Parser a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
postlexeme

-- Like 'lexeme', but does not consume trailing linebreaks.
lexeme' :: Parser a -> Parser a
lexeme' :: Parser a -> Parser a
lexeme' Parser a
p = Parser a
p Parser a -> Parser () -> Parser a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
hspace

lexstr :: T.Text -> Parser ()
lexstr :: Text -> Parser ()
lexstr = ParsecT Void Text Identity Text -> Parser ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ParsecT Void Text Identity Text -> Parser ())
-> (Text -> ParsecT Void Text Identity Text) -> Text -> Parser ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParsecT Void Text Identity Text -> ParsecT Void Text Identity Text
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (ParsecT Void Text Identity Text
 -> ParsecT Void Text Identity Text)
-> (Text -> ParsecT Void Text Identity Text)
-> Text
-> ParsecT Void Text Identity Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParsecT Void Text Identity Text -> ParsecT Void Text Identity Text
forall a. Parser a -> Parser a
lexeme (ParsecT Void Text Identity Text
 -> ParsecT Void Text Identity Text)
-> (Text -> ParsecT Void Text Identity Text)
-> Text
-> ParsecT Void Text Identity Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ParsecT Void Text Identity Text
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string

-- Like 'lexstr', but does not consume trailing linebreaks.
lexstr' :: T.Text -> Parser ()
lexstr' :: Text -> Parser ()
lexstr' = ParsecT Void Text Identity Text -> Parser ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ParsecT Void Text Identity Text -> Parser ())
-> (Text -> ParsecT Void Text Identity Text) -> Text -> Parser ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParsecT Void Text Identity Text -> ParsecT Void Text Identity Text
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (ParsecT Void Text Identity Text
 -> ParsecT Void Text Identity Text)
-> (Text -> ParsecT Void Text Identity Text)
-> Text
-> ParsecT Void Text Identity Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParsecT Void Text Identity Text -> ParsecT Void Text Identity Text
forall a. Parser a -> Parser a
lexeme' (ParsecT Void Text Identity Text
 -> ParsecT Void Text Identity Text)
-> (Text -> ParsecT Void Text Identity Text)
-> Text
-> ParsecT Void Text Identity Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ParsecT Void Text Identity Text
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string

braces :: Parser a -> Parser a
braces :: Parser a -> Parser a
braces Parser a
p = Text -> Parser ()
lexstr Text
"{" Parser () -> Parser a -> Parser a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser a
p Parser a -> Parser () -> Parser a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Text -> Parser ()
lexstr Text
"}"

parseNatural :: Parser Int
parseNatural :: Parser Int
parseNatural =
  Parser Int -> Parser Int
forall a. Parser a -> Parser a
lexeme (Parser Int -> Parser Int) -> Parser Int -> Parser Int
forall a b. (a -> b) -> a -> b
$
    (Int -> Int -> Int) -> Int -> [Int] -> Int
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\Int
acc Int
x -> Int
acc Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
10 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
x) Int
0
      ([Int] -> Int) -> (String -> [Int]) -> String -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Int) -> String -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map Char -> Int
num
      (String -> Int) -> ParsecT Void Text Identity String -> Parser Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void Text Identity Char
-> ParsecT Void Text Identity String
forall (f :: * -> *) a. Alternative f => f a -> f [a]
some ParsecT Void Text Identity Char
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
digitChar
  where
    num :: Char -> Int
num Char
c = Char -> Int
ord Char
c Int -> Int -> Int
forall a. Num a => a -> a -> a
- Char -> Int
ord Char
'0'

restOfLine :: Parser T.Text
restOfLine :: ParsecT Void Text Identity Text
restOfLine = do
  Text
l <- ParsecT Void Text Identity Text
restOfLine_
  if Text -> Bool
T.null Text
l then ParsecT Void Text Identity Text -> Parser ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void ParsecT Void Text Identity Text
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Tokens s)
eol else ParsecT Void Text Identity Text -> Parser ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void ParsecT Void Text Identity Text
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Tokens s)
eol Parser () -> Parser () -> Parser ()
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser ()
forall e s (m :: * -> *). MonadParsec e s m => m ()
eof
  Text -> ParsecT Void Text Identity Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
l

restOfLine_ :: Parser T.Text
restOfLine_ :: ParsecT Void Text Identity Text
restOfLine_ = Maybe String
-> (Token Text -> Bool) -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe String -> (Token s -> Bool) -> m (Tokens s)
takeWhileP Maybe String
forall a. Maybe a
Nothing (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'\n')

parseDescription :: Parser T.Text
parseDescription :: ParsecT Void Text Identity Text
parseDescription =
  [Text] -> Text
T.unlines ([Text] -> Text)
-> ParsecT Void Text Identity [Text]
-> ParsecT Void Text Identity Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void Text Identity Text
pDescLine ParsecT Void Text Identity Text
-> Parser () -> ParsecT Void Text Identity [Text]
forall (m :: * -> *) a end. MonadPlus m => m a -> m end -> m [a]
`manyTill` Parser ()
pDescriptionSeparator
  where
    pDescLine :: ParsecT Void Text Identity Text
pDescLine = ParsecT Void Text Identity Text
"--" ParsecT Void Text Identity Text
-> ParsecT Void Text Identity Text
-> ParsecT Void Text Identity Text
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT Void Text Identity Text
restOfLine
    pDescriptionSeparator :: Parser ()
pDescriptionSeparator = Parser () -> Parser ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Parser () -> Parser ()) -> Parser () -> Parser ()
forall a b. (a -> b) -> a -> b
$ ParsecT Void Text Identity Text
"-- ==" ParsecT Void Text Identity Text -> Parser () -> Parser ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser ()
postlexeme

parseTags :: Parser [T.Text]
parseTags :: ParsecT Void Text Identity [Text]
parseTags = ParsecT Void Text Identity Text -> ParsecT Void Text Identity Text
forall a. Parser a -> Parser a
lexeme' ParsecT Void Text Identity Text
"tags" ParsecT Void Text Identity Text
-> ParsecT Void Text Identity [Text]
-> ParsecT Void Text Identity [Text]
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT Void Text Identity [Text]
-> ParsecT Void Text Identity [Text]
forall a. Parser a -> Parser a
braces (ParsecT Void Text Identity Text
-> ParsecT Void Text Identity [Text]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many ParsecT Void Text Identity Text
parseTag) ParsecT Void Text Identity [Text]
-> ParsecT Void Text Identity [Text]
-> ParsecT Void Text Identity [Text]
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> [Text] -> ParsecT Void Text Identity [Text]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
  where
    parseTag :: ParsecT Void Text Identity Text
parseTag = String -> Text
T.pack (String -> Text)
-> ParsecT Void Text Identity String
-> ParsecT Void Text Identity Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void Text Identity String
-> ParsecT Void Text Identity String
forall a. Parser a -> Parser a
lexeme (ParsecT Void Text Identity Char
-> ParsecT Void Text Identity String
forall (f :: * -> *) a. Alternative f => f a -> f [a]
some (ParsecT Void Text Identity Char
 -> ParsecT Void Text Identity String)
-> ParsecT Void Text Identity Char
-> ParsecT Void Text Identity String
forall a b. (a -> b) -> a -> b
$ (Token Text -> Bool) -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
(Token s -> Bool) -> m (Token s)
satisfy Char -> Bool
Token Text -> Bool
tagConstituent)

tagConstituent :: Char -> Bool
tagConstituent :: Char -> Bool
tagConstituent Char
c = Char -> Bool
isAlphaNum Char
c Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'_' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'-'

parseAction :: Parser TestAction
parseAction :: Parser TestAction
parseAction =
  ExpectedError -> TestAction
CompileTimeFailure (ExpectedError -> TestAction)
-> ParsecT Void Text Identity ExpectedError -> Parser TestAction
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Text -> Parser ()
lexstr' Text
"error:" Parser ()
-> ParsecT Void Text Identity ExpectedError
-> ParsecT Void Text Identity ExpectedError
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT Void Text Identity ExpectedError
parseExpectedError)
    Parser TestAction -> Parser TestAction -> Parser TestAction
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ( [InputOutputs] -> [StructureTest] -> [WarningTest] -> TestAction
RunCases ([InputOutputs] -> [StructureTest] -> [WarningTest] -> TestAction)
-> ParsecT Void Text Identity [InputOutputs]
-> ParsecT
     Void Text Identity ([StructureTest] -> [WarningTest] -> TestAction)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void Text Identity [InputOutputs]
parseInputOutputs
            ParsecT
  Void Text Identity ([StructureTest] -> [WarningTest] -> TestAction)
-> ParsecT Void Text Identity [StructureTest]
-> ParsecT Void Text Identity ([WarningTest] -> TestAction)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ParsecT Void Text Identity StructureTest
-> ParsecT Void Text Identity [StructureTest]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many ParsecT Void Text Identity StructureTest
parseExpectedStructure
            ParsecT Void Text Identity ([WarningTest] -> TestAction)
-> ParsecT Void Text Identity [WarningTest] -> Parser TestAction
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ParsecT Void Text Identity WarningTest
-> ParsecT Void Text Identity [WarningTest]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many ParsecT Void Text Identity WarningTest
parseWarning
        )

parseInputOutputs :: Parser [InputOutputs]
parseInputOutputs :: ParsecT Void Text Identity [InputOutputs]
parseInputOutputs = do
  [Text]
entrys <- ParsecT Void Text Identity [Text]
parseEntryPoints
  [TestRun]
cases <- Parser [TestRun]
parseRunCases
  [InputOutputs] -> ParsecT Void Text Identity [InputOutputs]
forall (m :: * -> *) a. Monad m => a -> m a
return ([InputOutputs] -> ParsecT Void Text Identity [InputOutputs])
-> [InputOutputs] -> ParsecT Void Text Identity [InputOutputs]
forall a b. (a -> b) -> a -> b
$
    if [TestRun] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TestRun]
cases
      then []
      else (Text -> InputOutputs) -> [Text] -> [InputOutputs]
forall a b. (a -> b) -> [a] -> [b]
map (Text -> [TestRun] -> InputOutputs
`InputOutputs` [TestRun]
cases) [Text]
entrys

parseEntryPoints :: Parser [T.Text]
parseEntryPoints :: ParsecT Void Text Identity [Text]
parseEntryPoints =
  (ParsecT Void Text Identity Text -> ParsecT Void Text Identity Text
forall a. Parser a -> Parser a
lexeme' ParsecT Void Text Identity Text
"entry:" ParsecT Void Text Identity Text
-> ParsecT Void Text Identity [Text]
-> ParsecT Void Text Identity [Text]
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT Void Text Identity Text
-> ParsecT Void Text Identity [Text]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many ParsecT Void Text Identity Text
entry ParsecT Void Text Identity [Text]
-> Parser () -> ParsecT Void Text Identity [Text]
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
postlexeme)
    ParsecT Void Text Identity [Text]
-> ParsecT Void Text Identity [Text]
-> ParsecT Void Text Identity [Text]
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> [Text] -> ParsecT Void Text Identity [Text]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Text
"main"]
  where
    constituent :: Char -> Bool
constituent Char
c = Bool -> Bool
not (Char -> Bool
isSpace Char
c) Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'}'
    entry :: ParsecT Void Text Identity Text
entry = ParsecT Void Text Identity Text -> ParsecT Void Text Identity Text
forall a. Parser a -> Parser a
lexeme' (ParsecT Void Text Identity Text
 -> ParsecT Void Text Identity Text)
-> ParsecT Void Text Identity Text
-> ParsecT Void Text Identity Text
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text)
-> ParsecT Void Text Identity String
-> ParsecT Void Text Identity Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void Text Identity Char
-> ParsecT Void Text Identity String
forall (f :: * -> *) a. Alternative f => f a -> f [a]
some ((Token Text -> Bool) -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
(Token s -> Bool) -> m (Token s)
satisfy Char -> Bool
Token Text -> Bool
constituent)

parseRunTags :: Parser [String]
parseRunTags :: Parser [String]
parseRunTags = ParsecT Void Text Identity String -> Parser [String]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many (ParsecT Void Text Identity String -> Parser [String])
-> (ParsecT Void Text Identity String
    -> ParsecT Void Text Identity String)
-> ParsecT Void Text Identity String
-> Parser [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParsecT Void Text Identity String
-> ParsecT Void Text Identity String
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (ParsecT Void Text Identity String
 -> ParsecT Void Text Identity String)
-> (ParsecT Void Text Identity String
    -> ParsecT Void Text Identity String)
-> ParsecT Void Text Identity String
-> ParsecT Void Text Identity String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParsecT Void Text Identity String
-> ParsecT Void Text Identity String
forall a. Parser a -> Parser a
lexeme' (ParsecT Void Text Identity String -> Parser [String])
-> ParsecT Void Text Identity String -> Parser [String]
forall a b. (a -> b) -> a -> b
$ do
  String
s <- ParsecT Void Text Identity Char
-> ParsecT Void Text Identity String
forall (f :: * -> *) a. Alternative f => f a -> f [a]
some (ParsecT Void Text Identity Char
 -> ParsecT Void Text Identity String)
-> ParsecT Void Text Identity Char
-> ParsecT Void Text Identity String
forall a b. (a -> b) -> a -> b
$ (Token Text -> Bool) -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
(Token s -> Bool) -> m (Token s)
satisfy Char -> Bool
Token Text -> Bool
tagConstituent
  Bool -> Parser ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Parser ()) -> Bool -> Parser ()
forall a b. (a -> b) -> a -> b
$ String
s String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [String
"input", String
"structure", String
"warning"]
  String -> ParsecT Void Text Identity String
forall (m :: * -> *) a. Monad m => a -> m a
return String
s

parseRunCases :: Parser [TestRun]
parseRunCases :: Parser [TestRun]
parseRunCases = Int -> Parser [TestRun]
parseRunCases' (Int
0 :: Int)
  where
    parseRunCases' :: Int -> Parser [TestRun]
parseRunCases' Int
i =
      (:) (TestRun -> [TestRun] -> [TestRun])
-> ParsecT Void Text Identity TestRun
-> ParsecT Void Text Identity ([TestRun] -> [TestRun])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> ParsecT Void Text Identity TestRun
parseRunCase Int
i ParsecT Void Text Identity ([TestRun] -> [TestRun])
-> Parser [TestRun] -> Parser [TestRun]
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Int -> Parser [TestRun]
parseRunCases' (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
        Parser [TestRun] -> Parser [TestRun] -> Parser [TestRun]
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> [TestRun] -> Parser [TestRun]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
    parseRunCase :: Int -> ParsecT Void Text Identity TestRun
parseRunCase Int
i = do
      [String]
tags <- Parser [String]
parseRunTags
      Text -> Parser ()
lexstr Text
"input"
      Values
input <-
        if String
"random" String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
tags
          then Parser Values
parseRandomValues
          else Parser Values
parseValues
      ExpectedResult Success
expr <- Parser (ExpectedResult Success)
parseExpectedResult
      TestRun -> ParsecT Void Text Identity TestRun
forall (m :: * -> *) a. Monad m => a -> m a
return (TestRun -> ParsecT Void Text Identity TestRun)
-> TestRun -> ParsecT Void Text Identity TestRun
forall a b. (a -> b) -> a -> b
$ [String]
-> Values -> ExpectedResult Success -> Int -> String -> TestRun
TestRun [String]
tags Values
input ExpectedResult Success
expr Int
i (String -> TestRun) -> String -> TestRun
forall a b. (a -> b) -> a -> b
$ Int -> Values -> String
forall a. Show a => a -> Values -> String
desc Int
i Values
input

    -- If the file is gzipped, we strip the 'gz' extension from
    -- the dataset name.  This makes it more convenient to rename
    -- from 'foo.in' to 'foo.in.gz', as the reported dataset name
    -- does not change (which would make comparisons to historical
    -- data harder).
    desc :: a -> Values -> String
desc a
_ (InFile String
path)
      | ShowS
takeExtension String
path String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
".gz" = ShowS
dropExtension String
path
      | Bool
otherwise = String
path
    desc a
i (Values [Value]
vs) =
      -- Turn linebreaks into space.
      String
"#" String -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
i String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" (\"" String -> ShowS
forall a. [a] -> [a] -> [a]
++ [String] -> String
unwords (String -> [String]
lines String
vs') String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\")"
      where
        vs' :: String
vs' = case [String] -> String
unwords ((Value -> String) -> [Value] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Value -> String
forall a. Pretty a => a -> String
pretty [Value]
vs) of
          String
s
            | String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
s Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
50 -> Int -> ShowS
forall a. Int -> [a] -> [a]
take Int
50 String
s String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"..."
            | Bool
otherwise -> String
s
    desc a
_ (GenValues [GenValue]
gens) =
      [String] -> String
unwords ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ (GenValue -> String) -> [GenValue] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map GenValue -> String
genValueType [GenValue]
gens

parseExpectedResult :: Parser (ExpectedResult Success)
parseExpectedResult :: Parser (ExpectedResult Success)
parseExpectedResult =
  (Text -> Parser ()
lexstr Text
"auto" Parser () -> Parser () -> Parser ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Text -> Parser ()
lexstr Text
"output" Parser ()
-> ExpectedResult Success -> Parser (ExpectedResult Success)
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Maybe Success -> ExpectedResult Success
forall values. Maybe values -> ExpectedResult values
Succeeds (Success -> Maybe Success
forall a. a -> Maybe a
Just Success
SuccessGenerateValues))
    Parser (ExpectedResult Success)
-> Parser (ExpectedResult Success)
-> Parser (ExpectedResult Success)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (Maybe Success -> ExpectedResult Success
forall values. Maybe values -> ExpectedResult values
Succeeds (Maybe Success -> ExpectedResult Success)
-> (Values -> Maybe Success) -> Values -> ExpectedResult Success
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Success -> Maybe Success
forall a. a -> Maybe a
Just (Success -> Maybe Success)
-> (Values -> Success) -> Values -> Maybe Success
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Values -> Success
SuccessValues (Values -> ExpectedResult Success)
-> Parser Values -> Parser (ExpectedResult Success)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Text -> Parser ()
lexstr Text
"output" Parser () -> Parser Values -> Parser Values
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Values
parseValues))
    Parser (ExpectedResult Success)
-> Parser (ExpectedResult Success)
-> Parser (ExpectedResult Success)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (ExpectedError -> ExpectedResult Success
forall values. ExpectedError -> ExpectedResult values
RunTimeFailure (ExpectedError -> ExpectedResult Success)
-> ParsecT Void Text Identity ExpectedError
-> Parser (ExpectedResult Success)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Text -> Parser ()
lexstr Text
"error:" Parser ()
-> ParsecT Void Text Identity ExpectedError
-> ParsecT Void Text Identity ExpectedError
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT Void Text Identity ExpectedError
parseExpectedError))
    Parser (ExpectedResult Success)
-> Parser (ExpectedResult Success)
-> Parser (ExpectedResult Success)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ExpectedResult Success -> Parser (ExpectedResult Success)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Success -> ExpectedResult Success
forall values. Maybe values -> ExpectedResult values
Succeeds Maybe Success
forall a. Maybe a
Nothing)

parseExpectedError :: Parser ExpectedError
parseExpectedError :: ParsecT Void Text Identity ExpectedError
parseExpectedError = ParsecT Void Text Identity ExpectedError
-> ParsecT Void Text Identity ExpectedError
forall a. Parser a -> Parser a
lexeme (ParsecT Void Text Identity ExpectedError
 -> ParsecT Void Text Identity ExpectedError)
-> ParsecT Void Text Identity ExpectedError
-> ParsecT Void Text Identity ExpectedError
forall a b. (a -> b) -> a -> b
$ do
  Text
s <- Text -> Text
T.strip (Text -> Text)
-> ParsecT Void Text Identity Text
-> ParsecT Void Text Identity Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void Text Identity Text
restOfLine_ ParsecT Void Text Identity Text
-> Parser () -> ParsecT Void Text Identity Text
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
postlexeme
  if Text -> Bool
T.null Text
s
    then ExpectedError -> ParsecT Void Text Identity ExpectedError
forall (m :: * -> *) a. Monad m => a -> m a
return ExpectedError
AnyError
    else -- blankCompOpt creates a regular expression that treats
    -- newlines like ordinary characters, which is what we want.
      Text -> Regex -> ExpectedError
ThisError Text
s (Regex -> ExpectedError)
-> ParsecT Void Text Identity Regex
-> ParsecT Void Text Identity ExpectedError
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CompOption
-> ExecOption -> String -> ParsecT Void Text Identity Regex
forall regex compOpt execOpt source (m :: * -> *).
(RegexMaker regex compOpt execOpt source, MonadFail m) =>
compOpt -> execOpt -> source -> m regex
makeRegexOptsM CompOption
forall regex compOpt execOpt.
RegexOptions regex compOpt execOpt =>
compOpt
blankCompOpt ExecOption
forall regex compOpt execOpt.
RegexOptions regex compOpt execOpt =>
execOpt
defaultExecOpt (Text -> String
T.unpack Text
s)

parseRandomValues :: Parser Values
parseRandomValues :: Parser Values
parseRandomValues = [GenValue] -> Values
GenValues ([GenValue] -> Values)
-> ParsecT Void Text Identity [GenValue] -> Parser Values
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ()
-> Parser ()
-> ParsecT Void Text Identity [GenValue]
-> ParsecT Void Text Identity [GenValue]
forall (m :: * -> *) open close a.
Applicative m =>
m open -> m close -> m a -> m a
between (Text -> Parser ()
lexstr Text
"{") (Text -> Parser ()
lexstr Text
"}") (ParsecT Void Text Identity GenValue
-> ParsecT Void Text Identity [GenValue]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many ParsecT Void Text Identity GenValue
parseGenValue)

parseGenValue :: Parser GenValue
parseGenValue :: ParsecT Void Text Identity GenValue
parseGenValue =
  [ParsecT Void Text Identity GenValue]
-> ParsecT Void Text Identity GenValue
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice
    [ ValueType -> GenValue
GenValue (ValueType -> GenValue)
-> ParsecT Void Text Identity ValueType
-> ParsecT Void Text Identity GenValue
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void Text Identity ValueType
-> ParsecT Void Text Identity ValueType
forall a. Parser a -> Parser a
lexeme ParsecT Void Text Identity ValueType
parseType,
      PrimValue -> GenValue
GenPrim (PrimValue -> GenValue)
-> ParsecT Void Text Identity PrimValue
-> ParsecT Void Text Identity GenValue
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void Text Identity PrimValue
-> ParsecT Void Text Identity PrimValue
forall a. Parser a -> Parser a
lexeme ParsecT Void Text Identity PrimValue
parsePrimValue
    ]

parseValues :: Parser Values
parseValues :: Parser Values
parseValues =
  [Parser Values] -> Parser Values
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice
    [ [Value] -> Values
Values ([Value] -> Values)
-> ParsecT Void Text Identity [Value] -> Parser Values
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void Text Identity [Value]
-> ParsecT Void Text Identity [Value]
forall a. Parser a -> Parser a
braces (ParsecT Void Text Identity Value
-> ParsecT Void Text Identity [Value]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many (ParsecT Void Text Identity Value
 -> ParsecT Void Text Identity [Value])
-> ParsecT Void Text Identity Value
-> ParsecT Void Text Identity [Value]
forall a b. (a -> b) -> a -> b
$ Parser () -> ParsecT Void Text Identity Value
parseValue Parser ()
postlexeme),
      String -> Values
InFile (String -> Values) -> (Text -> String) -> Text -> Values
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack (Text -> Values)
-> ParsecT Void Text Identity Text -> Parser Values
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Text -> Parser ()
lexstr Text
"@" Parser ()
-> ParsecT Void Text Identity Text
-> ParsecT Void Text Identity Text
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT Void Text Identity Text -> ParsecT Void Text Identity Text
forall a. Parser a -> Parser a
lexeme ParsecT Void Text Identity Text
ParsecT Void Text Identity (Tokens Text)
nextWord)
    ]
  where
    nextWord :: ParsecT Void Text Identity (Tokens Text)
nextWord = Maybe String
-> (Token Text -> Bool) -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe String -> (Token s -> Bool) -> m (Tokens s)
takeWhileP Maybe String
forall a. Maybe a
Nothing ((Token Text -> Bool) -> ParsecT Void Text Identity (Tokens Text))
-> (Token Text -> Bool) -> ParsecT Void Text Identity (Tokens Text)
forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not (Bool -> Bool) -> (Char -> Bool) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Bool
isSpace

parseWarning :: Parser WarningTest
parseWarning :: ParsecT Void Text Identity WarningTest
parseWarning = Text -> Parser ()
lexstr Text
"warning:" Parser ()
-> ParsecT Void Text Identity WarningTest
-> ParsecT Void Text Identity WarningTest
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ParsecT Void Text Identity WarningTest
parseExpectedWarning
  where
    parseExpectedWarning :: ParsecT Void Text Identity WarningTest
parseExpectedWarning = ParsecT Void Text Identity WarningTest
-> ParsecT Void Text Identity WarningTest
forall a. Parser a -> Parser a
lexeme (ParsecT Void Text Identity WarningTest
 -> ParsecT Void Text Identity WarningTest)
-> ParsecT Void Text Identity WarningTest
-> ParsecT Void Text Identity WarningTest
forall a b. (a -> b) -> a -> b
$ do
      Text
s <- Text -> Text
T.strip (Text -> Text)
-> ParsecT Void Text Identity Text
-> ParsecT Void Text Identity Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void Text Identity Text
restOfLine_
      Text -> Regex -> WarningTest
ExpectedWarning Text
s (Regex -> WarningTest)
-> ParsecT Void Text Identity Regex
-> ParsecT Void Text Identity WarningTest
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CompOption
-> ExecOption -> String -> ParsecT Void Text Identity Regex
forall regex compOpt execOpt source (m :: * -> *).
(RegexMaker regex compOpt execOpt source, MonadFail m) =>
compOpt -> execOpt -> source -> m regex
makeRegexOptsM CompOption
forall regex compOpt execOpt.
RegexOptions regex compOpt execOpt =>
compOpt
blankCompOpt ExecOption
forall regex compOpt execOpt.
RegexOptions regex compOpt execOpt =>
execOpt
defaultExecOpt (Text -> String
T.unpack Text
s)

parseExpectedStructure :: Parser StructureTest
parseExpectedStructure :: ParsecT Void Text Identity StructureTest
parseExpectedStructure =
  Text -> Parser ()
lexstr Text
"structure"
    Parser ()
-> ParsecT Void Text Identity StructureTest
-> ParsecT Void Text Identity StructureTest
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (StructurePipeline -> AstMetrics -> StructureTest
StructureTest (StructurePipeline -> AstMetrics -> StructureTest)
-> ParsecT Void Text Identity StructurePipeline
-> ParsecT Void Text Identity (AstMetrics -> StructureTest)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void Text Identity StructurePipeline
optimisePipeline ParsecT Void Text Identity (AstMetrics -> StructureTest)
-> ParsecT Void Text Identity AstMetrics
-> ParsecT Void Text Identity StructureTest
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ParsecT Void Text Identity AstMetrics
parseMetrics)

optimisePipeline :: Parser StructurePipeline
optimisePipeline :: ParsecT Void Text Identity StructurePipeline
optimisePipeline =
  Text -> Parser ()
lexstr Text
"distributed" Parser ()
-> StructurePipeline
-> ParsecT Void Text Identity StructurePipeline
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> StructurePipeline
KernelsPipeline
    ParsecT Void Text Identity StructurePipeline
-> ParsecT Void Text Identity StructurePipeline
-> ParsecT Void Text Identity StructurePipeline
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Text -> Parser ()
lexstr Text
"gpu" Parser ()
-> StructurePipeline
-> ParsecT Void Text Identity StructurePipeline
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> StructurePipeline
GpuPipeline
    ParsecT Void Text Identity StructurePipeline
-> ParsecT Void Text Identity StructurePipeline
-> ParsecT Void Text Identity StructurePipeline
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Text -> Parser ()
lexstr Text
"cpu" Parser ()
-> StructurePipeline
-> ParsecT Void Text Identity StructurePipeline
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> StructurePipeline
SequentialCpuPipeline
    ParsecT Void Text Identity StructurePipeline
-> ParsecT Void Text Identity StructurePipeline
-> ParsecT Void Text Identity StructurePipeline
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Text -> Parser ()
lexstr Text
"internalised" Parser ()
-> StructurePipeline
-> ParsecT Void Text Identity StructurePipeline
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> StructurePipeline
NoPipeline
    ParsecT Void Text Identity StructurePipeline
-> ParsecT Void Text Identity StructurePipeline
-> ParsecT Void Text Identity StructurePipeline
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> StructurePipeline -> ParsecT Void Text Identity StructurePipeline
forall (f :: * -> *) a. Applicative f => a -> f a
pure StructurePipeline
SOACSPipeline

parseMetrics :: Parser AstMetrics
parseMetrics :: ParsecT Void Text Identity AstMetrics
parseMetrics =
  ParsecT Void Text Identity AstMetrics
-> ParsecT Void Text Identity AstMetrics
forall a. Parser a -> Parser a
braces (ParsecT Void Text Identity AstMetrics
 -> ParsecT Void Text Identity AstMetrics)
-> ParsecT Void Text Identity AstMetrics
-> ParsecT Void Text Identity AstMetrics
forall a b. (a -> b) -> a -> b
$
    ([(Text, Int)] -> AstMetrics)
-> ParsecT Void Text Identity [(Text, Int)]
-> ParsecT Void Text Identity AstMetrics
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Map Text Int -> AstMetrics
AstMetrics (Map Text Int -> AstMetrics)
-> ([(Text, Int)] -> Map Text Int) -> [(Text, Int)] -> AstMetrics
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Text, Int)] -> Map Text Int
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList) (ParsecT Void Text Identity [(Text, Int)]
 -> ParsecT Void Text Identity AstMetrics)
-> ParsecT Void Text Identity [(Text, Int)]
-> ParsecT Void Text Identity AstMetrics
forall a b. (a -> b) -> a -> b
$
      ParsecT Void Text Identity (Text, Int)
-> ParsecT Void Text Identity [(Text, Int)]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many (ParsecT Void Text Identity (Text, Int)
 -> ParsecT Void Text Identity [(Text, Int)])
-> ParsecT Void Text Identity (Text, Int)
-> ParsecT Void Text Identity [(Text, Int)]
forall a b. (a -> b) -> a -> b
$
        (,) (Text -> Int -> (Text, Int))
-> ParsecT Void Text Identity Text
-> ParsecT Void Text Identity (Int -> (Text, Int))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (String -> Text
T.pack (String -> Text)
-> ParsecT Void Text Identity String
-> ParsecT Void Text Identity Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void Text Identity String
-> ParsecT Void Text Identity String
forall a. Parser a -> Parser a
lexeme (ParsecT Void Text Identity Char
-> ParsecT Void Text Identity String
forall (f :: * -> *) a. Alternative f => f a -> f [a]
some ((Token Text -> Bool) -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
(Token s -> Bool) -> m (Token s)
satisfy Char -> Bool
Token Text -> Bool
constituent))) ParsecT Void Text Identity (Int -> (Text, Int))
-> Parser Int -> ParsecT Void Text Identity (Text, Int)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Int
parseNatural
  where
    constituent :: Char -> Bool
constituent Char
c = Char -> Bool
isAlpha Char
c Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'/'

testSpec :: Parser ProgramTest
testSpec :: Parser ProgramTest
testSpec =
  Text -> [Text] -> TestAction -> ProgramTest
ProgramTest (Text -> [Text] -> TestAction -> ProgramTest)
-> ParsecT Void Text Identity Text
-> ParsecT Void Text Identity ([Text] -> TestAction -> ProgramTest)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void Text Identity Text
parseDescription ParsecT Void Text Identity ([Text] -> TestAction -> ProgramTest)
-> ParsecT Void Text Identity [Text]
-> ParsecT Void Text Identity (TestAction -> ProgramTest)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ParsecT Void Text Identity [Text]
parseTags ParsecT Void Text Identity (TestAction -> ProgramTest)
-> Parser TestAction -> Parser ProgramTest
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser TestAction
parseAction

couldNotRead :: IOError -> IO (Either String a)
couldNotRead :: IOError -> IO (Either String a)
couldNotRead = Either String a -> IO (Either String a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String a -> IO (Either String a))
-> (IOError -> Either String a) -> IOError -> IO (Either String a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Either String a
forall a b. a -> Either a b
Left (String -> Either String a)
-> (IOError -> String) -> IOError -> Either String a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IOError -> String
forall a. Show a => a -> String
show

pProgramTest :: Parser ProgramTest
pProgramTest :: Parser ProgramTest
pProgramTest = do
  ParsecT Void Text Identity [()] -> Parser ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ParsecT Void Text Identity [()] -> Parser ())
-> ParsecT Void Text Identity [()] -> Parser ()
forall a b. (a -> b) -> a -> b
$ Parser () -> ParsecT Void Text Identity [()]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many Parser ()
pNonTestLine
  Maybe ProgramTest
maybe_spec <- Parser ProgramTest
-> ParsecT Void Text Identity (Maybe ProgramTest)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional Parser ProgramTest
testSpec ParsecT Void Text Identity (Maybe ProgramTest)
-> Parser () -> ParsecT Void Text Identity (Maybe ProgramTest)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
pEndOfTestBlock ParsecT Void Text Identity (Maybe ProgramTest)
-> ParsecT Void Text Identity [()]
-> ParsecT Void Text Identity (Maybe ProgramTest)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser () -> ParsecT Void Text Identity [()]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many Parser ()
pNonTestLine
  case Maybe ProgramTest
maybe_spec of
    Just ProgramTest
spec
      | RunCases [InputOutputs]
old_cases [StructureTest]
structures [WarningTest]
warnings <- ProgramTest -> TestAction
testAction ProgramTest
spec -> do
        [[InputOutputs]]
cases <- ParsecT Void Text Identity [InputOutputs]
-> ParsecT Void Text Identity [[InputOutputs]]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many (ParsecT Void Text Identity [InputOutputs]
 -> ParsecT Void Text Identity [[InputOutputs]])
-> ParsecT Void Text Identity [InputOutputs]
-> ParsecT Void Text Identity [[InputOutputs]]
forall a b. (a -> b) -> a -> b
$ ParsecT Void Text Identity [InputOutputs]
pInputOutputs ParsecT Void Text Identity [InputOutputs]
-> ParsecT Void Text Identity [()]
-> ParsecT Void Text Identity [InputOutputs]
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser () -> ParsecT Void Text Identity [()]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many Parser ()
pNonTestLine
        ProgramTest -> Parser ProgramTest
forall (f :: * -> *) a. Applicative f => a -> f a
pure ProgramTest
spec {testAction :: TestAction
testAction = [InputOutputs] -> [StructureTest] -> [WarningTest] -> TestAction
RunCases ([InputOutputs]
old_cases [InputOutputs] -> [InputOutputs] -> [InputOutputs]
forall a. [a] -> [a] -> [a]
++ [[InputOutputs]] -> [InputOutputs]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[InputOutputs]]
cases) [StructureTest]
structures [WarningTest]
warnings}
      | Bool
otherwise ->
        Parser () -> ParsecT Void Text Identity [()]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many Parser ()
pNonTestLine ParsecT Void Text Identity [()] -> Parser () -> Parser ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT Void Text Identity Text -> Parser ()
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m ()
notFollowedBy ParsecT Void Text Identity Text
"-- ==" Parser () -> Parser ProgramTest -> Parser ProgramTest
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ProgramTest -> Parser ProgramTest
forall (f :: * -> *) a. Applicative f => a -> f a
pure ProgramTest
spec
          Parser ProgramTest -> String -> Parser ProgramTest
forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> String -> m a
<?> String
"no more test blocks, since first test block specifies type error."
    Maybe ProgramTest
Nothing ->
      Parser ()
forall e s (m :: * -> *). MonadParsec e s m => m ()
eof Parser () -> ProgramTest -> Parser ProgramTest
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> ProgramTest
noTest
  where
    noTest :: ProgramTest
noTest =
      Text -> [Text] -> TestAction -> ProgramTest
ProgramTest Text
forall a. Monoid a => a
mempty [Text]
forall a. Monoid a => a
mempty ([InputOutputs] -> [StructureTest] -> [WarningTest] -> TestAction
RunCases [InputOutputs]
forall a. Monoid a => a
mempty [StructureTest]
forall a. Monoid a => a
mempty [WarningTest]
forall a. Monoid a => a
mempty)

    pEndOfTestBlock :: Parser ()
pEndOfTestBlock =
      (ParsecT Void Text Identity (Tokens Text) -> Parser ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Tokens s)
eol Parser () -> Parser () -> Parser ()
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser ()
forall e s (m :: * -> *). MonadParsec e s m => m ()
eof) Parser () -> Parser () -> Parser ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT Void Text Identity Text -> Parser ()
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m ()
notFollowedBy ParsecT Void Text Identity Text
"--"
    pNonTestLine :: Parser ()
pNonTestLine =
      ParsecT Void Text Identity Text -> Parser ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ParsecT Void Text Identity Text -> Parser ())
-> ParsecT Void Text Identity Text -> Parser ()
forall a b. (a -> b) -> a -> b
$ ParsecT Void Text Identity Text -> Parser ()
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m ()
notFollowedBy ParsecT Void Text Identity Text
"-- ==" Parser ()
-> ParsecT Void Text Identity Text
-> ParsecT Void Text Identity Text
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT Void Text Identity Text
restOfLine
    pInputOutputs :: ParsecT Void Text Identity [InputOutputs]
pInputOutputs =
      ParsecT Void Text Identity Text
parseDescription ParsecT Void Text Identity Text
-> ParsecT Void Text Identity [InputOutputs]
-> ParsecT Void Text Identity [InputOutputs]
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT Void Text Identity [InputOutputs]
parseInputOutputs ParsecT Void Text Identity [InputOutputs]
-> Parser () -> ParsecT Void Text Identity [InputOutputs]
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
pEndOfTestBlock

-- | Read the test specification from the given Futhark program.
testSpecFromFile :: FilePath -> IO (Either String ProgramTest)
testSpecFromFile :: String -> IO (Either String ProgramTest)
testSpecFromFile String
path =
  ( (ParseErrorBundle Text Void -> Either String ProgramTest)
-> (ProgramTest -> Either String ProgramTest)
-> Either (ParseErrorBundle Text Void) ProgramTest
-> Either String ProgramTest
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (String -> Either String ProgramTest
forall a b. a -> Either a b
Left (String -> Either String ProgramTest)
-> (ParseErrorBundle Text Void -> String)
-> ParseErrorBundle Text Void
-> Either String ProgramTest
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParseErrorBundle Text Void -> String
forall s e.
(VisualStream s, TraversableStream s, ShowErrorComponent e) =>
ParseErrorBundle s e -> String
errorBundlePretty) ProgramTest -> Either String ProgramTest
forall a b. b -> Either a b
Right (Either (ParseErrorBundle Text Void) ProgramTest
 -> Either String ProgramTest)
-> (Text -> Either (ParseErrorBundle Text Void) ProgramTest)
-> Text
-> Either String ProgramTest
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Parser ProgramTest
-> String
-> Text
-> Either (ParseErrorBundle Text Void) ProgramTest
forall e s a.
Parsec e s a -> String -> s -> Either (ParseErrorBundle s e) a
parse Parser ProgramTest
pProgramTest String
path
      (Text -> Either String ProgramTest)
-> IO Text -> IO (Either String ProgramTest)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO Text
T.readFile String
path
  )
    IO (Either String ProgramTest)
-> (IOError -> IO (Either String ProgramTest))
-> IO (Either String ProgramTest)
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` IOError -> IO (Either String ProgramTest)
forall a. IOError -> IO (Either String a)
couldNotRead

-- | Like 'testSpecFromFile', but kills the process on error.
testSpecFromFileOrDie :: FilePath -> IO ProgramTest
testSpecFromFileOrDie :: String -> IO ProgramTest
testSpecFromFileOrDie String
prog = do
  Either String ProgramTest
spec_or_err <- String -> IO (Either String ProgramTest)
testSpecFromFile String
prog
  case Either String ProgramTest
spec_or_err of
    Left String
err -> do
      String -> IO ()
putStrLn String
err
      IO ProgramTest
forall a. IO a
exitFailure
    Right ProgramTest
spec -> ProgramTest -> IO ProgramTest
forall (m :: * -> *) a. Monad m => a -> m a
return ProgramTest
spec

-- | Read test specifications from the given path, which can be a file
-- or directory containing @.fut@ files and further directories.
testSpecsFromPath :: FilePath -> IO (Either String [(FilePath, ProgramTest)])
testSpecsFromPath :: String -> IO (Either String [(String, ProgramTest)])
testSpecsFromPath String
path = do
  Either String [String]
programs_or_err <- ([String] -> Either String [String]
forall a b. b -> Either a b
Right ([String] -> Either String [String])
-> IO [String] -> IO (Either String [String])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO [String]
testPrograms String
path) IO (Either String [String])
-> (IOError -> IO (Either String [String]))
-> IO (Either String [String])
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` IOError -> IO (Either String [String])
forall a. IOError -> IO (Either String a)
couldNotRead
  case Either String [String]
programs_or_err of
    Left String
err -> Either String [(String, ProgramTest)]
-> IO (Either String [(String, ProgramTest)])
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String [(String, ProgramTest)]
 -> IO (Either String [(String, ProgramTest)]))
-> Either String [(String, ProgramTest)]
-> IO (Either String [(String, ProgramTest)])
forall a b. (a -> b) -> a -> b
$ String -> Either String [(String, ProgramTest)]
forall a b. a -> Either a b
Left String
err
    Right [String]
programs -> do
      [Either String ProgramTest]
specs_or_errs <- (String -> IO (Either String ProgramTest))
-> [String] -> IO [Either String ProgramTest]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM String -> IO (Either String ProgramTest)
testSpecFromFile [String]
programs
      Either String [(String, ProgramTest)]
-> IO (Either String [(String, ProgramTest)])
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String [(String, ProgramTest)]
 -> IO (Either String [(String, ProgramTest)]))
-> Either String [(String, ProgramTest)]
-> IO (Either String [(String, ProgramTest)])
forall a b. (a -> b) -> a -> b
$ [String] -> [ProgramTest] -> [(String, ProgramTest)]
forall a b. [a] -> [b] -> [(a, b)]
zip [String]
programs ([ProgramTest] -> [(String, ProgramTest)])
-> Either String [ProgramTest]
-> Either String [(String, ProgramTest)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Either String ProgramTest] -> Either String [ProgramTest]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [Either String ProgramTest]
specs_or_errs

-- | Read test specifications from the given paths, which can be a
-- files or directories containing @.fut@ files and further
-- directories.
testSpecsFromPaths ::
  [FilePath] ->
  IO (Either String [(FilePath, ProgramTest)])
testSpecsFromPaths :: [String] -> IO (Either String [(String, ProgramTest)])
testSpecsFromPaths = ([Either String [(String, ProgramTest)]]
 -> Either String [(String, ProgramTest)])
-> IO [Either String [(String, ProgramTest)]]
-> IO (Either String [(String, ProgramTest)])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (([[(String, ProgramTest)]] -> [(String, ProgramTest)])
-> Either String [[(String, ProgramTest)]]
-> Either String [(String, ProgramTest)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[(String, ProgramTest)]] -> [(String, ProgramTest)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (Either String [[(String, ProgramTest)]]
 -> Either String [(String, ProgramTest)])
-> ([Either String [(String, ProgramTest)]]
    -> Either String [[(String, ProgramTest)]])
-> [Either String [(String, ProgramTest)]]
-> Either String [(String, ProgramTest)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Either String [(String, ProgramTest)]]
-> Either String [[(String, ProgramTest)]]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence) (IO [Either String [(String, ProgramTest)]]
 -> IO (Either String [(String, ProgramTest)]))
-> ([String] -> IO [Either String [(String, ProgramTest)]])
-> [String]
-> IO (Either String [(String, ProgramTest)])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> IO (Either String [(String, ProgramTest)]))
-> [String] -> IO [Either String [(String, ProgramTest)]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM String -> IO (Either String [(String, ProgramTest)])
testSpecsFromPath

-- | Like 'testSpecsFromPaths', but kills the process on errors.
testSpecsFromPathsOrDie ::
  [FilePath] ->
  IO [(FilePath, ProgramTest)]
testSpecsFromPathsOrDie :: [String] -> IO [(String, ProgramTest)]
testSpecsFromPathsOrDie [String]
dirs = do
  Either String [(String, ProgramTest)]
specs_or_err <- [String] -> IO (Either String [(String, ProgramTest)])
testSpecsFromPaths [String]
dirs
  case Either String [(String, ProgramTest)]
specs_or_err of
    Left String
err -> do
      String -> IO ()
putStrLn String
err
      IO [(String, ProgramTest)]
forall a. IO a
exitFailure
    Right [(String, ProgramTest)]
specs -> [(String, ProgramTest)] -> IO [(String, ProgramTest)]
forall (m :: * -> *) a. Monad m => a -> m a
return [(String, ProgramTest)]
specs

testPrograms :: FilePath -> IO [FilePath]
testPrograms :: String -> IO [String]
testPrograms String
dir = (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter String -> Bool
isFut ([String] -> [String]) -> IO [String] -> IO [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO [String]
directoryContents String
dir
  where
    isFut :: String -> Bool
isFut = (String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
".fut") (String -> Bool) -> ShowS -> String -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
takeExtension

-- | Try to parse a several values from a byte string.  The 'String'
-- parameter is used for error messages.
valuesFromByteString :: String -> BS.ByteString -> Either String [Value]
valuesFromByteString :: String -> ByteString -> Either String [Value]
valuesFromByteString String
srcname =
  Either String [Value]
-> ([Value] -> Either String [Value])
-> Maybe [Value]
-> Either String [Value]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> Either String [Value]
forall a b. a -> Either a b
Left (String -> Either String [Value])
-> String -> Either String [Value]
forall a b. (a -> b) -> a -> b
$ String
"Cannot parse values from '" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
srcname String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"'") [Value] -> Either String [Value]
forall a b. b -> Either a b
Right (Maybe [Value] -> Either String [Value])
-> (ByteString -> Maybe [Value])
-> ByteString
-> Either String [Value]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Maybe [Value]
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
/= :: FutharkExe -> FutharkExe -> Bool
$c/= :: FutharkExe -> FutharkExe -> Bool
== :: FutharkExe -> FutharkExe -> Bool
$c== :: 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
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
$cp1Ord :: Eq FutharkExe
Ord, Int -> FutharkExe -> ShowS
[FutharkExe] -> ShowS
FutharkExe -> String
(Int -> FutharkExe -> ShowS)
-> (FutharkExe -> String)
-> ([FutharkExe] -> ShowS)
-> Show FutharkExe
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [FutharkExe] -> ShowS
$cshowList :: [FutharkExe] -> ShowS
show :: FutharkExe -> String
$cshow :: FutharkExe -> String
showsPrec :: Int -> FutharkExe -> ShowS
$cshowsPrec :: Int -> FutharkExe -> ShowS
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 [Value]
getValues :: FutharkExe -> String -> Values -> m [Value]
getValues FutharkExe
_ String
_ (Values [Value]
vs) =
  [Value] -> m [Value]
forall (m :: * -> *) a. Monad m => a -> m a
return [Value]
vs
getValues FutharkExe
futhark String
dir Values
v = do
  ByteString
s <- FutharkExe -> String -> Values -> m ByteString
forall (m :: * -> *).
MonadIO m =>
FutharkExe -> String -> Values -> m ByteString
getValuesBS FutharkExe
futhark String
dir Values
v
  case String -> ByteString -> Either String [Value]
valuesFromByteString String
file ByteString
s of
    Left String
e -> String -> m [Value]
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
e
    Right [Value]
vs -> [Value] -> m [Value]
forall (m :: * -> *) a. Monad m => a -> m a
return [Value]
vs
  where
    file :: String
file = case Values
v of
      Values {} -> String
"<values>"
      InFile String
f -> String
f
      GenValues {} -> String
"<randomly generated>"

-- | Extract a pretty 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 :: MonadIO m => FutharkExe -> FilePath -> Values -> m BS.ByteString
getValuesBS :: FutharkExe -> String -> Values -> m ByteString
getValuesBS FutharkExe
_ String
_ (Values [Value]
vs) =
  ByteString -> m ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return (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
forall a. Pretty a => a -> Text
prettyText [Value]
vs
getValuesBS FutharkExe
_ String
dir (InFile String
file) =
  case ShowS
takeExtension String
file of
    String
".gz" -> IO ByteString -> m ByteString
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 <- IO ByteString -> IO (Either DecompressError ByteString)
forall e a. Exception e => IO a -> IO (Either e a)
E.try IO ByteString
readAndDecompress
      case Either DecompressError ByteString
s of
        Left DecompressError
e -> String -> IO ByteString
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> IO ByteString) -> String -> IO ByteString
forall a b. (a -> b) -> a -> b
$ ShowS
forall a. Show a => a -> String
show String
file String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
": " String -> ShowS
forall a. [a] -> [a] -> [a]
++ DecompressError -> String
forall a. Show a => a -> String
show (DecompressError
e :: DecompressError)
        Right ByteString
s' -> ByteString -> IO ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
s'
    String
_ -> IO ByteString -> m ByteString
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
$ String -> IO ByteString
BS.readFile String
file'
  where
    file' :: String
file' = String
dir String -> ShowS
</> String
file
    readAndDecompress :: IO ByteString
readAndDecompress = do
      ByteString
s <- String -> IO ByteString
BS.readFile String
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
getValuesBS FutharkExe
futhark String
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)
mapM (FutharkExe -> String -> GenValue -> m ByteString
forall (m :: * -> *).
MonadIO m =>
FutharkExe -> String -> GenValue -> m ByteString
getGenBS FutharkExe
futhark String
dir) [GenValue]
gens

-- | Evaluate an IO action while the values are available in the
-- binary format in a file by some name.  The file will be removed
-- after the action is done.
withValuesFile ::
  MonadIO m =>
  FutharkExe ->
  FilePath ->
  Values ->
  (FilePath -> IO a) ->
  m a
withValuesFile :: FutharkExe -> String -> Values -> (String -> IO a) -> m a
withValuesFile FutharkExe
_ String
dir (InFile String
file) String -> IO a
f
  | ShowS
takeExtension String
file String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= String
".gz" =
    IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> m a) -> IO a -> m a
forall a b. (a -> b) -> a -> b
$ String -> IO a
f (String -> IO a) -> String -> IO a
forall a b. (a -> b) -> a -> b
$ String
dir String -> ShowS
</> String
file
withValuesFile FutharkExe
futhark String
dir Values
vs String -> IO a
f =
  IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> m a)
-> ((String -> Handle -> IO a) -> IO a)
-> (String -> Handle -> IO a)
-> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> (String -> Handle -> IO a) -> IO a
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
String -> (String -> Handle -> m a) -> m a
withSystemTempFile String
"futhark-input" ((String -> Handle -> IO a) -> m a)
-> (String -> Handle -> IO a) -> m a
forall a b. (a -> b) -> a -> b
$ \String
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] -> IO ()) -> IO [Value] -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< FutharkExe -> String -> Values -> IO [Value]
forall (m :: * -> *).
(MonadFail m, MonadIO m) =>
FutharkExe -> String -> Values -> m [Value]
getValues FutharkExe
futhark String
dir Values
vs
    Handle -> IO ()
hClose Handle
tmpf_h
    String -> IO a
f String
tmpf

-- | Check that the file contains values of the expected types.
checkValueTypes ::
  (MonadError T.Text m, MonadIO m) => FilePath -> [TypeName] -> m ()
checkValueTypes :: String -> [Text] -> m ()
checkValueTypes String
values_f [Text]
input_types = do
  Maybe [Value]
maybe_vs <- IO (Maybe [Value]) -> m (Maybe [Value])
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe [Value]) -> m (Maybe [Value]))
-> IO (Maybe [Value]) -> m (Maybe [Value])
forall a b. (a -> b) -> a -> b
$ ByteString -> Maybe [Value]
readValues (ByteString -> Maybe [Value])
-> IO ByteString -> IO (Maybe [Value])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO ByteString
BS.readFile String
values_f
  case Maybe [Value]
maybe_vs of
    Maybe [Value]
Nothing ->
      Text -> m ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError Text
"Invalid input data format."
    Just [Value]
vs -> do
      let vs_types :: [Text]
vs_types = (Value -> Text) -> [Value] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (ValueType -> Text
prettyValueTypeNoDims (ValueType -> Text) -> (Value -> ValueType) -> Value -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> ValueType
valueType) [Value]
vs
      Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([Text]
vs_types [Text] -> [Text] -> Bool
forall a. Eq a => a -> a -> Bool
== [Text]
input_types) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
        Text -> m ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$
          [Text] -> Text
T.unlines
            [ Text
"Expected input types: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
T.unwords [Text]
input_types,
              Text
"Provided input types: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
T.unwords [Text]
vs_types
            ]

-- | There is a risk of race conditions when multiple programs have
-- identical 'GenValues'.  In such cases, multiple threads in 'futhark
-- test' might attempt to create the same file (or read from it, while
-- something else is constructing it).  This leads to a mess.  To
-- avoid this, we create a temporary file, and only when it is
-- complete do we move it into place.  It would be better if we could
-- use file locking, but that does not work on some file systems.  The
-- approach here seems robust enough for now, but certainly it could
-- be made even better.  The race condition that remains should mostly
-- result in duplicate work, not crashes or data corruption.
getGenBS :: MonadIO m => FutharkExe -> FilePath -> GenValue -> m BS.ByteString
getGenBS :: FutharkExe -> String -> GenValue -> m ByteString
getGenBS FutharkExe
futhark String
dir GenValue
gen = do
  IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Bool -> String -> IO ()
createDirectoryIfMissing Bool
True (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
dir String -> ShowS
</> String
"data"
  Bool
exists_and_proper_size <-
    IO Bool -> m Bool
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
$
      String -> IOMode -> (Handle -> IO Bool) -> IO Bool
forall r. String -> IOMode -> (Handle -> IO r) -> IO r
withFile (String
dir String -> ShowS
</> String
file) IOMode
ReadMode ((Integer -> Bool) -> IO Integer -> IO Bool
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 (m :: * -> *) a. Monad m => a -> m a
return 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 (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]
      String -> String -> (String -> Handle -> IO ()) -> IO ()
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
String -> String -> (String -> Handle -> m a) -> m a
withTempFile (String
dir String -> ShowS
</> String
"data") (GenValue -> String
genFileName GenValue
gen) ((String -> Handle -> IO ()) -> IO ())
-> (String -> Handle -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \String
tmpfile Handle
h -> do
        Handle -> IO ()
hClose Handle
h -- We will be writing and reading this ourselves.
        String -> ByteString -> IO ()
SBS.writeFile String
tmpfile ByteString
s
        String -> String -> IO ()
renameFile String
tmpfile (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
dir String -> ShowS
</> String
file
  FutharkExe -> String -> Values -> m ByteString
forall (m :: * -> *).
MonadIO m =>
FutharkExe -> String -> Values -> m ByteString
getValuesBS FutharkExe
futhark String
dir (Values -> m ByteString) -> Values -> m ByteString
forall a b. (a -> b) -> a -> b
$ String -> Values
InFile String
file
  where
    file :: String
file = String
"data" String -> ShowS
</> GenValue -> String
genFileName GenValue
gen

genValues :: FutharkExe -> [GenValue] -> IO SBS.ByteString
genValues :: FutharkExe -> [GenValue] -> IO ByteString
genValues (FutharkExe String
futhark) [GenValue]
gens = do
  (ExitCode
code, ByteString
stdout, ByteString
stderr) <- String
-> [String] -> ByteString -> IO (ExitCode, ByteString, ByteString)
readProcessWithExitCode String
futhark (String
"dataset" String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
args) ByteString
forall a. Monoid a => a
mempty
  case ExitCode
code of
    ExitCode
ExitSuccess ->
      ByteString -> IO ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
stdout
    ExitFailure Int
e ->
      String -> IO ByteString
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> IO ByteString) -> String -> IO ByteString
forall a b. (a -> b) -> a -> b
$
        String
"'futhark dataset' failed with exit code " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
e String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" and stderr:\n"
          String -> ShowS
forall a. [a] -> [a] -> [a]
++ (Word8 -> Char) -> [Word8] -> String
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 :: [String]
args = String
"-b" String -> [String] -> [String]
forall a. a -> [a] -> [a]
: (GenValue -> [String]) -> [GenValue] -> [String]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap GenValue -> [String]
argForGen [GenValue]
gens
    argForGen :: GenValue -> [String]
argForGen GenValue
g = [String
"-g", GenValue -> String
genValueType GenValue
g]

genFileName :: GenValue -> FilePath
genFileName :: GenValue -> String
genFileName GenValue
gen = GenValue -> String
genValueType GenValue
gen String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
".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 :: Integer
header_size = Integer
1 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
1 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
1 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
4 -- 'b' <version> <num_dims> <type>
    genSize :: GenValue -> Integer
genSize (GenValue (ValueType [Int]
ds PrimType
t)) =
      Integer
header_size Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Int -> Integer
forall a. Integral a => a -> Integer
toInteger ([Int] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Int]
ds) Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
8
        Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ [Integer] -> Integer
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
product ((Int -> Integer) -> [Int] -> [Integer]
forall a b. (a -> b) -> [a] -> [b]
map Int -> Integer
forall a. Integral a => a -> Integer
toInteger [Int]
ds) Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* PrimType -> Integer
forall p. Num p => PrimType -> p
primSize PrimType
t
    genSize (GenPrim PrimValue
v) =
      Integer
header_size Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ PrimType -> Integer
forall p. Num p => PrimType -> p
primByteSize (PrimValue -> PrimType
primValueType PrimValue
v)

    primSize :: PrimType -> p
primSize (Signed IntType
it) = IntType -> p
forall a. Num a => IntType -> a
intByteSize IntType
it
    primSize (Unsigned IntType
it) = IntType -> p
forall a. Num a => IntType -> a
intByteSize IntType
it
    primSize (FloatType FloatType
ft) = FloatType -> p
forall a. Num a => FloatType -> a
floatByteSize FloatType
ft
    primSize PrimType
Bool = p
1

-- | 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 :: String -> Text -> TestRun -> String
testRunReferenceOutput String
prog Text
entry TestRun
tr =
  String
"data"
    String -> ShowS
</> ShowS
takeBaseName String
prog
    String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
":"
    String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack Text
entry
    String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"-"
    String -> ShowS
forall a. Semigroup a => a -> a -> a
<> (Char -> Char) -> ShowS
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
clean (TestRun -> String
runDescription TestRun
tr)
    String -> ShowS
<.> String
"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 [Value])
getExpectedResult :: FutharkExe
-> String -> Text -> TestRun -> m (ExpectedResult [Value])
getExpectedResult FutharkExe
futhark String
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 -> String -> Values -> m [Value]
forall (m :: * -> *).
(MonadFail m, MonadIO m) =>
FutharkExe -> String -> Values -> m [Value]
getValues FutharkExe
futhark (ShowS
takeDirectory String
prog) Values
vals
    Succeeds (Just Success
SuccessGenerateValues) ->
      FutharkExe
-> String -> Text -> TestRun -> m (ExpectedResult [Value])
forall (m :: * -> *).
(MonadFail m, MonadIO m) =>
FutharkExe
-> String -> Text -> TestRun -> m (ExpectedResult [Value])
getExpectedResult
        FutharkExe
futhark
        String
prog
        Text
entry
        TestRun
tr
          { runExpectedResult :: ExpectedResult Success
runExpectedResult =
              Maybe Success -> ExpectedResult Success
forall values. Maybe values -> ExpectedResult values
Succeeds (Maybe Success -> ExpectedResult Success)
-> Maybe Success -> ExpectedResult Success
forall a b. (a -> b) -> a -> b
$
                Success -> Maybe Success
forall a. a -> Maybe a
Just (Success -> Maybe Success) -> Success -> Maybe Success
forall a b. (a -> b) -> a -> b
$
                  Values -> Success
SuccessValues (Values -> Success) -> Values -> Success
forall a b. (a -> b) -> a -> b
$
                    String -> Values
InFile (String -> Values) -> String -> Values
forall a b. (a -> b) -> a -> b
$
                      String -> Text -> TestRun -> String
testRunReferenceOutput String
prog Text
entry TestRun
tr
          }
    Succeeds Maybe Success
Nothing ->
      ExpectedResult [Value] -> m (ExpectedResult [Value])
forall (m :: * -> *) a. Monad m => a -> m a
return (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 (m :: * -> *) a. Monad m => a -> m a
return (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 :: ShowS
binaryName = ShowS
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 :: [String]
-> FutharkExe -> String -> String -> m (ByteString, ByteString)
compileProgram [String]
extra_options (FutharkExe String
futhark) String
backend String
program = do
  (ExitCode
futcode, ByteString
stdout, ByteString
stderr) <- IO (ExitCode, ByteString, ByteString)
-> m (ExitCode, ByteString, ByteString)
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
$ String
-> [String] -> ByteString -> IO (ExitCode, ByteString, ByteString)
readProcessWithExitCode String
futhark (String
backend String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
options) ByteString
""
  case ExitCode
futcode of
    ExitFailure Int
127 -> [Text] -> m ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError [Text -> Text
forall a. (Semigroup a, IsString a) => a -> a
progNotFound (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack String
futhark]
    ExitFailure Int
_ -> [Text] -> m ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError [ByteString -> Text
T.decodeUtf8 ByteString
stderr]
    ExitCode
ExitSuccess -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  (ByteString, ByteString) -> m (ByteString, ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString
stdout, ByteString
stderr)
  where
    binOutputf :: String
binOutputf = ShowS
binaryName String
program
    options :: [String]
options = [String
program, String
"-o", String
binOutputf] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
extra_options
    progNotFound :: a -> a
progNotFound a
s = a
s a -> a -> a
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
-> String
-> [String]
-> String
-> Text
-> Values
-> IO (ExitCode, ByteString, ByteString)
runProgram FutharkExe
futhark String
runner [String]
extra_options String
prog Text
entry Values
input = do
  let progbin :: String
progbin = ShowS
binaryName String
prog
      dir :: String
dir = ShowS
takeDirectory String
prog
      binpath :: String
binpath = String
"." String -> ShowS
</> String
progbin
      entry_options :: [String]
entry_options = [String
"-e", Text -> String
T.unpack Text
entry]

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

  ByteString
input' <- FutharkExe -> String -> Values -> IO ByteString
forall (m :: * -> *).
MonadIO m =>
FutharkExe -> String -> Values -> m ByteString
getValuesBS FutharkExe
futhark String
dir Values
input
  IO (ExitCode, ByteString, ByteString)
-> IO (ExitCode, ByteString, ByteString)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (ExitCode, ByteString, ByteString)
 -> IO (ExitCode, ByteString, ByteString))
-> IO (ExitCode, ByteString, ByteString)
-> IO (ExitCode, ByteString, ByteString)
forall a b. (a -> b) -> a -> b
$ String
-> [String] -> ByteString -> IO (ExitCode, ByteString, ByteString)
readProcessWithExitCode String
to_run [String]
to_run_args (ByteString -> IO (ExitCode, ByteString, ByteString))
-> ByteString -> IO (ExitCode, ByteString, ByteString)
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] ->
  FilePath ->
  m [Value]
readResults :: Server -> [Text] -> String -> m [Value]
readResults Server
server [Text]
outs String
program =
  m (m [Value]) -> m [Value]
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (m (m [Value]) -> m [Value])
-> ((String -> Handle -> IO (m [Value])) -> m (m [Value]))
-> (String -> Handle -> IO (m [Value]))
-> m [Value]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO (m [Value]) -> m (m [Value])
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (m [Value]) -> m (m [Value]))
-> ((String -> Handle -> IO (m [Value])) -> IO (m [Value]))
-> (String -> Handle -> IO (m [Value]))
-> m (m [Value])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> (String -> Handle -> IO (m [Value])) -> IO (m [Value])
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
String -> (String -> Handle -> m a) -> m a
withSystemTempFile String
"futhark-output" ((String -> Handle -> IO (m [Value])) -> m [Value])
-> (String -> Handle -> IO (m [Value])) -> m [Value]
forall a b. (a -> b) -> a -> b
$ \String
outputf Handle
outputh -> do
    Handle -> IO ()
hClose Handle
outputh
    Maybe CmdFailure
store_r <- Server -> String -> [Text] -> IO (Maybe CmdFailure)
cmdStore Server
server String
outputf [Text]
outs
    case Maybe CmdFailure
store_r of
      Just (CmdFailure [Text]
_ [Text]
err) ->
        m [Value] -> IO (m [Value])
forall (f :: * -> *) a. Applicative f => a -> f a
pure (m [Value] -> IO (m [Value])) -> m [Value] -> IO (m [Value])
forall a b. (a -> b) -> a -> b
$ Text -> m [Value]
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Text -> m [Value]) -> Text -> m [Value]
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.unlines [Text]
err
      Maybe CmdFailure
Nothing -> do
        ByteString
bytes <- String -> IO ByteString
BS.readFile String
outputf
        case String -> ByteString -> Either String [Value]
valuesFromByteString String
"output" ByteString
bytes of
          Left String
e -> do
            let actualf :: String
actualf = String
program String -> ShowS
`addExtension` String
"actual"
            IO () -> IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> ByteString -> IO ()
BS.writeFile String
actualf ByteString
bytes
            m [Value] -> IO (m [Value])
forall (f :: * -> *) a. Applicative f => a -> f a
pure (m [Value] -> IO (m [Value])) -> m [Value] -> IO (m [Value])
forall a b. (a -> b) -> a -> b
$ Text -> m [Value]
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Text -> m [Value]) -> Text -> m [Value]
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack String
e Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\n(See " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack String
actualf Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")"
          Right [Value]
vs -> m [Value] -> IO (m [Value])
forall (f :: * -> *) a. Applicative f => a -> f a
pure (m [Value] -> IO (m [Value])) -> m [Value] -> IO (m [Value])
forall a b. (a -> b) -> a -> b
$ [Value] -> m [Value]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Value]
vs

-- | 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 :: Maybe Int
-> FutharkExe -> String -> String -> [InputOutputs] -> m ()
ensureReferenceOutput Maybe Int
concurrency FutharkExe
futhark String
compiler String
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 (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
$ [String]
-> FutharkExe -> String -> String -> m (ByteString, ByteString)
forall (m :: * -> *).
(MonadIO m, MonadError [Text] m) =>
[String]
-> FutharkExe -> String -> String -> m (ByteString, ByteString)
compileProgram [] FutharkExe
futhark String
compiler String
prog

    [Either [Text] ()]
res <- IO [Either [Text] ()] -> m [Either [Text] ()]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [Either [Text] ()] -> m [Either [Text] ()])
-> IO [Either [Text] ()] -> m [Either [Text] ()]
forall a b. (a -> b) -> a -> b
$
      (((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] ()))
 -> IO [Either [Text] ()])
-> ((Text, TestRun) -> IO (Either [Text] ()))
-> IO [Either [Text] ()]
forall a b. (a -> b) -> a -> b
$ \(Text
entry, TestRun
tr) -> do
        (ExitCode
code, ByteString
stdout, ByteString
stderr) <- FutharkExe
-> String
-> [String]
-> String
-> Text
-> Values
-> IO (ExitCode, ByteString, ByteString)
runProgram FutharkExe
futhark String
"" [String
"-b"] String
prog Text
entry (Values -> IO (ExitCode, ByteString, ByteString))
-> Values -> IO (ExitCode, ByteString, ByteString)
forall a b. (a -> b) -> a -> b
$ TestRun -> Values
runInput TestRun
tr
        case ExitCode
code of
          ExitFailure Int
e ->
            Either [Text] () -> IO (Either [Text] ())
forall (m :: * -> *) a. Monad m => a -> m a
return (Either [Text] () -> IO (Either [Text] ()))
-> Either [Text] () -> IO (Either [Text] ())
forall a b. (a -> b) -> a -> b
$
              [Text] -> Either [Text] ()
forall a b. a -> Either a b
Left
                [ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$
                    String
"Reference dataset generation failed with exit code "
                      String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
e
                      String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" and stderr:\n"
                      String -> ShowS
forall a. [a] -> [a] -> [a]
++ (Word8 -> Char) -> [Word8] -> String
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)
                ]
          ExitCode
ExitSuccess -> do
            let f :: String
f = (Text, TestRun) -> String
file (Text
entry, TestRun
tr)
            IO () -> IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Bool -> String -> IO ()
createDirectoryIfMissing Bool
True (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ ShowS
takeDirectory String
f
            String -> ByteString -> IO ()
SBS.writeFile String
f ByteString
stdout
            Either [Text] () -> IO (Either [Text] ())
forall (m :: * -> *) a. Monad m => a -> m a
return (Either [Text] () -> IO (Either [Text] ()))
-> Either [Text] () -> IO (Either [Text] ())
forall a b. (a -> b) -> a -> b
$ () -> Either [Text] ()
forall a b. b -> Either a b
Right ()

    case [Either [Text] ()] -> Either [Text] ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ [Either [Text] ()]
res of
      Left [Text]
err -> [Text] -> m ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError [Text]
err
      Right () -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  where
    file :: (Text, TestRun) -> String
file (Text
entry, TestRun
tr) =
      ShowS
takeDirectory String
prog String -> ShowS
</> String -> Text -> TestRun -> String
testRunReferenceOutput String
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 (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> m Bool)
-> ((Text, TestRun) -> IO Bool) -> (Text, TestRun) -> m Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Bool -> Bool) -> IO Bool -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Bool -> Bool
not (IO Bool -> IO Bool)
-> ((Text, TestRun) -> IO Bool) -> (Text, TestRun) -> IO Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO Bool
doesFileExist (String -> IO Bool)
-> ((Text, TestRun) -> String) -> (Text, TestRun) -> IO Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text, TestRun) -> String
file ((Text, TestRun) -> m Bool) -> (Text, TestRun) -> m Bool
forall a b. (a -> b) -> a -> b
$ (Text
entry, TestRun
tr)
      | Bool
otherwise =
        Bool -> m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return 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 :: Maybe String -> String -> m ([String], String)
determineTuning Maybe String
Nothing String
_ = ([String], String) -> m ([String], String)
forall (m :: * -> *) a. Monad m => a -> m a
return ([], String
forall a. Monoid a => a
mempty)
determineTuning (Just String
ext) String
program = do
  Bool
exists <- IO Bool -> m Bool
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
$ String -> IO Bool
doesFileExist (String
program String -> ShowS
<.> String
ext)
  if Bool
exists
    then
      ([String], String) -> m ([String], String)
forall (m :: * -> *) a. Monad m => a -> m a
return
        ( [String
"--tuning", String
program String -> ShowS
<.> String
ext],
          String
" (using " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> ShowS
takeFileName (String
program String -> ShowS
<.> String
ext) String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
")"
        )
    else ([String], String) -> m ([String], String)
forall (m :: * -> *) a. Monad m => a -> m a
return ([], String
forall a. Monoid a => a
mempty)

-- | Check that the result is as expected, and write files and throw
-- an error if not.
checkResult ::
  (MonadError T.Text m, MonadIO m) =>
  FilePath ->
  [Value] ->
  [Value] ->
  m ()
checkResult :: String -> [Value] -> [Value] -> m ()
checkResult String
program [Value]
expected_vs [Value]
actual_vs =
  case [Value] -> [Value] -> [Mismatch]
compareValues [Value]
actual_vs [Value]
expected_vs of
    Mismatch
mismatch : [Mismatch]
mismatches -> do
      let actualf :: String
actualf = String
program String -> ShowS
<.> String
"actual"
          expectedf :: String
expectedf = String
program String -> ShowS
<.> String
"expected"
      IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ String -> ByteString -> IO ()
BS.writeFile String
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 (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ String -> ByteString -> IO ()
BS.writeFile String
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 e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$
        String -> Text
T.pack String
actualf Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" and " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack String
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
<> String -> Text
T.pack (Mismatch -> String
forall a. Show a => a -> String
show Mismatch
mismatch)
          Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> if [Mismatch] -> 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 (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 (m :: * -> *) a. Monad m => a -> m a
return ()