-- | Definition and parsing of a test specification.
module Futhark.Test.Spec
  ( testSpecFromProgram,
    testSpecFromProgramOrDie,
    testSpecsFromPaths,
    testSpecsFromPathsOrDie,
    testSpecFromFile,
    testSpecFromFileOrDie,
    ProgramTest (..),
    StructureTest (..),
    StructurePipeline (..),
    WarningTest (..),
    TestAction (..),
    ExpectedError (..),
    InputOutputs (..),
    TestRun (..),
    ExpectedResult (..),
    Success (..),
    Values (..),
    GenValue (..),
    genValueType,
  )
where

import Control.Applicative
import Control.Exception (catch)
import Control.Monad
import Data.Char
import Data.Functor
import Data.List (foldl', (\\))
import Data.Map.Strict qualified as M
import Data.Maybe
import Data.Text qualified as T
import Data.Text.IO qualified as T
import Data.Void
import Futhark.Analysis.Metrics.Type
import Futhark.Data.Parser
import Futhark.Data.Parser qualified as V
import Futhark.Script qualified as Script
import Futhark.Test.Values qualified as V
import Futhark.Util (directoryContents, nubOrd, showText)
import Futhark.Util.Pretty (prettyTextOneLine)
import System.Exit
import System.FilePath
import System.IO
import System.IO.Error
import Text.Megaparsec hiding (many, some)
import Text.Megaparsec.Char
import Text.Megaparsec.Char.Lexer (charLiteral)
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
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
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
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 " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Text
r

-- | How a program can be transformed.
data StructurePipeline
  = GpuPipeline
  | MCPipeline
  | SOACSPipeline
  | SeqMemPipeline
  | GpuMemPipeline
  | MCMemPipeline
  | NoPipeline
  deriving (Int -> StructurePipeline -> ShowS
[StructurePipeline] -> ShowS
StructurePipeline -> String
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
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 " 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 -> Text
runDescription :: T.Text
  }
  deriving (Int -> TestRun -> ShowS
[TestRun] -> ShowS
TestRun -> String
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.  All paths are relative to test program.
data Values
  = Values [V.Value]
  | InFile FilePath
  | GenValues [GenValue]
  | ScriptValues Script.Exp
  | ScriptFile FilePath
  deriving (Int -> Values -> ShowS
[Values] -> ShowS
Values -> String
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)

-- | How to generate a single random value.
data GenValue
  = -- | Generate a value of the given rank and primitive
    -- type.  Scalars are considered 0-ary arrays.
    GenValue V.ValueType
  | -- | A fixed non-randomised primitive value.
    GenPrim V.Value
  deriving (Int -> GenValue -> ShowS
[GenValue] -> ShowS
GenValue -> String
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 -> T.Text
genValueType :: GenValue -> Text
genValueType (GenValue (V.ValueType [Int]
ds PrimType
t)) =
  forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (\Int
d -> Text
"[" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showText Int
d forall a. Semigroup a => a -> a -> a
<> Text
"]") [Int]
ds forall a. Semigroup a => a -> a -> a
<> PrimType -> Text
V.primTypeText PrimType
t
genValueType (GenPrim Value
v) =
  Value -> Text
V.valueText Value
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
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
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

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

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

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

inBraces :: Parser () -> Parser a -> Parser a
inBraces :: forall a. Parser () -> Parser a -> Parser a
inBraces Parser ()
sep = forall (m :: * -> *) open close a.
Applicative m =>
m open -> m close -> m a -> m a
between (forall a. Parser () -> Parser a -> Parser a
lexeme Parser ()
sep Parser Text
"{") (forall a. Parser () -> Parser a -> Parser a
lexeme Parser ()
sep Parser Text
"}")

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

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

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

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

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

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

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

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

parseEntryPoints :: Parser () -> Parser [T.Text]
parseEntryPoints :: Parser () -> ParsecT Void Text Identity [Text]
parseEntryPoints Parser ()
sep =
  (forall a. Parser a -> Parser a
lexeme' Parser Text
"entry:" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (f :: * -> *) a. Alternative f => f a -> f [a]
many Parser Text
entry forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
sep) forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> 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 forall a. Eq a => a -> a -> Bool
/= Char
'}'
    entry :: Parser Text
entry = forall a. Parser a -> Parser a
lexeme' forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) a. Alternative f => f a -> f [a]
some (forall e s (m :: * -> *).
MonadParsec e s m =>
(Token s -> Bool) -> m (Token s)
satisfy Char -> Bool
constituent)

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

parseStringLiteral :: Parser () -> Parser T.Text
parseStringLiteral :: Parser () -> Parser Text
parseStringLiteral Parser ()
sep =
  forall a. Parser () -> Parser a -> Parser a
lexeme Parser ()
sep forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> Text
T.pack forall a b. (a -> b) -> a -> b
$ forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
'"' forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a end. MonadPlus m => m a -> m end -> m [a]
manyTill forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m Char
charLiteral (forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
'"')

parseRunCases :: Parser () -> Parser [TestRun]
parseRunCases :: Parser () -> Parser [TestRun]
parseRunCases Parser ()
sep = Int -> Parser [TestRun]
parseRunCases' (Int
0 :: Int)
  where
    parseRunCases' :: Int -> Parser [TestRun]
parseRunCases' Int
i =
      (:) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> ParsecT Void Text Identity TestRun
parseRunCase Int
i forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Int -> Parser [TestRun]
parseRunCases' (Int
i forall {a}. Num a => a -> a -> a
+ Int
1)
        forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (f :: * -> *) a. Applicative f => a -> f a
pure []
    parseRunCase :: Int -> ParsecT Void Text Identity TestRun
parseRunCase Int
i = do
      Maybe Text
name <- forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional forall a b. (a -> b) -> a -> b
$ Parser () -> Parser Text
parseStringLiteral Parser ()
sep
      [String]
tags <- Parser [String]
parseRunTags
      forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall a. Parser () -> Parser a -> Parser a
lexeme Parser ()
sep Parser Text
"input"
      Values
input <-
        if String
"random" forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
tags
          then Parser () -> Parser Values
parseRandomValues Parser ()
sep
          else
            if String
"script" forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
tags
              then Parser () -> Parser Values
parseScriptValues Parser ()
sep
              else Parser () -> Parser Values
parseValues Parser ()
sep
      ExpectedResult Success
expr <- Parser () -> Parser (ExpectedResult Success)
parseExpectedResult Parser ()
sep
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ [String]
-> Values -> ExpectedResult Success -> Int -> Text -> TestRun
TestRun [String]
tags Values
input ExpectedResult Success
expr Int
i forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a -> a
fromMaybe (forall {a}. Show a => a -> Values -> Text
desc Int
i Values
input) Maybe Text
name

    -- 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 -> Text
desc a
_ (InFile String
path)
      | ShowS
takeExtension String
path forall a. Eq a => a -> a -> Bool
== String
".gz" = String -> Text
T.pack forall a b. (a -> b) -> a -> b
$ ShowS
dropExtension String
path
      | Bool
otherwise = String -> Text
T.pack String
path
    desc a
i (Values [Value]
vs) =
      -- Turn linebreaks into space.
      Text
"#" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showText a
i forall a. Semigroup a => a -> a -> a
<> Text
" (\"" forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
T.unwords (Text -> [Text]
T.lines Text
vs') forall a. Semigroup a => a -> a -> a
<> Text
"\")"
      where
        vs' :: Text
vs' = case [Text] -> Text
T.unwords forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map Value -> Text
V.valueText [Value]
vs of
          Text
s
            | Text -> Int
T.length Text
s forall a. Ord a => a -> a -> Bool
> Int
50 -> Int -> Text -> Text
T.take Int
50 Text
s forall a. Semigroup a => a -> a -> a
<> Text
"..."
            | Bool
otherwise -> Text
s
    desc a
_ (GenValues [GenValue]
gens) =
      [Text] -> Text
T.unwords forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map GenValue -> Text
genValueType [GenValue]
gens
    desc a
_ (ScriptValues Exp
e) =
      forall a. Pretty a => a -> Text
prettyTextOneLine Exp
e
    desc a
_ (ScriptFile String
path) =
      String -> Text
T.pack String
path

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

parseExpectedError :: Parser () -> Parser ExpectedError
parseExpectedError :: Parser () -> ParsecT Void Text Identity ExpectedError
parseExpectedError Parser ()
sep = forall a. Parser () -> Parser a -> Parser a
lexeme Parser ()
sep forall a b. (a -> b) -> a -> b
$ do
  Text
s <- Text -> Text
T.strip forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text
restOfLine_ forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
sep
  if Text -> Bool
T.null Text
s
    then forall (f :: * -> *) a. Applicative f => a -> f a
pure 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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall regex compOpt execOpt source (m :: * -> *).
(RegexMaker regex compOpt execOpt source, MonadFail m) =>
compOpt -> execOpt -> source -> m regex
makeRegexOptsM forall regex compOpt execOpt.
RegexOptions regex compOpt execOpt =>
compOpt
blankCompOpt forall regex compOpt execOpt.
RegexOptions regex compOpt execOpt =>
execOpt
defaultExecOpt (Text -> String
T.unpack Text
s)

parseScriptValues :: Parser () -> Parser Values
parseScriptValues :: Parser () -> Parser Values
parseScriptValues Parser ()
sep =
  forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice
    [ Exp -> Values
ScriptValues forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Parser () -> Parser a -> Parser a
inBraces Parser ()
sep (Parser () -> Parsec Void Text Exp
Script.parseExp Parser ()
sep),
      String -> Values
ScriptFile forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall a. Parser () -> Parser a -> Parser a
lexeme Parser ()
sep Parser Text
"@" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall a. Parser () -> Parser a -> Parser a
lexeme Parser ()
sep ParsecT Void Text Identity (Tokens Text)
nextWord)
    ]
  where
    nextWord :: ParsecT Void Text Identity (Tokens Text)
nextWord = forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe String -> (Token s -> Bool) -> m (Tokens s)
takeWhileP forall a. Maybe a
Nothing forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Bool
isSpace

parseRandomValues :: Parser () -> Parser Values
parseRandomValues :: Parser () -> Parser Values
parseRandomValues Parser ()
sep = [GenValue] -> Values
GenValues forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Parser () -> Parser a -> Parser a
inBraces Parser ()
sep (forall (f :: * -> *) a. Alternative f => f a -> f [a]
many (Parser () -> Parser GenValue
parseGenValue Parser ()
sep))

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

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

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

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

optimisePipeline :: Parser () -> Parser StructurePipeline
optimisePipeline :: Parser () -> Parser StructurePipeline
optimisePipeline Parser ()
sep =
  forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice
    [ forall a. Parser () -> Parser a -> Parser a
lexeme Parser ()
sep Parser Text
"gpu-mem" forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> StructurePipeline
GpuMemPipeline,
      forall a. Parser () -> Parser a -> Parser a
lexeme Parser ()
sep Parser Text
"gpu" forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> StructurePipeline
GpuPipeline,
      forall a. Parser () -> Parser a -> Parser a
lexeme Parser ()
sep Parser Text
"mc-mem" forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> StructurePipeline
MCMemPipeline,
      forall a. Parser () -> Parser a -> Parser a
lexeme Parser ()
sep Parser Text
"mc" forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> StructurePipeline
MCPipeline,
      forall a. Parser () -> Parser a -> Parser a
lexeme Parser ()
sep Parser Text
"seq-mem" forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> StructurePipeline
SeqMemPipeline,
      forall a. Parser () -> Parser a -> Parser a
lexeme Parser ()
sep Parser Text
"internalised" forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> StructurePipeline
NoPipeline,
      forall (f :: * -> *) a. Applicative f => a -> f a
pure StructurePipeline
SOACSPipeline
    ]

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

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

couldNotRead :: IOError -> IO (Either String a)
couldNotRead :: forall a. IOError -> IO (Either String a)
couldNotRead = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> Either a b
Left forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show

pProgramTest :: Parser ProgramTest
pProgramTest :: Parser ProgramTest
pProgramTest = do
  forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Alternative f => f a -> f [a]
many Parser ()
pNonTestLine
  Maybe ProgramTest
maybe_spec <-
    forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (Parser Text
"--" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser ()
sep forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser () -> Parser ProgramTest
testSpec Parser ()
sep) forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
pEndOfTestBlock forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* 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 <- forall (f :: * -> *) a. Alternative f => f a -> f [a]
many forall a b. (a -> b) -> a -> b
$ Parser [InputOutputs]
pInputOutputs forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall (f :: * -> *) a. Alternative f => f a -> f [a]
many Parser ()
pNonTestLine
          forall (f :: * -> *) a. Applicative f => a -> f a
pure ProgramTest
spec {testAction :: TestAction
testAction = [InputOutputs] -> [StructureTest] -> [WarningTest] -> TestAction
RunCases ([InputOutputs]
old_cases forall a. [a] -> [a] -> [a]
++ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[InputOutputs]]
cases) [StructureTest]
structures [WarningTest]
warnings}
      | Bool
otherwise ->
          forall (f :: * -> *) a. Alternative f => f a -> f [a]
many Parser ()
pNonTestLine
            forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m ()
notFollowedBy Parser Text
"-- =="
            forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (f :: * -> *) a. Applicative f => a -> f a
pure ProgramTest
spec
            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 ->
      forall e s (m :: * -> *). MonadParsec e s m => m ()
eof forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> ProgramTest
noTest
  where
    sep :: Parser ()
sep = forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
hspace forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try forall a b. (a -> b) -> a -> b
$ forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Tokens s)
eol forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Text
"--" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser ()
sep)

    noTest :: ProgramTest
noTest =
      Text -> [Text] -> TestAction -> ProgramTest
ProgramTest forall a. Monoid a => a
mempty forall a. Monoid a => a
mempty ([InputOutputs] -> [StructureTest] -> [WarningTest] -> TestAction
RunCases forall a. Monoid a => a
mempty forall a. Monoid a => a
mempty forall a. Monoid a => a
mempty)

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

validate :: FilePath -> ProgramTest -> Either String ProgramTest
validate :: String -> ProgramTest -> Either String ProgramTest
validate String
path ProgramTest
pt = do
  case ProgramTest -> TestAction
testAction ProgramTest
pt of
    CompileTimeFailure {} -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ProgramTest
pt
    RunCases [InputOutputs]
ios [StructureTest]
_ [WarningTest]
_ -> do
      forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ([Text] -> Either String ()
noDups forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map TestRun -> Text
runDescription forall b c a. (b -> c) -> (a -> b) -> a -> c
. InputOutputs -> [TestRun]
iosTestRuns) [InputOutputs]
ios
      forall a b. b -> Either a b
Right ProgramTest
pt
  where
    noDups :: [Text] -> Either String ()
noDups [Text]
xs =
      let xs' :: [Text]
xs' = forall a. Ord a => [a] -> [a]
nubOrd [Text]
xs
       in -- Works because \\ only removes first instance.
          case [Text]
xs forall a. Eq a => [a] -> [a] -> [a]
\\ [Text]
xs' of
            [] -> forall a b. b -> Either a b
Right ()
            Text
x : [Text]
_ -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ String
path forall a. Semigroup a => a -> a -> a
<> String
": multiple datasets with name " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show (Text -> String
T.unpack Text
x)

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

-- | Like 'testSpecFromProgram', but exits the process on error.
testSpecFromProgramOrDie :: FilePath -> IO ProgramTest
testSpecFromProgramOrDie :: String -> IO ProgramTest
testSpecFromProgramOrDie String
prog = do
  Either String ProgramTest
spec_or_err <- String -> IO (Either String ProgramTest)
testSpecFromProgram String
prog
  case Either String ProgramTest
spec_or_err of
    Left String
err -> do
      Handle -> String -> IO ()
hPutStrLn Handle
stderr String
err
      forall a. IO a
exitFailure
    Right ProgramTest
spec -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ProgramTest
spec

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

-- | 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 <- (forall a b. b -> Either a b
Right forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO [String]
testPrograms String
path) forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` forall a. IOError -> IO (Either String a)
couldNotRead
  case Either String [String]
programs_or_err of
    Left String
err -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left String
err
    Right [String]
programs -> do
      [Either String ProgramTest]
specs_or_errs <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM String -> IO (Either String ProgramTest)
testSpecFromProgram [String]
programs
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. [a] -> [b] -> [(a, b)]
zip [String]
programs forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence) forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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
      Handle -> String -> IO ()
hPutStrLn Handle
stderr String
err
      forall a. IO a
exitFailure
    Right [(String, ProgramTest)]
specs -> forall (f :: * -> *) a. Applicative f => a -> f a
pure [(String, ProgramTest)]
specs

-- | Read a test specification from a file.  Expects only a single
-- block, and no comment prefixes.
testSpecFromFile :: FilePath -> IO (Either String ProgramTest)
testSpecFromFile :: String -> IO (Either String ProgramTest)
testSpecFromFile String
path =
  ( forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> Either a b
Left forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s e.
(VisualStream s, TraversableStream s, ShowErrorComponent e) =>
ParseErrorBundle s e -> String
errorBundlePretty) forall a b. b -> Either a b
Right forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e s a.
Parsec e s a -> String -> s -> Either (ParseErrorBundle s e) a
parse (Parser () -> Parser ProgramTest
testSpec forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
space) String
path
      forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO Text
T.readFile String
path
  )
    forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` forall a. IOError -> IO (Either String a)
couldNotRead

-- | Like 'testSpecFromFile', but kills the process on errors.
testSpecFromFileOrDie :: FilePath -> IO ProgramTest
testSpecFromFileOrDie :: String -> IO ProgramTest
testSpecFromFileOrDie String
dirs = do
  Either String ProgramTest
spec_or_err <- String -> IO (Either String ProgramTest)
testSpecFromFile String
dirs
  case Either String ProgramTest
spec_or_err of
    Left String
err -> do
      Handle -> String -> IO ()
hPutStrLn Handle
stderr String
err
      forall a. IO a
exitFailure
    Right ProgramTest
spec -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ProgramTest
spec