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

import Control.Applicative
import Control.Exception (catch)
import Control.Monad
import Data.Char
import Data.Either (partitionEithers)
import Data.Functor
import Data.List qualified as L
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.Test.Values qualified as V
import Futhark.Util (directoryContents, nubOrd, showText)
import Futhark.Util.Loc qualified as Loc
import Futhark.Util.Pretty (prettyTextOneLine)
import Language.Futhark.Parser (SyntaxError (..), parseExpAt)
import Language.Futhark.Pretty ()
import Language.Futhark.Prop (UncheckedExp)
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
(Int -> ProgramTest -> ShowS)
-> (ProgramTest -> String)
-> ([ProgramTest] -> ShowS)
-> Show ProgramTest
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ProgramTest -> ShowS
showsPrec :: Int -> ProgramTest -> ShowS
$cshow :: ProgramTest -> String
show :: ProgramTest -> String
$cshowList :: [ProgramTest] -> ShowS
showList :: [ProgramTest] -> ShowS
Show)

-- | How to test a program.
data TestAction
  = CompileTimeFailure ExpectedError
  | RunCases [InputOutputs] [StructureTest] [WarningTest] [PropertyCase]
  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
$cshowsPrec :: Int -> TestAction -> ShowS
showsPrec :: Int -> TestAction -> ShowS
$cshow :: TestAction -> String
show :: TestAction -> String
$cshowList :: [TestAction] -> ShowS
showList :: [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
$cshowsPrec :: Int -> InputOutputs -> ShowS
showsPrec :: Int -> InputOutputs -> ShowS
$cshow :: InputOutputs -> String
show :: InputOutputs -> String
$cshowList :: [InputOutputs] -> ShowS
showList :: [InputOutputs] -> ShowS
Show)

newtype PropertyCase = PropertyCase
  {PropertyCase -> Text
propertyEntryPoint :: T.Text}
  deriving (Int -> PropertyCase -> ShowS
[PropertyCase] -> ShowS
PropertyCase -> String
(Int -> PropertyCase -> ShowS)
-> (PropertyCase -> String)
-> ([PropertyCase] -> ShowS)
-> Show PropertyCase
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> PropertyCase -> ShowS
showsPrec :: Int -> PropertyCase -> ShowS
$cshow :: PropertyCase -> String
show :: PropertyCase -> String
$cshowList :: [PropertyCase] -> ShowS
showList :: [PropertyCase] -> 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
  = GpuPipeline
  | MCPipeline
  | SOACSPipeline
  | SeqMemPipeline
  | GpuMemPipeline
  | MCMemPipeline
  | 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
$cshowsPrec :: Int -> StructurePipeline -> ShowS
showsPrec :: Int -> StructurePipeline -> ShowS
$cshow :: StructurePipeline -> String
show :: StructurePipeline -> String
$cshowList :: [StructurePipeline] -> ShowS
showList :: [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
$cshowsPrec :: Int -> StructureTest -> ShowS
showsPrec :: Int -> StructureTest -> ShowS
$cshow :: StructureTest -> String
show :: StructureTest -> String
$cshowList :: [StructureTest] -> ShowS
showList :: [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 -> [Text]
runTags :: [T.Text],
    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
(Int -> TestRun -> ShowS)
-> (TestRun -> String) -> ([TestRun] -> ShowS) -> Show TestRun
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> TestRun -> ShowS
showsPrec :: Int -> TestRun -> ShowS
$cshow :: TestRun -> String
show :: TestRun -> String
$cshowList :: [TestRun] -> ShowS
showList :: [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]
  | -- | A Futhark expression, evaluated by the interpreter in the
    -- context of the program, with calls to entry points run on the
    -- compiled program.
    ScriptValues UncheckedExp
  | -- | A file containing such an expression.
    ScriptFile FilePath
  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
$cshowsPrec :: Int -> Values -> ShowS
showsPrec :: Int -> Values -> ShowS
$cshow :: Values -> String
show :: Values -> String
$cshowList :: [Values] -> ShowS
showList :: [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
(Int -> GenValue -> ShowS)
-> (GenValue -> String) -> ([GenValue] -> ShowS) -> Show GenValue
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> GenValue -> ShowS
showsPrec :: Int -> GenValue -> ShowS
$cshow :: GenValue -> String
show :: GenValue -> String
$cshowList :: [GenValue] -> ShowS
showList :: [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)) =
  (Int -> Text) -> [Int] -> Text
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (\Int
d -> Text
"[" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
showText Int
d Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"]") [Int]
ds Text -> Text -> Text
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
[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
$cshowsPrec :: forall values. Show values => Int -> ExpectedResult values -> ShowS
showsPrec :: Int -> ExpectedResult values -> ShowS
$cshow :: forall values. Show values => ExpectedResult values -> String
show :: ExpectedResult values -> String
$cshowList :: forall values. Show values => [ExpectedResult values] -> ShowS
showList :: [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
$cshowsPrec :: Int -> Success -> ShowS
showsPrec :: Int -> Success -> ShowS
$cshow :: Success -> String
show :: Success -> String
$cshowList :: [Success] -> ShowS
showList :: [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 Parser a -> Parser () -> Parser a
forall a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity a
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 Parser a -> Parser () -> Parser a
forall a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity 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

-- Like 'lexstr', but does not consume trailing linebreaks.
lexstr' :: T.Text -> Parser ()
lexstr' :: Text -> Parser ()
lexstr' = Parser Text -> Parser ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Parser Text -> Parser ())
-> (Text -> Parser Text) -> Text -> Parser ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Parser Text -> Parser Text
forall a. Parser a -> Parser a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (Parser Text -> Parser Text)
-> (Text -> Parser Text) -> Text -> Parser Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Parser Text -> Parser Text
forall a. Parser a -> Parser a
lexeme' (Parser Text -> Parser Text)
-> (Text -> Parser Text) -> Text -> Parser Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Parser Text
Tokens Text -> ParsecT Void Text Identity (Tokens Text)
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 = Parser Text
-> Parser Text
-> ParsecT Void Text Identity a
-> ParsecT Void Text Identity a
forall (m :: * -> *) open close a.
Applicative m =>
m open -> m close -> m a -> m a
between (Parser () -> Parser Text -> Parser Text
forall a. Parser () -> Parser a -> Parser a
lexeme Parser ()
sep Parser Text
"{") (Parser () -> Parser Text -> 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 =
  Parser () -> Parser Int -> Parser Int
forall a. Parser () -> Parser a -> Parser a
lexeme Parser ()
sep (Parser Int -> Parser Int) -> Parser Int -> Parser Int
forall a b. (a -> b) -> a -> b
$ (Int -> Int -> Int) -> Int -> [Int] -> Int
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
L.foldl' Int -> Int -> Int
forall {a}. Num a => a -> a -> a
addDigit 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 a.
ParsecT Void Text Identity a -> ParsecT Void Text Identity [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
some ParsecT Void Text Identity Char
ParsecT Void Text Identity (Token Text)
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 a -> a -> a
forall {a}. Num a => a -> a -> a
* a
10 a -> a -> a
forall {a}. Num a => a -> a -> a
+ a
x
    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 :: Parser Text
restOfLine = do
  l <- Parser Text
restOfLine_
  if T.null l then void eol else void eol <|> eof
  pure l

restOfLine_ :: Parser T.Text
restOfLine_ :: Parser 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 (Token Text -> Token Text -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
Token Text
'\n')

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

lTagName :: Parser () -> Parser T.Text
lTagName :: Parser () -> Parser Text
lTagName Parser ()
sep =
  Parser () -> Parser Text -> Parser Text
forall a. Parser () -> Parser a -> Parser a
lexeme Parser ()
sep (Parser Text -> Parser Text) -> Parser Text -> Parser Text
forall a b. (a -> b) -> a -> b
$
    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)
takeWhile1P (String -> Maybe String
forall a. a -> Maybe a
Just String
"tag-constituent character") Char -> Bool
Token Text -> Bool
tagConstituent

parseTags :: Parser () -> Parser [T.Text]
parseTags :: Parser () -> ParsecT Void Text Identity [Text]
parseTags Parser ()
sep =
  [ParsecT Void Text Identity [Text]]
-> ParsecT Void Text Identity [Text]
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice
    [ Parser Text -> Parser Text
forall a. Parser a -> Parser a
lexeme' Parser Text
"tags" Parser Text
-> ParsecT Void Text Identity [Text]
-> ParsecT Void Text Identity [Text]
forall a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser ()
-> ParsecT Void Text Identity [Text]
-> ParsecT Void Text Identity [Text]
forall a. Parser () -> Parser a -> Parser a
inBraces Parser ()
sep (Parser Text -> ParsecT Void Text Identity [Text]
forall a.
ParsecT Void Text Identity a -> ParsecT Void Text Identity [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many (Parser () -> Parser Text
lTagName Parser ()
sep)),
      [Text] -> ParsecT Void Text Identity [Text]
forall a. a -> ParsecT Void Text Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
    ]

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 () -> Parser TestAction
parseAction :: Parser () -> Parser TestAction
parseAction Parser ()
sep =
  [Parser TestAction] -> Parser TestAction
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice
    [ 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 a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser () -> ParsecT Void Text Identity ExpectedError
parseExpectedError Parser ()
sep),
      Parser TestAction -> Parser TestAction
forall a. Parser a -> Parser a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try Parser TestAction
parseAsProperty,
      Parser TestAction
parseAsRunCase
    ]
  where
    parseAsProperty :: Parser TestAction
parseAsProperty = do
      props <- Parser () -> Parser [PropertyCase]
parseProperty Parser ()
sep
      pure $ RunCases [] [] [] props

    parseAsRunCase :: Parser TestAction
parseAsRunCase =
      [InputOutputs]
-> [StructureTest] -> [WarningTest] -> [PropertyCase] -> TestAction
RunCases
        ([InputOutputs]
 -> [StructureTest]
 -> [WarningTest]
 -> [PropertyCase]
 -> TestAction)
-> ParsecT Void Text Identity [InputOutputs]
-> ParsecT
     Void
     Text
     Identity
     ([StructureTest] -> [WarningTest] -> [PropertyCase] -> TestAction)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser () -> ParsecT Void Text Identity [InputOutputs]
parseInputOutputs Parser ()
sep
        ParsecT
  Void
  Text
  Identity
  ([StructureTest] -> [WarningTest] -> [PropertyCase] -> TestAction)
-> ParsecT Void Text Identity [StructureTest]
-> ParsecT
     Void Text Identity ([WarningTest] -> [PropertyCase] -> TestAction)
forall a b.
ParsecT Void Text Identity (a -> b)
-> ParsecT Void Text Identity a -> ParsecT Void Text Identity b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ParsecT Void Text Identity StructureTest
-> ParsecT Void Text Identity [StructureTest]
forall a.
ParsecT Void Text Identity a -> ParsecT Void Text Identity [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many (Parser () -> ParsecT Void Text Identity StructureTest
parseExpectedStructure Parser ()
sep)
        ParsecT
  Void Text Identity ([WarningTest] -> [PropertyCase] -> TestAction)
-> ParsecT Void Text Identity [WarningTest]
-> ParsecT Void Text Identity ([PropertyCase] -> TestAction)
forall a b.
ParsecT Void Text Identity (a -> b)
-> ParsecT Void Text Identity a -> ParsecT Void Text Identity b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ParsecT Void Text Identity WarningTest
-> ParsecT Void Text Identity [WarningTest]
forall a.
ParsecT Void Text Identity a -> ParsecT Void Text Identity [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many (Parser () -> ParsecT Void Text Identity WarningTest
parseWarning Parser ()
sep)
        ParsecT Void Text Identity ([PropertyCase] -> TestAction)
-> Parser [PropertyCase] -> Parser TestAction
forall a b.
ParsecT Void Text Identity (a -> b)
-> ParsecT Void Text Identity a -> ParsecT Void Text Identity b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [PropertyCase] -> Parser [PropertyCase]
forall a. a -> ParsecT Void Text Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []

parseProperty :: Parser () -> Parser [PropertyCase]
parseProperty :: Parser () -> Parser [PropertyCase]
parseProperty Parser ()
sep = do
  entryss <- ParsecT Void Text Identity [Text]
-> ParsecT Void Text Identity [[Text]]
forall a.
ParsecT Void Text Identity a -> ParsecT Void Text Identity [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
some (Parser () -> ParsecT Void Text Identity [Text]
parseEntryPointsProp Parser ()
sep)
  pure $ map PropertyCase (concat entryss)

parseEntryPointsProp :: Parser () -> Parser [T.Text]
parseEntryPointsProp :: Parser () -> ParsecT Void Text Identity [Text]
parseEntryPointsProp Parser ()
sep =
  Parser Text -> Parser Text
forall a. Parser a -> Parser a
lexeme' Parser Text
"property:" Parser Text
-> ParsecT Void Text Identity [Text]
-> ParsecT Void Text Identity [Text]
forall a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Text -> ParsecT Void Text Identity [Text]
forall a.
ParsecT Void Text Identity a -> ParsecT Void Text Identity [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
some Parser Text
entry ParsecT Void Text Identity [Text]
-> Parser () -> ParsecT Void Text Identity [Text]
forall a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
sep
  where
    constituent :: Char -> Bool
constituent Char
c = Bool -> Bool
not (Char -> Bool
isSpace Char
c)
    entry :: ParsecT Void Text Identity (Tokens Text)
entry = ParsecT Void Text Identity (Tokens Text)
-> ParsecT Void Text Identity (Tokens Text)
forall a. Parser a -> Parser a
lexeme' (ParsecT Void Text Identity (Tokens Text)
 -> ParsecT Void Text Identity (Tokens Text))
-> ParsecT Void Text Identity (Tokens Text)
-> ParsecT Void Text Identity (Tokens Text)
forall a b. (a -> b) -> a -> b
$ 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)
takeWhile1P Maybe String
forall a. Maybe a
Nothing Char -> Bool
Token Text -> Bool
constituent

parseInputOutputs :: Parser () -> Parser [InputOutputs]
parseInputOutputs :: Parser () -> ParsecT Void Text Identity [InputOutputs]
parseInputOutputs Parser ()
sep = do
  entrys <- Parser () -> ParsecT Void Text Identity [Text]
parseEntryPoints Parser ()
sep
  cases <- parseRunCases sep
  pure $
    if null cases
      then []
      else map (`InputOutputs` cases) entrys

parseEntryPoints :: Parser () -> Parser [T.Text]
parseEntryPoints :: Parser () -> ParsecT Void Text Identity [Text]
parseEntryPoints Parser ()
sep =
  (Parser Text -> Parser Text
forall a. Parser a -> Parser a
lexeme' Parser Text
"entry:" Parser Text
-> ParsecT Void Text Identity [Text]
-> ParsecT Void Text Identity [Text]
forall a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Text -> ParsecT Void Text Identity [Text]
forall a.
ParsecT Void Text Identity a -> ParsecT Void Text Identity [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many Parser Text
entry ParsecT Void Text Identity [Text]
-> Parser () -> ParsecT Void Text Identity [Text]
forall a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
sep) ParsecT Void Text Identity [Text]
-> ParsecT Void Text Identity [Text]
-> ParsecT Void Text Identity [Text]
forall a.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> [Text] -> ParsecT Void Text Identity [Text]
forall a. a -> ParsecT Void Text Identity 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 Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'}'
    entry :: ParsecT Void Text Identity (Tokens Text)
entry = ParsecT Void Text Identity (Tokens Text)
-> ParsecT Void Text Identity (Tokens Text)
forall a. Parser a -> Parser a
lexeme' (ParsecT Void Text Identity (Tokens Text)
 -> ParsecT Void Text Identity (Tokens Text))
-> ParsecT Void Text Identity (Tokens Text)
-> ParsecT Void Text Identity (Tokens Text)
forall a b. (a -> b) -> a -> b
$ 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)
takeWhile1P Maybe String
forall a. Maybe a
Nothing Char -> Bool
Token Text -> Bool
constituent

parseRunTags :: Parser () -> Parser [T.Text]
parseRunTags :: Parser () -> ParsecT Void Text Identity [Text]
parseRunTags Parser ()
sep = Parser Text -> ParsecT Void Text Identity [Text]
forall a.
ParsecT Void Text Identity a -> ParsecT Void Text Identity [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many (Parser Text -> ParsecT Void Text Identity [Text])
-> (Parser Text -> Parser Text)
-> Parser Text
-> ParsecT Void Text Identity [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Parser Text -> Parser Text
forall a. Parser a -> Parser a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (Parser Text -> Parser Text)
-> (Parser Text -> Parser Text) -> Parser Text -> Parser Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Parser Text -> Parser Text
forall a. Parser a -> Parser a
lexeme' (Parser Text -> ParsecT Void Text Identity [Text])
-> Parser Text -> ParsecT Void Text Identity [Text]
forall a b. (a -> b) -> a -> b
$ do
  s <- Parser () -> Parser Text
lTagName Parser ()
sep
  guard $ s `notElem` ["input", "structure", "warning"]
  pure s

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

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 =
      (:) (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 a b.
ParsecT Void Text Identity (a -> b)
-> ParsecT Void Text Identity a -> ParsecT Void Text Identity b
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 a.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> [TestRun] -> Parser [TestRun]
forall a. a -> ParsecT Void Text Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
    parseRunCase :: Int -> ParsecT Void Text Identity TestRun
parseRunCase Int
i = do
      name <- Parser Text -> ParsecT Void Text Identity (Maybe Text)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (Parser Text -> ParsecT Void Text Identity (Maybe Text))
-> Parser Text -> ParsecT Void Text Identity (Maybe Text)
forall a b. (a -> b) -> a -> b
$ Parser () -> Parser Text
parseStringLiteral Parser ()
sep
      tags <- parseRunTags sep
      void $ lexeme sep "input"
      input <-
        if "random" `elem` tags
          then parseRandomValues sep
          else
            if "script" `elem` tags
              then parseScriptValues sep
              else parseValues sep
      expr <- parseExpectedResult sep
      pure $ TestRun tags input expr i $ fromMaybe (desc i input) 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 String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
".gz" = String -> Text
T.pack (String -> Text) -> String -> Text
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
"#" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> a -> Text
forall a. Show a => a -> Text
showText a
i Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" (\"" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
T.unwords (Text -> [Text]
T.lines Text
vs') Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\")"
      where
        vs' :: Text
vs' = case [Text] -> Text
T.unwords ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ (Value -> Text) -> [Value] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Value -> Text
V.valueText [Value]
vs of
          Text
s
            | Text -> Int
T.length Text
s Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
50 -> Int -> Text -> Text
T.take Int
50 Text
s Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"..."
            | Bool
otherwise -> Text
s
    desc a
_ (GenValues [GenValue]
gens) =
      [Text] -> Text
T.unwords ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ (GenValue -> Text) -> [GenValue] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map GenValue -> Text
genValueType [GenValue]
gens
    desc a
_ (ScriptValues UncheckedExp
e) =
      UncheckedExp -> Text
forall a. Pretty a => a -> Text
prettyTextOneLine UncheckedExp
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 =
  [Parser (ExpectedResult Success)]
-> Parser (ExpectedResult Success)
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice
    [ Parser () -> Parser Text -> Parser Text
forall a. Parser () -> Parser a -> Parser a
lexeme Parser ()
sep Parser Text
"auto" Parser Text -> Parser Text -> Parser Text
forall a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser () -> Parser Text -> Parser Text
forall a. Parser () -> Parser a -> Parser a
lexeme Parser ()
sep Parser Text
"output" Parser Text
-> 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),
      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
<$> (Parser () -> Parser Text -> Parser Text
forall a. Parser () -> Parser a -> Parser a
lexeme Parser ()
sep Parser Text
"output" Parser Text -> Parser Values -> Parser Values
forall a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser () -> Parser Values
parseValues Parser ()
sep),
      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
<$> (Parser () -> Parser Text -> Parser Text
forall a. Parser () -> Parser a -> Parser a
lexeme Parser ()
sep Parser Text
"error:" Parser Text
-> ParsecT Void Text Identity ExpectedError
-> ParsecT Void Text Identity ExpectedError
forall a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser () -> ParsecT Void Text Identity ExpectedError
parseExpectedError Parser ()
sep),
      ExpectedResult Success -> Parser (ExpectedResult Success)
forall a. a -> ParsecT Void Text Identity a
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 () -> Parser ExpectedError
parseExpectedError :: Parser () -> ParsecT Void Text Identity ExpectedError
parseExpectedError Parser ()
sep = Parser ()
-> ParsecT Void Text Identity ExpectedError
-> ParsecT Void Text Identity ExpectedError
forall a. Parser () -> Parser a -> Parser a
lexeme Parser ()
sep (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
  s <- Text -> Text
T.strip (Text -> Text) -> Parser Text -> Parser Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text
restOfLine_ Parser Text -> Parser () -> Parser Text
forall a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
sep
  if T.null s
    then pure AnyError
    else -- blankCompOpt creates a regular expression that treats
    -- newlines like ordinary characters, which is what we want.
      ThisError s <$> makeRegexOptsM blankCompOpt defaultExecOpt (T.unpack s)

parseScriptValues :: Parser () -> Parser Values
parseScriptValues :: Parser () -> Parser Values
parseScriptValues Parser ()
sep =
  [Parser Values] -> Parser Values
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice
    [ UncheckedExp -> Values
ScriptValues (UncheckedExp -> Values)
-> ParsecT Void Text Identity UncheckedExp -> Parser Values
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ()
-> ParsecT Void Text Identity UncheckedExp
-> ParsecT Void Text Identity UncheckedExp
forall a. Parser () -> Parser a -> Parser a
inBraces Parser ()
sep ParsecT Void Text Identity UncheckedExp
parseScriptExp,
      String -> Values
ScriptFile (String -> Values) -> (Text -> String) -> Text -> Values
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack (Text -> Values) -> Parser Text -> Parser Values
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Parser () -> Parser Text -> Parser Text
forall a. Parser () -> Parser a -> Parser a
lexeme Parser ()
sep Parser Text
"@" Parser Text -> Parser Text -> Parser Text
forall a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser () -> Parser Text -> Parser Text
forall a. Parser () -> Parser a -> Parser a
lexeme Parser ()
sep Parser 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) -> (Token Text -> Bool) -> Token Text -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Bool
Token Text -> Bool
isSpace

-- | Parse a Futhark expression embedded in a comment block, consisting of the
-- text consumed by the given parser. We slice out that text and hand it to the
-- Futhark parser. This is somewhat clumsy because the Futhark parser is not
-- written with parser combinators.
parseEmbeddedExp :: Parser () -> Parser UncheckedExp
parseEmbeddedExp :: Parser () -> ParsecT Void Text Identity UncheckedExp
parseEmbeddedExp Parser ()
extent = do
  pos <- Parser Pos
sourcePos
  s <- getInput
  bef <- getOffset
  extent
  aft <- getOffset
  -- To get the right source positions, we replace comment prefixes with spaces.
  case parseExpAt pos $ blankCommentPrefix $ T.take (aft - bef) s of
    Left (SyntaxError Loc
loc Text
msg) -> do
      case Loc
loc of
        Loc.Loc Pos
start Pos
_ -> Int -> Parser ()
forall e s (m :: * -> *). MonadParsec e s m => Int -> m ()
setOffset (Int -> Parser ()) -> Int -> Parser ()
forall a b. (a -> b) -> a -> b
$ Pos -> Int
Loc.posCoff Pos
start
        Loc
Loc.NoLoc -> () -> Parser ()
forall a. a -> ParsecT Void Text Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      String -> ParsecT Void Text Identity UncheckedExp
forall a. String -> ParsecT Void Text Identity a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> ParsecT Void Text Identity UncheckedExp)
-> String -> ParsecT Void Text Identity UncheckedExp
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ Text -> Text
T.strip Text
msg
    Right UncheckedExp
e -> UncheckedExp -> ParsecT Void Text Identity UncheckedExp
forall a. a -> ParsecT Void Text Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure UncheckedExp
e

-- | The current position, in the form used by the Futhark parser.
sourcePos :: Parser Loc.Pos
sourcePos :: Parser Pos
sourcePos = do
  p <- ParsecT Void Text Identity SourcePos
forall s e (m :: * -> *).
(TraversableStream s, MonadParsec e s m) =>
m SourcePos
getSourcePos
  Loc.Pos (sourceName p) (unPos (sourceLine p)) (unPos (sourceColumn p)) <$> getOffset

-- | A script expression extends to the matching closing brace. Braces inside
-- string literals are not counted.
parseScriptExp :: Parser UncheckedExp
parseScriptExp :: ParsecT Void Text Identity UncheckedExp
parseScriptExp = Parser () -> ParsecT Void Text Identity UncheckedExp
parseEmbeddedExp Parser ()
balanced
  where
    balanced :: Parser ()
balanced =
      Parser () -> Parser ()
forall (m :: * -> *) a. MonadPlus m => m a -> m ()
skipMany (Parser () -> Parser ()) -> Parser () -> Parser ()
forall a b. (a -> b) -> a -> b
$
        [Parser ()] -> Parser ()
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice
          [ ParsecT Void Text Identity (Tokens Text) -> Parser ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ParsecT Void Text Identity (Tokens Text) -> Parser ())
-> ParsecT Void Text Identity (Tokens Text) -> Parser ()
forall a b. (a -> b) -> a -> b
$ 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)
takeWhile1P Maybe String
forall a. Maybe a
Nothing (Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` (String
"{}\"" :: String)),
            ParsecT Void Text Identity String -> Parser ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ParsecT Void Text Identity String -> Parser ())
-> ParsecT Void Text Identity String -> Parser ()
forall a b. (a -> b) -> a -> b
$ Token Text -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token Text
'"' ParsecT Void Text Identity Char
-> ParsecT Void Text Identity String
-> ParsecT Void Text Identity String
forall a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT Void Text Identity Char
-> ParsecT Void Text Identity Char
-> ParsecT Void Text Identity String
forall (m :: * -> *) a end. MonadPlus m => m a -> m end -> m [a]
manyTill ParsecT Void Text Identity Char
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m Char
charLiteral (Token Text -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token Text
'"'),
            ParsecT Void Text Identity Char -> Parser ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ParsecT Void Text Identity Char -> Parser ())
-> ParsecT Void Text Identity Char -> Parser ()
forall a b. (a -> b) -> a -> b
$ Token Text -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token Text
'{' ParsecT Void Text Identity Char -> Parser () -> Parser ()
forall a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser ()
balanced Parser ()
-> ParsecT Void Text Identity Char
-> ParsecT Void Text Identity Char
forall a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Token Text -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token Text
'}'
          ]

-- | Replace the comment marker on every line but the first with spaces.
blankCommentPrefix :: T.Text -> T.Text
blankCommentPrefix :: Text -> Text
blankCommentPrefix Text
s =
  case Text -> [Text]
T.lines Text
s of
    [] -> Text
s
    Text
l : [Text]
ls -> Text -> [Text] -> Text
T.intercalate Text
"\n" ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ Text
l Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: (Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Text -> Text
onLine [Text]
ls
  where
    onLine :: Text -> Text
onLine Text
l = Text -> (Text -> Text) -> Maybe Text -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
l (Text
"  " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>) (Maybe Text -> Text) -> Maybe Text -> Text
forall a b. (a -> b) -> a -> b
$ Text -> Text -> Maybe Text
T.stripPrefix Text
"--" Text
l

parseRandomValues :: Parser () -> Parser Values
parseRandomValues :: Parser () -> Parser Values
parseRandomValues Parser ()
sep = [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 ()
-> ParsecT Void Text Identity [GenValue]
-> ParsecT Void Text Identity [GenValue]
forall a. Parser () -> Parser a -> Parser a
inBraces Parser ()
sep (ParsecT Void Text Identity GenValue
-> ParsecT Void Text Identity [GenValue]
forall a.
ParsecT Void Text Identity a -> ParsecT Void Text Identity [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many (Parser () -> ParsecT Void Text Identity GenValue
parseGenValue Parser ()
sep))

parseGenValue :: Parser () -> Parser GenValue
parseGenValue :: Parser () -> ParsecT Void Text Identity GenValue
parseGenValue Parser ()
sep =
  [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
<$> Parser ()
-> ParsecT Void Text Identity ValueType
-> ParsecT Void Text Identity ValueType
forall a. Parser () -> Parser a -> Parser a
lexeme Parser ()
sep ParsecT Void Text Identity ValueType
parseType,
      Value -> GenValue
GenPrim (Value -> GenValue)
-> ParsecT Void Text Identity Value
-> ParsecT Void Text Identity GenValue
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ()
-> ParsecT Void Text Identity Value
-> ParsecT Void Text Identity Value
forall a. Parser () -> Parser a -> Parser a
lexeme Parser ()
sep ParsecT Void Text Identity Value
V.parsePrimValue
    ]

parseValues :: Parser () -> Parser Values
parseValues :: Parser () -> Parser Values
parseValues Parser ()
sep =
  [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
<$> Parser ()
-> ParsecT Void Text Identity [Value]
-> ParsecT Void Text Identity [Value]
forall a. Parser () -> Parser a -> Parser a
inBraces Parser ()
sep (ParsecT Void Text Identity Value
-> ParsecT Void Text Identity [Value]
forall a.
ParsecT Void Text Identity a -> ParsecT Void Text Identity [a]
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 ()
sep),
      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) -> Parser Text -> Parser Values
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Parser () -> Parser Text -> Parser Text
forall a. Parser () -> Parser a -> Parser a
lexeme Parser ()
sep Parser Text
"@" Parser Text -> Parser Text -> Parser Text
forall a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser () -> Parser Text -> Parser Text
forall a. Parser () -> Parser a -> Parser a
lexeme Parser ()
sep Parser 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) -> (Token Text -> Bool) -> Token Text -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Bool
Token Text -> Bool
isSpace

parseWarning :: Parser () -> Parser WarningTest
parseWarning :: Parser () -> ParsecT Void Text Identity WarningTest
parseWarning Parser ()
sep = Parser () -> Parser Text -> Parser Text
forall a. Parser () -> Parser a -> Parser a
lexeme Parser ()
sep Parser Text
"warning:" Parser Text
-> ParsecT Void Text Identity WarningTest
-> ParsecT Void Text Identity WarningTest
forall a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity b
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 = Parser ()
-> ParsecT Void Text Identity WarningTest
-> ParsecT Void Text Identity WarningTest
forall a. Parser () -> Parser a -> Parser a
lexeme Parser ()
sep (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
      s <- Text -> Text
T.strip (Text -> Text) -> Parser Text -> Parser Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text
restOfLine_
      ExpectedWarning s <$> makeRegexOptsM blankCompOpt defaultExecOpt (T.unpack s)

parseExpectedStructure :: Parser () -> Parser StructureTest
parseExpectedStructure :: Parser () -> ParsecT Void Text Identity StructureTest
parseExpectedStructure Parser ()
sep =
  Parser () -> Parser Text -> Parser Text
forall a. Parser () -> Parser a -> Parser a
lexeme Parser ()
sep Parser Text
"structure" Parser Text
-> ParsecT Void Text Identity StructureTest
-> ParsecT Void Text Identity StructureTest
forall a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity b
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
<$> Parser () -> ParsecT Void Text Identity StructurePipeline
optimisePipeline Parser ()
sep ParsecT Void Text Identity (AstMetrics -> StructureTest)
-> ParsecT Void Text Identity AstMetrics
-> ParsecT Void Text Identity StructureTest
forall a b.
ParsecT Void Text Identity (a -> b)
-> ParsecT Void Text Identity a -> ParsecT Void Text Identity b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser () -> ParsecT Void Text Identity AstMetrics
parseMetrics Parser ()
sep)

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

parseMetrics :: Parser () -> Parser AstMetrics
parseMetrics :: Parser () -> ParsecT Void Text Identity AstMetrics
parseMetrics Parser ()
sep =
  Parser ()
-> ParsecT Void Text Identity AstMetrics
-> ParsecT Void Text Identity AstMetrics
forall a. Parser () -> Parser a -> Parser a
inBraces Parser ()
sep (ParsecT Void Text Identity AstMetrics
 -> ParsecT Void Text Identity AstMetrics)
-> (ParsecT Void Text Identity (Text, Int)
    -> ParsecT Void Text Identity AstMetrics)
-> ParsecT Void Text Identity (Text, Int)
-> ParsecT Void Text Identity AstMetrics
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([(Text, Int)] -> AstMetrics)
-> ParsecT Void Text Identity [(Text, Int)]
-> ParsecT Void Text Identity AstMetrics
forall a b.
(a -> b)
-> ParsecT Void Text Identity a -> ParsecT Void Text Identity b
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 [(Text, Int)])
-> ParsecT Void Text Identity (Text, Int)
-> ParsecT Void Text Identity AstMetrics
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParsecT Void Text Identity (Text, Int)
-> ParsecT Void Text Identity [(Text, Int)]
forall a.
ParsecT Void Text Identity a -> ParsecT Void Text Identity [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many (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
$
    (,) (Text -> Int -> (Text, Int))
-> Parser Text -> ParsecT Void Text Identity (Int -> (Text, Int))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser () -> Parser Text -> Parser Text
forall a. Parser () -> Parser a -> Parser a
lexeme Parser ()
sep (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)
takeWhile1P Maybe String
forall a. Maybe a
Nothing Char -> Bool
Token Text -> Bool
constituent) ParsecT Void Text Identity (Int -> (Text, Int))
-> Parser Int -> ParsecT Void Text Identity (Text, Int)
forall a b.
ParsecT Void Text Identity (a -> b)
-> ParsecT Void Text Identity a -> ParsecT Void Text Identity b
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 Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'/'

testSpec :: Parser () -> Parser ProgramTest
testSpec :: Parser () -> Parser ProgramTest
testSpec Parser ()
sep =
  Text -> [Text] -> TestAction -> ProgramTest
ProgramTest (Text -> [Text] -> TestAction -> ProgramTest)
-> Parser Text
-> ParsecT Void Text Identity ([Text] -> TestAction -> ProgramTest)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser () -> Parser Text
parseDescription Parser ()
sep ParsecT Void Text Identity ([Text] -> TestAction -> ProgramTest)
-> ParsecT Void Text Identity [Text]
-> ParsecT Void Text Identity (TestAction -> ProgramTest)
forall a b.
ParsecT Void Text Identity (a -> b)
-> ParsecT Void Text Identity a -> ParsecT Void Text Identity b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser () -> ParsecT Void Text Identity [Text]
parseTags Parser ()
sep ParsecT Void Text Identity (TestAction -> ProgramTest)
-> Parser TestAction -> Parser ProgramTest
forall a b.
ParsecT Void Text Identity (a -> b)
-> ParsecT Void Text Identity a -> ParsecT Void Text Identity b
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 = Either String a -> IO (Either String a)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (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 a.
ParsecT Void Text Identity a -> ParsecT Void Text Identity [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many Parser ()
pNonTestLine
  maybe_spec <-
    Parser ProgramTest
-> ParsecT Void Text Identity (Maybe ProgramTest)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (Parser Text
"--" Parser Text -> Parser () -> Parser ()
forall a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser ()
sep Parser () -> Parser ProgramTest -> Parser ProgramTest
forall a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser () -> Parser ProgramTest
testSpec Parser ()
sep) ParsecT Void Text Identity (Maybe ProgramTest)
-> Parser () -> ParsecT Void Text Identity (Maybe ProgramTest)
forall a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity a
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 a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser () -> ParsecT Void Text Identity [()]
forall a.
ParsecT Void Text Identity a -> ParsecT Void Text Identity [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many Parser ()
pNonTestLine
  case maybe_spec of
    Just ProgramTest
spec
      | RunCases [InputOutputs]
old_cases [StructureTest]
structures [WarningTest]
warnings [PropertyCase]
old_properties <- ProgramTest -> TestAction
testAction ProgramTest
spec -> do
          let pAnyBlock :: ParsecT Void Text Identity (Either [InputOutputs] [PropertyCase])
pAnyBlock = ([InputOutputs] -> Either [InputOutputs] [PropertyCase]
forall a b. a -> Either a b
Left ([InputOutputs] -> Either [InputOutputs] [PropertyCase])
-> ParsecT Void Text Identity [InputOutputs]
-> ParsecT
     Void Text Identity (Either [InputOutputs] [PropertyCase])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void Text Identity [InputOutputs]
pInputOutputs) ParsecT Void Text Identity (Either [InputOutputs] [PropertyCase])
-> ParsecT
     Void Text Identity (Either [InputOutputs] [PropertyCase])
-> ParsecT
     Void Text Identity (Either [InputOutputs] [PropertyCase])
forall a.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ([PropertyCase] -> Either [InputOutputs] [PropertyCase]
forall a b. b -> Either a b
Right ([PropertyCase] -> Either [InputOutputs] [PropertyCase])
-> Parser [PropertyCase]
-> ParsecT
     Void Text Identity (Either [InputOutputs] [PropertyCase])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser [PropertyCase]
pPropertyCases)
          restBlocks <- ParsecT Void Text Identity (Either [InputOutputs] [PropertyCase])
-> ParsecT
     Void Text Identity [Either [InputOutputs] [PropertyCase]]
forall a.
ParsecT Void Text Identity a -> ParsecT Void Text Identity [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many (ParsecT Void Text Identity (Either [InputOutputs] [PropertyCase])
pAnyBlock ParsecT Void Text Identity (Either [InputOutputs] [PropertyCase])
-> ParsecT Void Text Identity [()]
-> ParsecT
     Void Text Identity (Either [InputOutputs] [PropertyCase])
forall a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser () -> ParsecT Void Text Identity [()]
forall a.
ParsecT Void Text Identity a -> ParsecT Void Text Identity [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many Parser ()
pNonTestLine)
          let (restCases, restProperties) = partitionEithers restBlocks
          pure
            spec
              { testAction =
                  RunCases
                    (old_cases ++ concat restCases)
                    structures
                    warnings
                    (old_properties ++ concat restProperties)
              }
      | Bool
otherwise ->
          Parser () -> ParsecT Void Text Identity [()]
forall a.
ParsecT Void Text Identity a -> ParsecT Void Text Identity [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many Parser ()
pNonTestLine
            ParsecT Void Text Identity [()] -> Parser () -> Parser ()
forall a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Text -> Parser ()
forall a. ParsecT Void Text Identity a -> Parser ()
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m ()
notFollowedBy Parser Text
"-- =="
            Parser () -> Parser ProgramTest -> Parser ProgramTest
forall a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ProgramTest -> Parser ProgramTest
forall a. a -> ParsecT Void Text Identity a
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
    sep :: Parser ()
sep = 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 a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity b
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 a. Parser a -> Parser a
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 (Tokens Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Tokens s)
eol ParsecT Void Text Identity (Tokens Text)
-> Parser Text -> Parser Text
forall a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Text
"--" Parser Text -> Parser () -> Parser ()
forall a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser ()
sep)

    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] -> [PropertyCase] -> TestAction
RunCases [InputOutputs]
forall a. Monoid a => a
mempty [StructureTest]
forall a. Monoid a => a
mempty [WarningTest]
forall a. Monoid a => a
mempty [PropertyCase]
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 a.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity a -> ParsecT Void Text Identity a
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 a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Text -> Parser ()
forall a. ParsecT Void Text Identity a -> Parser ()
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m ()
notFollowedBy Parser Text
"--"
    pNonTestLine :: Parser ()
pNonTestLine =
      Parser Text -> Parser ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Parser Text -> Parser ()) -> Parser Text -> Parser ()
forall a b. (a -> b) -> a -> b
$ Parser Text -> Parser ()
forall a. ParsecT Void Text Identity a -> Parser ()
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m ()
notFollowedBy Parser Text
"-- ==" Parser () -> Parser Text -> Parser Text
forall a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Text
restOfLine
    pInputOutputs :: ParsecT Void Text Identity [InputOutputs]
pInputOutputs =
      ParsecT Void Text Identity [InputOutputs]
-> ParsecT Void Text Identity [InputOutputs]
forall a. Parser a -> Parser a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (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
$
        Parser Text
"--" Parser Text -> Parser () -> Parser ()
forall a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser ()
sep Parser () -> Parser Text -> Parser Text
forall a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser () -> Parser Text
parseDescription Parser ()
sep Parser Text
-> ParsecT Void Text Identity [InputOutputs]
-> ParsecT Void Text Identity [InputOutputs]
forall a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser () -> ParsecT Void Text Identity [InputOutputs]
parseInputOutputs Parser ()
sep ParsecT Void Text Identity [InputOutputs]
-> Parser () -> ParsecT Void Text Identity [InputOutputs]
forall a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
pEndOfTestBlock
    pPropertyCases :: Parser [PropertyCase]
pPropertyCases =
      Parser Text
"--" Parser Text -> Parser () -> Parser ()
forall a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser ()
sep Parser () -> Parser Text -> Parser Text
forall a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser () -> Parser Text
parseDescription Parser ()
sep Parser Text -> Parser [PropertyCase] -> Parser [PropertyCase]
forall a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser () -> Parser [PropertyCase]
parseProperty Parser ()
sep Parser [PropertyCase] -> Parser () -> Parser [PropertyCase]
forall a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity a
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 {} -> ProgramTest -> Either String ProgramTest
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ProgramTest
pt
    RunCases [InputOutputs]
ios [StructureTest]
_ [WarningTest]
_ [PropertyCase]
_ -> do
      (InputOutputs -> Either String ())
-> [InputOutputs] -> Either String ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ([Text] -> Either String ()
noDups ([Text] -> Either String ())
-> (InputOutputs -> [Text]) -> InputOutputs -> Either String ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TestRun -> Text) -> [TestRun] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map TestRun -> Text
runDescription ([TestRun] -> [Text])
-> (InputOutputs -> [TestRun]) -> InputOutputs -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. InputOutputs -> [TestRun]
iosTestRuns) [InputOutputs]
ios
      ProgramTest -> Either String ProgramTest
forall a b. b -> Either a b
Right ProgramTest
pt
  where
    noDups :: [Text] -> Either String ()
noDups [Text]
xs =
      let xs' :: [Text]
xs' = [Text] -> [Text]
forall a. Ord a => [a] -> [a]
nubOrd [Text]
xs
       in -- Works because \\ only removes first instance.
          case [Text]
xs [Text] -> [Text] -> [Text]
forall a. Eq a => [a] -> [a] -> [a]
L.\\ [Text]
xs' of
            [] -> () -> Either String ()
forall a b. b -> Either a b
Right ()
            Text
x : [Text]
_ -> String -> Either String ()
forall a b. a -> Either a b
Left (String -> Either String ()) -> String -> Either String ()
forall a b. (a -> b) -> a -> b
$ String
path String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
": multiple datasets with name " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> ShowS
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 =
  ( (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) (String -> ProgramTest -> Either String ProgramTest
validate String
path) (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 'testSpecFromProgram', but exits the process on error.
testSpecFromProgramOrDie :: FilePath -> IO ProgramTest
testSpecFromProgramOrDie :: String -> IO ProgramTest
testSpecFromProgramOrDie String
prog = do
  spec_or_err <- String -> IO (Either String ProgramTest)
testSpecFromProgram String
prog
  case spec_or_err of
    Left String
err -> do
      Handle -> String -> IO ()
hPutStrLn Handle
stderr String
err
      IO ProgramTest
forall a. IO a
exitFailure
    Right ProgramTest
spec -> ProgramTest -> IO ProgramTest
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ProgramTest
spec

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

-- | 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
  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 programs_or_err of
    Left String
err -> Either String [(String, ProgramTest)]
-> IO (Either String [(String, ProgramTest)])
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (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
      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)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM String -> IO (Either String ProgramTest)
testSpecFromProgram [String]
programs
      pure $ zip programs <$> sequence 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 a b. (a -> b) -> IO a -> IO b
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 a b. (a -> b) -> Either String a -> Either String b
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)
forall (m :: * -> *) a. Monad m => [m a] -> m [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)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [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
  specs_or_err <- [String] -> IO (Either String [(String, ProgramTest)])
testSpecsFromPaths [String]
dirs
  case specs_or_err of
    Left String
err -> do
      Handle -> String -> IO ()
hPutStrLn Handle
stderr String
err
      IO [(String, ProgramTest)]
forall a. IO a
exitFailure
    Right [(String, ProgramTest)]
specs -> [(String, ProgramTest)] -> IO [(String, ProgramTest)]
forall a. a -> IO a
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 =
  ( (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 () -> Parser ProgramTest
testSpec Parser ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
space) 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 errors.
testSpecFromFileOrDie :: FilePath -> IO ProgramTest
testSpecFromFileOrDie :: String -> IO ProgramTest
testSpecFromFileOrDie String
dirs = do
  spec_or_err <- String -> IO (Either String ProgramTest)
testSpecFromFile String
dirs
  case spec_or_err of
    Left String
err -> do
      Handle -> String -> IO ()
hPutStrLn Handle
stderr String
err
      IO ProgramTest
forall a. IO a
exitFailure
    Right ProgramTest
spec -> ProgramTest -> IO ProgramTest
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ProgramTest
spec