{-# LANGUAGE LambdaCase #-}

-- | @futhark test@
module Futhark.CLI.Test (main) where

import Control.Applicative.Lift (Errors, Lift (..), failure, runErrors)
import Control.Concurrent
import Control.Concurrent.Async
import Control.Exception
import Control.Monad
import Control.Monad.Except (ExceptT (..), MonadError, runExceptT, withExceptT)
import Control.Monad.Except qualified as E
import Control.Monad.IO.Class (MonadIO, liftIO)
import Control.Monad.Trans.Class (lift)
import Data.ByteString qualified as SBS
import Data.ByteString.Lazy qualified as LBS
import Data.IORef
import Data.List (delete, partition)
import Data.Map.Strict qualified as M
import Data.Maybe (mapMaybe)
import Data.Text qualified as T
import Data.Text.Encoding qualified as T
import Data.Text.IO qualified as T
import Data.Time.Clock.System (SystemTime (..), getSystemTime)
import Data.Word (Word64)
import Futhark.Analysis.Metrics.Type
import Futhark.Server
import Futhark.Test
import Futhark.Util (atMostChars, fancyTerminal, nubOrd, randomSeed, showText)
import Futhark.Util.Options
import Futhark.Util.Pretty (annotate, bgColor, bold, hardline, pretty, putDoc, vsep)
import Futhark.Util.Table
import System.Console.ANSI (clearFromCursorToScreenEnd, clearLine, cursorUpLine)
import System.Console.Terminal.Size qualified as Terminal
import System.Environment
import System.Exit
import System.FilePath
import System.IO
import System.Process.ByteString (readProcessWithExitCode)
import Text.Regex.TDFA

--- Test execution

-- The use of [T.Text] here is somewhat kludgy. We use it to track how
-- many errors have occurred during testing of a single program (which
-- may have multiple entry points). This should really not be done at
-- the monadic level - a test failing should be handled explicitly.
type TestM = ExceptT [T.Text] IO

data IRInterpreter = SOACSInterpreter | GPUInterpreter

interpreterOptions :: IRInterpreter -> String -> [String]
interpreterOptions :: IRInterpreter -> String -> [String]
interpreterOptions IRInterpreter
SOACSInterpreter String
entry =
  [String
"--run-soacs=" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
entry]
interpreterOptions IRInterpreter
GPUInterpreter String
entry =
  [String
"--gpu", String
"--run-gpu=" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
entry]

-- Taken from transformers-0.5.5.0.
eitherToErrors :: Either e a -> Errors e a
eitherToErrors :: forall e a. Either e a -> Errors e a
eitherToErrors = (e -> Errors e a) -> (a -> Errors e a) -> Either e a -> Errors e a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either e -> Errors e a
forall e a. e -> Errors e a
failure a -> Errors e a
forall (f :: * -> *) a. a -> Lift f a
Pure

throwError :: (MonadError [e] m) => e -> m a
throwError :: forall e (m :: * -> *) a. MonadError [e] m => e -> m a
throwError e
e = [e] -> m a
forall a. [e] -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
E.throwError [e
e]

runTestM :: TestM () -> IO TestResult
runTestM :: TestM () -> IO TestResult
runTestM = (Either [Text] () -> TestResult)
-> IO (Either [Text] ()) -> IO TestResult
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (([Text] -> TestResult)
-> (() -> TestResult) -> Either [Text] () -> TestResult
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either [Text] -> TestResult
Failure ((() -> TestResult) -> Either [Text] () -> TestResult)
-> (() -> TestResult) -> Either [Text] () -> TestResult
forall a b. (a -> b) -> a -> b
$ TestResult -> () -> TestResult
forall a b. a -> b -> a
const TestResult
Success) (IO (Either [Text] ()) -> IO TestResult)
-> (TestM () -> IO (Either [Text] ())) -> TestM () -> IO TestResult
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TestM () -> IO (Either [Text] ())
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT

liftExcept :: ExceptT T.Text IO a -> TestM a
liftExcept :: forall a. ExceptT Text IO a -> TestM a
liftExcept = (Text -> ExceptT [Text] IO a)
-> (a -> ExceptT [Text] IO a)
-> Either Text a
-> ExceptT [Text] IO a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ([Text] -> ExceptT [Text] IO a
forall a. [Text] -> ExceptT [Text] IO a
forall e (m :: * -> *) a. MonadError e m => e -> m a
E.throwError ([Text] -> ExceptT [Text] IO a)
-> (Text -> [Text]) -> Text -> ExceptT [Text] IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure) a -> ExceptT [Text] IO a
forall a. a -> ExceptT [Text] IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either Text a -> ExceptT [Text] IO a)
-> (ExceptT Text IO a -> ExceptT [Text] IO (Either Text a))
-> ExceptT Text IO a
-> ExceptT [Text] IO a
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< IO (Either Text a) -> ExceptT [Text] IO (Either Text a)
forall a. IO a -> ExceptT [Text] IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either Text a) -> ExceptT [Text] IO (Either Text a))
-> (ExceptT Text IO a -> IO (Either Text a))
-> ExceptT Text IO a
-> ExceptT [Text] IO (Either Text a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExceptT Text IO a -> IO (Either Text a)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT

context :: T.Text -> TestM a -> TestM a
context :: forall a. Text -> TestM a -> TestM a
context Text
s = ([Text] -> [Text]) -> ExceptT [Text] IO a -> ExceptT [Text] IO a
forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT (([Text] -> [Text]) -> ExceptT [Text] IO a -> ExceptT [Text] IO a)
-> ([Text] -> [Text]) -> ExceptT [Text] IO a -> ExceptT [Text] IO a
forall a b. (a -> b) -> a -> b
$
  \case
    [] -> []
    (Text
e : [Text]
es') -> (Text
s Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
":\n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
e) Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text]
es'

context1 :: (Monad m) => T.Text -> ExceptT T.Text m a -> ExceptT T.Text m a
context1 :: forall (m :: * -> *) a.
Monad m =>
Text -> ExceptT Text m a -> ExceptT Text m a
context1 Text
s = (Text -> Text) -> ExceptT Text m a -> ExceptT Text m a
forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT ((Text -> Text) -> ExceptT Text m a -> ExceptT Text m a)
-> (Text -> Text) -> ExceptT Text m a -> ExceptT Text m a
forall a b. (a -> b) -> a -> b
$ \Text
e -> Text
s Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
":\n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
e

accErrors :: [TestM a] -> TestM [a]
accErrors :: forall a. [TestM a] -> TestM [a]
accErrors [TestM a]
tests = do
  eithers <- IO [Either [Text] a] -> ExceptT [Text] IO [Either [Text] a]
forall (m :: * -> *) a. Monad m => m a -> ExceptT [Text] m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO [Either [Text] a] -> ExceptT [Text] IO [Either [Text] a])
-> IO [Either [Text] a] -> ExceptT [Text] IO [Either [Text] a]
forall a b. (a -> b) -> a -> b
$ (TestM a -> IO (Either [Text] a))
-> [TestM a] -> IO [Either [Text] a]
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 TestM a -> IO (Either [Text] a)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT [TestM a]
tests
  let errors = (Either [Text] a -> Lift (Constant [Text]) a)
-> [Either [Text] a] -> Lift (Constant [Text]) [a]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse Either [Text] a -> Lift (Constant [Text]) a
forall e a. Either e a -> Errors e a
eitherToErrors [Either [Text] a]
eithers
  ExceptT $ pure $ runErrors errors

accErrors_ :: [TestM a] -> TestM ()
accErrors_ :: forall a. [TestM a] -> TestM ()
accErrors_ = ExceptT [Text] IO [a] -> TestM ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ExceptT [Text] IO [a] -> TestM ())
-> ([TestM a] -> ExceptT [Text] IO [a]) -> [TestM a] -> TestM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [TestM a] -> ExceptT [Text] IO [a]
forall a. [TestM a] -> TestM [a]
accErrors

data TestResult
  = Success
  | Failure [T.Text]
  deriving (TestResult -> TestResult -> Bool
(TestResult -> TestResult -> Bool)
-> (TestResult -> TestResult -> Bool) -> Eq TestResult
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: TestResult -> TestResult -> Bool
== :: TestResult -> TestResult -> Bool
$c/= :: TestResult -> TestResult -> Bool
/= :: TestResult -> TestResult -> Bool
Eq, Int -> TestResult -> String -> String
[TestResult] -> String -> String
TestResult -> String
(Int -> TestResult -> String -> String)
-> (TestResult -> String)
-> ([TestResult] -> String -> String)
-> Show TestResult
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> TestResult -> String -> String
showsPrec :: Int -> TestResult -> String -> String
$cshow :: TestResult -> String
show :: TestResult -> String
$cshowList :: [TestResult] -> String -> String
showList :: [TestResult] -> String -> String
Show)

pureTestResults :: IO [TestResult] -> TestM ()
pureTestResults :: IO [TestResult] -> TestM ()
pureTestResults IO [TestResult]
m = do
  errs <- (TestResult -> [[Text]] -> [[Text]])
-> [[Text]] -> [TestResult] -> [[Text]]
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr TestResult -> [[Text]] -> [[Text]]
collectErrors [[Text]]
forall a. Monoid a => a
mempty ([TestResult] -> [[Text]])
-> ExceptT [Text] IO [TestResult] -> ExceptT [Text] IO [[Text]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO [TestResult] -> ExceptT [Text] IO [TestResult]
forall a. IO a -> ExceptT [Text] IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO [TestResult]
m
  unless (null errs) $ E.throwError $ concat errs
  where
    collectErrors :: TestResult -> [[Text]] -> [[Text]]
collectErrors TestResult
Success [[Text]]
errs = [[Text]]
errs
    collectErrors (Failure [Text]
err) [[Text]]
errs = [Text]
err [Text] -> [[Text]] -> [[Text]]
forall a. a -> [a] -> [a]
: [[Text]]
errs

-- | The longest we are willing to wait for a test, in microseconds.
timeout :: Int
timeout :: Int
timeout = Int
5 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
60 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1000000

withProgramServer :: FilePath -> FilePath -> [String] -> IORef PBTPhase -> (Server -> IO [TestResult]) -> TestM ()
withProgramServer :: String
-> String
-> [String]
-> IORef PBTPhase
-> (Server -> IO [TestResult])
-> TestM ()
withProgramServer String
program String
runner [String]
extra_options IORef PBTPhase
phaseRef Server -> IO [TestResult]
f = do
  -- Explicitly prefixing the current directory is necessary for
  -- readProcessWithExitCode to find the binary when binOutputf has
  -- no path component.
  let binOutputf :: String
binOutputf = String -> String
dropExtension String
program
      binpath :: String
binpath = String
"." String -> String -> String
</> String
binOutputf

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

      prog_ctx :: Text
prog_ctx =
        Text
"Running " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack ([String] -> String
unwords ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ String
binpath String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
extra_options)

  Text -> TestM () -> TestM ()
forall a. Text -> TestM a -> TestM a
context Text
prog_ctx (TestM () -> TestM ())
-> (IO [TestResult] -> TestM ()) -> IO [TestResult] -> TestM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO [TestResult] -> TestM ()
pureTestResults (IO [TestResult] -> TestM ())
-> (IO [TestResult] -> IO [TestResult])
-> IO [TestResult]
-> TestM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO [TestResult] -> IO [TestResult]
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [TestResult] -> TestM ()) -> IO [TestResult] -> TestM ()
forall a b. (a -> b) -> a -> b
$
    ServerCfg -> (Server -> IO [TestResult]) -> IO [TestResult]
forall a. ServerCfg -> (Server -> IO a) -> IO a
withServer (String -> [String] -> ServerCfg
futharkServerCfg String
to_run [String]
to_run_args) ((Server -> IO [TestResult]) -> IO [TestResult])
-> (Server -> IO [TestResult]) -> IO [TestResult]
forall a b. (a -> b) -> a -> b
$ \Server
server ->
      IO () -> IO [TestResult] -> IO (Either () [TestResult])
forall a b. IO a -> IO b -> IO (Either a b)
race (Int -> IO ()
threadDelay Int
timeout) (Server -> IO [TestResult]
f Server
server) IO (Either () [TestResult])
-> (Either () [TestResult] -> IO [TestResult]) -> IO [TestResult]
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Left ()
_ -> do
          Server -> IO ()
abortServer Server
server
          st <- IORef PBTPhase -> IO PBTPhase
forall a. IORef a -> IO a
readIORef IORef PBTPhase
phaseRef
          fail . T.unpack $
            "test timeout after " <> showText timeout <> " microseconds" <> case activeTest st of
              Maybe Text
Nothing -> Text
forall a. Monoid a => a
mempty
              Just Text
activeTestName -> do
                -- use annotate to make the phase name stand out in the error message, since it is the most likely place to find out what went wrong
                let phaseInfo :: Text
phaseInfo = Text -> (Text -> Text) -> Maybe Text -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
forall a. Monoid a => a
mempty (Text
" during phase " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>) (PBTPhase -> Maybe Text
phase PBTPhase
st)
                    shrinkInfo :: Text
shrinkInfo = Text -> (Text -> Text) -> Maybe Text -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
forall a. Monoid a => a
mempty (Text
" while shrinking with " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>) (PBTPhase -> Maybe Text
shrinkWith PBTPhase
st)
                    sizeInfo :: Text
sizeInfo = Text -> (Int64 -> Text) -> Maybe Int64 -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
forall a. Monoid a => a
mempty ((Text
" at size=" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>) (Text -> Text) -> (Int64 -> Text) -> Int64 -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int64 -> Text
forall a. Show a => a -> Text
showText) (PBTPhase -> Maybe Int64
phaseSize PBTPhase
st)
                    seedInfo :: Text
seedInfo = Text -> (Word64 -> Text) -> Maybe Word64 -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
forall a. Monoid a => a
mempty ((Text
" and seed=" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>) (Text -> Text) -> (Word64 -> Text) -> Word64 -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word64 -> Text
forall a. Show a => a -> Text
showText) (PBTPhase -> Maybe Word64
phaseSeed PBTPhase
st)
                    tacticInfo :: Text
tacticInfo = Text -> (Word64 -> Text) -> Maybe Word64 -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
forall a. Monoid a => a
mempty ((Text
" with tactic=" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>) (Text -> Text) -> (Word64 -> Text) -> Word64 -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word64 -> Text
forall a. Show a => a -> Text
showText) (PBTPhase -> Maybe Word64
phaseRandom PBTPhase
st)
                Text
". Was evaluating property:\n"
                  Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
activeTestName
                  Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
phaseInfo
                  Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
shrinkInfo
                  Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
sizeInfo
                  Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
seedInfo
                  Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
tacticInfo
        Right [TestResult]
r -> [TestResult] -> IO [TestResult]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [TestResult]
r

data TestMode
  = -- | Only type check.
    TypeCheck
  | -- | Only compile (do not run).
    Compile
  | -- | Only internalise (do not run).
    Internalise
  | -- | Test compiled code.
    Compiled
  | -- | Test interpreted code.
    Interpreted
  | -- | Test code interpreted after internalisation to SOACS.
    InterpretedSOACS
  | -- | Test code interpreted after internalisation to GPU IR
    InterpretedGPU
  | -- | Perform structure tests.
    Structure
  deriving (TestMode -> TestMode -> Bool
(TestMode -> TestMode -> Bool)
-> (TestMode -> TestMode -> Bool) -> Eq TestMode
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: TestMode -> TestMode -> Bool
== :: TestMode -> TestMode -> Bool
$c/= :: TestMode -> TestMode -> Bool
/= :: TestMode -> TestMode -> Bool
Eq, Int -> TestMode -> String -> String
[TestMode] -> String -> String
TestMode -> String
(Int -> TestMode -> String -> String)
-> (TestMode -> String)
-> ([TestMode] -> String -> String)
-> Show TestMode
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> TestMode -> String -> String
showsPrec :: Int -> TestMode -> String -> String
$cshow :: TestMode -> String
show :: TestMode -> String
$cshowList :: [TestMode] -> String -> String
showList :: [TestMode] -> String -> String
Show)

data TestCase = TestCase
  { TestCase -> TestMode
_testCaseMode :: TestMode,
    TestCase -> String
testCaseProgram :: FilePath,
    TestCase -> ProgramTest
testCaseTest :: ProgramTest,
    TestCase -> ProgConfig
_testCasePrograms :: ProgConfig,
    TestCase -> PBTConfig
pbtConfig :: PBTConfig
  }
  deriving (Int -> TestCase -> String -> String
[TestCase] -> String -> String
TestCase -> String
(Int -> TestCase -> String -> String)
-> (TestCase -> String)
-> ([TestCase] -> String -> String)
-> Show TestCase
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> TestCase -> String -> String
showsPrec :: Int -> TestCase -> String -> String
$cshow :: TestCase -> String
show :: TestCase -> String
$cshowList :: [TestCase] -> String -> String
showList :: [TestCase] -> String -> String
Show)

instance Eq TestCase where
  TestCase
x == :: TestCase -> TestCase -> Bool
== TestCase
y = TestCase -> String
testCaseProgram TestCase
x String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== TestCase -> String
testCaseProgram TestCase
y

instance Ord TestCase where
  TestCase
x compare :: TestCase -> TestCase -> Ordering
`compare` TestCase
y = TestCase -> String
testCaseProgram TestCase
x String -> String -> Ordering
forall a. Ord a => a -> a -> Ordering
`compare` TestCase -> String
testCaseProgram TestCase
y

data RunResult m
  = ErrorResult T.Text
  | SuccessResult (m [Value]) (m ())

progNotFound :: T.Text -> T.Text
progNotFound :: Text -> Text
progNotFound Text
s = Text
s Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": command not found"

optimisedProgramMetrics :: ProgConfig -> StructurePipeline -> FilePath -> TestM AstMetrics
optimisedProgramMetrics :: ProgConfig -> StructurePipeline -> String -> TestM AstMetrics
optimisedProgramMetrics ProgConfig
programs StructurePipeline
pipeline String
program =
  case StructurePipeline
pipeline of
    StructurePipeline
SOACSPipeline ->
      [String] -> TestM AstMetrics
forall {m :: * -> *} {b}.
(MonadIO m, Read b, MonadError [Text] m) =>
[String] -> m b
check [String
"-s"]
    StructurePipeline
GpuPipeline ->
      [String] -> TestM AstMetrics
forall {m :: * -> *} {b}.
(MonadIO m, Read b, MonadError [Text] m) =>
[String] -> m b
check [String
"--gpu"]
    StructurePipeline
MCPipeline ->
      [String] -> TestM AstMetrics
forall {m :: * -> *} {b}.
(MonadIO m, Read b, MonadError [Text] m) =>
[String] -> m b
check [String
"--mc"]
    StructurePipeline
SeqMemPipeline ->
      [String] -> TestM AstMetrics
forall {m :: * -> *} {b}.
(MonadIO m, Read b, MonadError [Text] m) =>
[String] -> m b
check [String
"--seq-mem"]
    StructurePipeline
GpuMemPipeline ->
      [String] -> TestM AstMetrics
forall {m :: * -> *} {b}.
(MonadIO m, Read b, MonadError [Text] m) =>
[String] -> m b
check [String
"--gpu-mem"]
    StructurePipeline
MCMemPipeline ->
      [String] -> TestM AstMetrics
forall {m :: * -> *} {b}.
(MonadIO m, Read b, MonadError [Text] m) =>
[String] -> m b
check [String
"--mc-mem"]
    StructurePipeline
NoPipeline ->
      [String] -> TestM AstMetrics
forall {m :: * -> *} {b}.
(MonadIO m, Read b, MonadError [Text] m) =>
[String] -> m b
check []
  where
    check :: [String] -> m b
check [String]
opt = do
      futhark <- IO String -> m String
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO String -> m String) -> IO String -> m String
forall a b. (a -> b) -> a -> b
$ IO String -> (String -> IO String) -> Maybe String -> IO String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe IO String
getExecutablePath String -> IO String
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe String -> IO String) -> Maybe String -> IO String
forall a b. (a -> b) -> a -> b
$ ProgConfig -> Maybe String
configFuthark ProgConfig
programs
      let opts = [String
"dev"] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
opt [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String
"--metrics", String
program]
      (code, output, err) <- liftIO $ readProcessWithExitCode futhark opts ""
      let output' = ByteString -> Text
T.decodeUtf8 ByteString
output
      case code of
        ExitCode
ExitSuccess
          | [(b
m, [])] <- ReadS b
forall a. Read a => ReadS a
reads ReadS b -> ReadS b
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
output' -> b -> m b
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure b
m
          | Bool
otherwise -> Text -> m b
forall e (m :: * -> *) a. MonadError [e] m => e -> m a
throwError (Text -> m b) -> Text -> m b
forall a b. (a -> b) -> a -> b
$ Text
"Could not read metrics output:\n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
output'
        ExitFailure Int
127 -> Text -> m b
forall e (m :: * -> *) a. MonadError [e] m => e -> m a
throwError (Text -> m b) -> Text -> m b
forall a b. (a -> b) -> a -> b
$ Text -> Text
progNotFound (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack String
futhark
        ExitFailure Int
_ -> Text -> m b
forall e (m :: * -> *) a. MonadError [e] m => e -> m a
throwError (Text -> m b) -> Text -> m b
forall a b. (a -> b) -> a -> b
$ ByteString -> Text
T.decodeUtf8 ByteString
err

testMetrics :: ProgConfig -> FilePath -> StructureTest -> TestM ()
testMetrics :: ProgConfig -> String -> StructureTest -> TestM ()
testMetrics ProgConfig
programs String
program (StructureTest StructurePipeline
pipeline (AstMetrics Map Text Int
expected)) =
  Text -> TestM () -> TestM ()
forall a. Text -> TestM a -> TestM a
context Text
"Checking metrics" (TestM () -> TestM ()) -> TestM () -> TestM ()
forall a b. (a -> b) -> a -> b
$ do
    actual <- ProgConfig -> StructurePipeline -> String -> TestM AstMetrics
optimisedProgramMetrics ProgConfig
programs StructurePipeline
pipeline String
program
    accErrors_ $ map (ok actual) $ M.toList expected
  where
    maybePipeline :: StructurePipeline -> T.Text
    maybePipeline :: StructurePipeline -> Text
maybePipeline StructurePipeline
SOACSPipeline = Text
"(soacs) "
    maybePipeline StructurePipeline
GpuPipeline = Text
"(gpu) "
    maybePipeline StructurePipeline
MCPipeline = Text
"(mc) "
    maybePipeline StructurePipeline
SeqMemPipeline = Text
"(seq-mem) "
    maybePipeline StructurePipeline
GpuMemPipeline = Text
"(gpu-mem) "
    maybePipeline StructurePipeline
MCMemPipeline = Text
"(mc-mem) "
    maybePipeline StructurePipeline
NoPipeline = Text
" "

    ok :: AstMetrics -> (Text, Int) -> m ()
ok (AstMetrics Map Text Int
metrics) (Text
name, Int
expected_occurences) =
      case Text -> Map Text Int -> Maybe Int
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Text
name Map Text Int
metrics of
        Maybe Int
Nothing
          | Int
expected_occurences Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 ->
              Text -> m ()
forall e (m :: * -> *) a. MonadError [e] m => e -> m a
throwError (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$
                Text
name
                  Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> StructurePipeline -> Text
maybePipeline StructurePipeline
pipeline
                  Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"should have occurred "
                  Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
showText Int
expected_occurences
                  Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" times, but did not occur at all in optimised program."
        Just Int
actual_occurences
          | Int
expected_occurences Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
actual_occurences ->
              Text -> m ()
forall e (m :: * -> *) a. MonadError [e] m => e -> m a
throwError (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$
                Text
name
                  Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> StructurePipeline -> Text
maybePipeline StructurePipeline
pipeline
                  Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"should have occurred "
                  Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
showText Int
expected_occurences
                  Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" times, but occurred "
                  Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
showText Int
actual_occurences
                  Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" times."
        Maybe Int
_ -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

testWarnings :: [WarningTest] -> SBS.ByteString -> TestM ()
testWarnings :: [WarningTest] -> ByteString -> TestM ()
testWarnings [WarningTest]
warnings ByteString
futerr = [TestM ()] -> TestM ()
forall a. [TestM a] -> TestM ()
accErrors_ ([TestM ()] -> TestM ()) -> [TestM ()] -> TestM ()
forall a b. (a -> b) -> a -> b
$ (WarningTest -> TestM ()) -> [WarningTest] -> [TestM ()]
forall a b. (a -> b) -> [a] -> [b]
map WarningTest -> TestM ()
forall {m :: * -> *}. MonadError [Text] m => WarningTest -> m ()
testWarning [WarningTest]
warnings
  where
    testWarning :: WarningTest -> m ()
testWarning (ExpectedWarning Text
regex_s Regex
regex)
      | Bool -> Bool
not (Regex -> String -> Bool
forall regex source target.
RegexContext regex source target =>
regex -> source -> target
match Regex
regex (String -> Bool) -> String -> Bool
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ ByteString -> Text
T.decodeUtf8 ByteString
futerr) =
          Text -> m ()
forall e (m :: * -> *) a. MonadError [e] m => e -> m a
throwError (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$
            Text
"Expected warning:\n  "
              Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
regex_s
              Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\nGot warnings:\n  "
              Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ByteString -> Text
T.decodeUtf8 ByteString
futerr
      | Bool
otherwise = () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

runInterpretedEntry :: FutharkExe -> FilePath -> InputOutputs -> TestM ()
runInterpretedEntry :: FutharkExe -> String -> InputOutputs -> TestM ()
runInterpretedEntry (FutharkExe String
futhark) String
program (InputOutputs Text
entry [TestRun]
run_cases) =
  let dir :: String
dir = String -> String
takeDirectory String
program
      runInterpretedCase :: TestRun -> TestM ()
runInterpretedCase run :: TestRun
run@(TestRun [Text]
_ Values
inputValues ExpectedResult Success
_ Int
index Text
_) =
        Bool -> TestM () -> TestM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ((Text -> Bool) -> [Text] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Text -> [Text] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` TestRun -> [Text]
runTags TestRun
run) [Text
"compiled", Text
"script"]) (TestM () -> TestM ()) -> TestM () -> TestM ()
forall a b. (a -> b) -> a -> b
$
          Text -> TestM () -> TestM ()
forall a. Text -> TestM a -> TestM a
context (Text
"Entry point: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
entry Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"; dataset: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> TestRun -> Text
runDescription TestRun
run) (TestM () -> TestM ()) -> TestM () -> TestM ()
forall a b. (a -> b) -> a -> b
$ do
            input <- [Text] -> Text
T.unlines ([Text] -> Text) -> ([Value] -> [Text]) -> [Value] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Value -> Text) -> [Value] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Value -> Text
valueText ([Value] -> Text)
-> ExceptT [Text] IO [Value] -> ExceptT [Text] IO Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FutharkExe -> String -> Values -> ExceptT [Text] IO [Value]
forall (m :: * -> *).
(MonadFail m, MonadIO m) =>
FutharkExe -> String -> Values -> m [Value]
getValues (String -> FutharkExe
FutharkExe String
futhark) String
dir Values
inputValues
            expectedResult' <- getExpectedResult (FutharkExe futhark) program entry run
            (code, output, err) <-
              liftIO $
                readProcessWithExitCode futhark ["run", "-e", T.unpack entry, program] $
                  T.encodeUtf8 input
            case code of
              ExitFailure Int
127 ->
                Text -> TestM ()
forall e (m :: * -> *) a. MonadError [e] m => e -> m a
throwError (Text -> TestM ()) -> Text -> TestM ()
forall a b. (a -> b) -> a -> b
$ Text -> Text
progNotFound (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack String
futhark
              ExitCode
_ ->
                ExceptT Text IO () -> TestM ()
forall a. ExceptT Text IO a -> TestM a
liftExcept (ExceptT Text IO () -> TestM ()) -> ExceptT Text IO () -> TestM ()
forall a b. (a -> b) -> a -> b
$
                  Text
-> Int
-> String
-> ExpectedResult [Value]
-> RunResult (ExceptT Text IO)
-> ExceptT Text IO ()
forall (m :: * -> *).
(MonadIO m, MonadError Text m) =>
Text
-> Int -> String -> ExpectedResult [Value] -> RunResult m -> m ()
compareResult Text
entry Int
index String
program ExpectedResult [Value]
expectedResult' (RunResult (ExceptT Text IO) -> ExceptT Text IO ())
-> RunResult (ExceptT Text IO) -> ExceptT Text IO ()
forall a b. (a -> b) -> a -> b
$
                    String
-> ExitCode
-> ByteString
-> ByteString
-> RunResult (ExceptT Text IO)
forall (m :: * -> *).
(MonadIO m, MonadError Text m) =>
String -> ExitCode -> ByteString -> ByteString -> RunResult m
runResult String
program ExitCode
code ByteString
output ByteString
err
   in [TestM ()] -> TestM ()
forall a. [TestM a] -> TestM ()
accErrors_ ([TestM ()] -> TestM ()) -> [TestM ()] -> TestM ()
forall a b. (a -> b) -> a -> b
$ (TestRun -> TestM ()) -> [TestRun] -> [TestM ()]
forall a b. (a -> b) -> [a] -> [b]
map TestRun -> TestM ()
runInterpretedCase [TestRun]
run_cases

runIRInterpretedEntry :: FutharkExe -> IRInterpreter -> FilePath -> InputOutputs -> TestM ()
runIRInterpretedEntry :: FutharkExe -> IRInterpreter -> String -> InputOutputs -> TestM ()
runIRInterpretedEntry (FutharkExe String
futhark) IRInterpreter
interpreter String
program (InputOutputs Text
entry [TestRun]
run_cases) =
  let dir :: String
dir = String -> String
takeDirectory String
program
      runInterpretedCase :: TestRun -> TestM ()
runInterpretedCase run :: TestRun
run@(TestRun [Text]
_ Values
inputValues ExpectedResult Success
_ Int
index Text
_) =
        Bool -> TestM () -> TestM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ((Text -> Bool) -> [Text] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Text -> [Text] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` TestRun -> [Text]
runTags TestRun
run) [Text
"compiled", Text
"script"]) (TestM () -> TestM ()) -> TestM () -> TestM ()
forall a b. (a -> b) -> a -> b
$
          Text -> TestM () -> TestM ()
forall a. Text -> TestM a -> TestM a
context (Text
"Entry point: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
entry Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"; dataset: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> TestRun -> Text
runDescription TestRun
run) (TestM () -> TestM ()) -> TestM () -> TestM ()
forall a b. (a -> b) -> a -> b
$ do
            input <- [Text] -> Text
T.unlines ([Text] -> Text) -> ([Value] -> [Text]) -> [Value] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Value -> Text) -> [Value] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Value -> Text
valueText ([Value] -> Text)
-> ExceptT [Text] IO [Value] -> ExceptT [Text] IO Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FutharkExe -> String -> Values -> ExceptT [Text] IO [Value]
forall (m :: * -> *).
(MonadFail m, MonadIO m) =>
FutharkExe -> String -> Values -> m [Value]
getValues (String -> FutharkExe
FutharkExe String
futhark) String
dir Values
inputValues
            expectedResult' <- getExpectedResult (FutharkExe futhark) program entry run
            (code, output, err) <-
              liftIO $
                readProcessWithExitCode
                  futhark
                  (["dev"] <> interpreterOptions interpreter (T.unpack entry) <> [program])
                  (T.encodeUtf8 input)
            case code of
              ExitFailure Int
127 ->
                Text -> TestM ()
forall e (m :: * -> *) a. MonadError [e] m => e -> m a
throwError (Text -> TestM ()) -> Text -> TestM ()
forall a b. (a -> b) -> a -> b
$ Text -> Text
progNotFound (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack String
futhark
              ExitCode
_ ->
                ExceptT Text IO () -> TestM ()
forall a. ExceptT Text IO a -> TestM a
liftExcept (ExceptT Text IO () -> TestM ()) -> ExceptT Text IO () -> TestM ()
forall a b. (a -> b) -> a -> b
$
                  Text
-> Int
-> String
-> ExpectedResult [Value]
-> RunResult (ExceptT Text IO)
-> ExceptT Text IO ()
forall (m :: * -> *).
(MonadIO m, MonadError Text m) =>
Text
-> Int -> String -> ExpectedResult [Value] -> RunResult m -> m ()
compareResult Text
entry Int
index String
program ExpectedResult [Value]
expectedResult' (RunResult (ExceptT Text IO) -> ExceptT Text IO ())
-> RunResult (ExceptT Text IO) -> ExceptT Text IO ()
forall a b. (a -> b) -> a -> b
$
                    String
-> ExitCode
-> ByteString
-> ByteString
-> RunResult (ExceptT Text IO)
forall (m :: * -> *).
(MonadIO m, MonadError Text m) =>
String -> ExitCode -> ByteString -> ByteString -> RunResult m
runResult String
program ExitCode
code ByteString
output ByteString
err
   in [TestM ()] -> TestM ()
forall a. [TestM a] -> TestM ()
accErrors_ ([TestM ()] -> TestM ()) -> [TestM ()] -> TestM ()
forall a b. (a -> b) -> a -> b
$ (TestRun -> TestM ()) -> [TestRun] -> [TestM ()]
forall a b. (a -> b) -> [a] -> [b]
map TestRun -> TestM ()
runInterpretedCase [TestRun]
run_cases

runTestCase :: TestCase -> TestM ()
runTestCase :: TestCase -> TestM ()
runTestCase (TestCase TestMode
mode String
program ProgramTest
testcase ProgConfig
progs PBTConfig
pbtConfig) = do
  futhark <- IO String -> ExceptT [Text] IO String
forall a. IO a -> ExceptT [Text] IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO String -> ExceptT [Text] IO String)
-> IO String -> ExceptT [Text] IO String
forall a b. (a -> b) -> a -> b
$ IO String -> (String -> IO String) -> Maybe String -> IO String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe IO String
getExecutablePath String -> IO String
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe String -> IO String) -> Maybe String -> IO String
forall a b. (a -> b) -> a -> b
$ ProgConfig -> Maybe String
configFuthark ProgConfig
progs
  let checkctx =
        [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat
          [ Text
"Type-checking with '",
            String -> Text
T.pack String
futhark,
            Text
" check ",
            String -> Text
T.pack String
program,
            Text
"'"
          ]
  case testAction testcase of
    CompileTimeFailure ExpectedError
expected_error ->
      Bool -> TestM () -> TestM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (TestMode
mode TestMode -> [TestMode] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [TestMode
Structure, TestMode
Internalise]) (TestM () -> TestM ())
-> (TestM () -> TestM ()) -> TestM () -> TestM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> TestM () -> TestM ()
forall a. Text -> TestM a -> TestM a
context Text
checkctx (TestM () -> TestM ()) -> TestM () -> TestM ()
forall a b. (a -> b) -> a -> b
$ do
        (code, _, err) <-
          IO (ExitCode, ByteString, ByteString)
-> ExceptT [Text] IO (ExitCode, ByteString, ByteString)
forall a. IO a -> ExceptT [Text] IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (ExitCode, ByteString, ByteString)
 -> ExceptT [Text] IO (ExitCode, ByteString, ByteString))
-> IO (ExitCode, ByteString, ByteString)
-> ExceptT [Text] IO (ExitCode, ByteString, ByteString)
forall a b. (a -> b) -> a -> b
$ String
-> [String] -> ByteString -> IO (ExitCode, ByteString, ByteString)
readProcessWithExitCode String
futhark [String
"check", String
program] ByteString
""
        case code of
          ExitCode
ExitSuccess -> Text -> TestM ()
forall e (m :: * -> *) a. MonadError [e] m => e -> m a
throwError Text
"Expected failure\n"
          ExitFailure Int
127 -> Text -> TestM ()
forall e (m :: * -> *) a. MonadError [e] m => e -> m a
throwError (Text -> TestM ()) -> Text -> TestM ()
forall a b. (a -> b) -> a -> b
$ Text -> Text
progNotFound (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack String
futhark
          ExitFailure Int
1 -> Text -> TestM ()
forall e (m :: * -> *) a. MonadError [e] m => e -> m a
throwError (Text -> TestM ()) -> Text -> TestM ()
forall a b. (a -> b) -> a -> b
$ ByteString -> Text
T.decodeUtf8 ByteString
err
          ExitFailure Int
_ -> ExceptT Text IO () -> TestM ()
forall a. ExceptT Text IO a -> TestM a
liftExcept (ExceptT Text IO () -> TestM ()) -> ExceptT Text IO () -> TestM ()
forall a b. (a -> b) -> a -> b
$ ExpectedError -> Text -> ExceptT Text IO ()
forall (m :: * -> *).
MonadError Text m =>
ExpectedError -> Text -> m ()
checkError ExpectedError
expected_error (Text -> ExceptT Text IO ()) -> Text -> ExceptT Text IO ()
forall a b. (a -> b) -> a -> b
$ ByteString -> Text
T.decodeUtf8 ByteString
err
    RunCases {}
      | TestMode
mode TestMode -> TestMode -> Bool
forall a. Eq a => a -> a -> Bool
== TestMode
TypeCheck -> do
          let options :: [String]
options = [String
"check", String
program] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ ProgConfig -> [String]
configExtraCompilerOptions ProgConfig
progs
          Text -> TestM () -> TestM ()
forall a. Text -> TestM a -> TestM a
context Text
checkctx (TestM () -> TestM ()) -> TestM () -> TestM ()
forall a b. (a -> b) -> a -> b
$ do
            (code, _, err) <- IO (ExitCode, ByteString, ByteString)
-> ExceptT [Text] IO (ExitCode, ByteString, ByteString)
forall a. IO a -> ExceptT [Text] IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (ExitCode, ByteString, ByteString)
 -> ExceptT [Text] IO (ExitCode, ByteString, ByteString))
-> IO (ExitCode, ByteString, ByteString)
-> ExceptT [Text] IO (ExitCode, ByteString, ByteString)
forall a b. (a -> b) -> a -> b
$ String
-> [String] -> ByteString -> IO (ExitCode, ByteString, ByteString)
readProcessWithExitCode String
futhark [String]
options ByteString
""
            case code of
              ExitCode
ExitSuccess -> () -> TestM ()
forall a. a -> ExceptT [Text] IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
              ExitFailure Int
127 -> Text -> TestM ()
forall e (m :: * -> *) a. MonadError [e] m => e -> m a
throwError (Text -> TestM ()) -> Text -> TestM ()
forall a b. (a -> b) -> a -> b
$ Text -> Text
progNotFound (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack String
futhark
              ExitFailure Int
_ -> Text -> TestM ()
forall e (m :: * -> *) a. MonadError [e] m => e -> m a
throwError (Text -> TestM ()) -> Text -> TestM ()
forall a b. (a -> b) -> a -> b
$ ByteString -> Text
T.decodeUtf8 ByteString
err
      | TestMode
mode TestMode -> TestMode -> Bool
forall a. Eq a => a -> a -> Bool
== TestMode
Internalise -> do
          let options :: [String]
options = [String
"dev", String
program] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ ProgConfig -> [String]
configExtraCompilerOptions ProgConfig
progs
          Text -> TestM () -> TestM ()
forall a. Text -> TestM a -> TestM a
context Text
checkctx (TestM () -> TestM ()) -> TestM () -> TestM ()
forall a b. (a -> b) -> a -> b
$ do
            (code, _, err) <- IO (ExitCode, ByteString, ByteString)
-> ExceptT [Text] IO (ExitCode, ByteString, ByteString)
forall a. IO a -> ExceptT [Text] IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (ExitCode, ByteString, ByteString)
 -> ExceptT [Text] IO (ExitCode, ByteString, ByteString))
-> IO (ExitCode, ByteString, ByteString)
-> ExceptT [Text] IO (ExitCode, ByteString, ByteString)
forall a b. (a -> b) -> a -> b
$ String
-> [String] -> ByteString -> IO (ExitCode, ByteString, ByteString)
readProcessWithExitCode String
futhark [String]
options ByteString
""
            case code of
              ExitCode
ExitSuccess -> () -> TestM ()
forall a. a -> ExceptT [Text] IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
              ExitFailure Int
127 -> Text -> TestM ()
forall e (m :: * -> *) a. MonadError [e] m => e -> m a
throwError (Text -> TestM ()) -> Text -> TestM ()
forall a b. (a -> b) -> a -> b
$ Text -> Text
progNotFound (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack String
futhark
              ExitFailure Int
_ -> Text -> TestM ()
forall e (m :: * -> *) a. MonadError [e] m => e -> m a
throwError (Text -> TestM ()) -> Text -> TestM ()
forall a b. (a -> b) -> a -> b
$ ByteString -> Text
T.decodeUtf8 ByteString
err
    RunCases [InputOutputs]
ios [StructureTest]
structures [WarningTest]
warnings [PropertyCase]
properties -> do
      -- Compile up-front and reuse same executable for several entry points.
      let backend :: String
backend = ProgConfig -> String
configBackend ProgConfig
progs
          extra_compiler_options :: [String]
extra_compiler_options = ProgConfig -> [String]
configExtraCompilerOptions ProgConfig
progs

      phaseRef <-
        IO (IORef PBTPhase) -> ExceptT [Text] IO (IORef PBTPhase)
forall a. IO a -> ExceptT [Text] IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (IORef PBTPhase) -> ExceptT [Text] IO (IORef PBTPhase))
-> (PBTPhase -> IO (IORef PBTPhase))
-> PBTPhase
-> ExceptT [Text] IO (IORef PBTPhase)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PBTPhase -> IO (IORef PBTPhase)
forall a. a -> IO (IORef a)
newIORef (PBTPhase -> ExceptT [Text] IO (IORef PBTPhase))
-> PBTPhase -> ExceptT [Text] IO (IORef PBTPhase)
forall a b. (a -> b) -> a -> b
$
          PBTPhase
            { activeTest :: Maybe Text
activeTest = Maybe Text
forall a. Maybe a
Nothing,
              phase :: Maybe Text
phase = Maybe Text
forall a. Maybe a
Nothing,
              shrinkWith :: Maybe Text
shrinkWith = Maybe Text
forall a. Maybe a
Nothing,
              phaseSize :: Maybe Int64
phaseSize = Maybe Int64
forall a. Maybe a
Nothing,
              phaseSeed :: Maybe Word64
phaseSeed = Maybe Word64
forall a. Maybe a
Nothing,
              phaseRandom :: Maybe Word64
phaseRandom = Maybe Word64
forall a. Maybe a
Nothing
            }

      when (mode `elem` [Compiled, Interpreted, InterpretedSOACS, InterpretedGPU]) $
        context "Generating reference outputs" $
          -- We probably get the concurrency at the test program level,
          -- so force just one data set at a time here.
          withExceptT pure $
            ensureReferenceOutput (Just 1) (FutharkExe futhark) "c" program ios

      when (mode == Structure) $
        mapM_ (testMetrics progs program) structures

      when (mode `elem` [Compile, Compiled]) $
        context ("Compiling with --backend=" <> T.pack backend) $ do
          compileTestProgram extra_compiler_options (FutharkExe futhark) backend program warnings
          unless (mode == Compile) $ do
            (tuning_opts, _) <-
              liftIO $ determineTuning (configTuning progs) program
            let extra_options =
                  Maybe String -> String -> [String]
determineCache (ProgConfig -> Maybe String
configCacheExt ProgConfig
progs) String
program
                    [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
tuning_opts
                    [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ ProgConfig -> [String]
configExtraOptions ProgConfig
progs
                runner = ProgConfig -> String
configRunner ProgConfig
progs
            context "Running compiled program" $
              withProgramServer program runner extra_options phaseRef $ \Server
server -> do
                let run :: InputOutputs -> IO [TestResult]
run = FutharkExe -> Server -> String -> InputOutputs -> IO [TestResult]
runCompiledEntry (String -> FutharkExe
FutharkExe String
futhark) Server
server String
program
                IO (Either Text [PropSpec]) -> IO (Either Text [PropSpec])
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Server -> [Text] -> IO (Either Text [PropSpec])
extractPropSpecs Server
server ((PropertyCase -> Text) -> [PropertyCase] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map PropertyCase -> Text
propertyEntryPoint [PropertyCase]
properties)) IO (Either Text [PropSpec])
-> (Either Text [PropSpec] -> IO [TestResult]) -> IO [TestResult]
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                  Left Text
err -> [TestResult] -> IO [TestResult]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [[Text] -> TestResult
Failure [Text
err]]
                  Right [PropSpec]
propSpecs -> IO [TestResult] -> IO [TestResult]
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [TestResult] -> IO [TestResult])
-> IO [TestResult] -> IO [TestResult]
forall a b. (a -> b) -> a -> b
$ do
                    normal_test_result <- [[TestResult]] -> [TestResult]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[TestResult]] -> [TestResult])
-> IO [[TestResult]] -> IO [TestResult]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (InputOutputs -> IO [TestResult])
-> [InputOutputs] -> IO [[TestResult]]
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 InputOutputs -> IO [TestResult]
run [InputOutputs]
ios

                    let verifiedProps = [PropertyCase] -> [PropSpec] -> [PropSpec]
selectRequestedPropSpecs [PropertyCase]
properties [PropSpec]
propSpecs
                    pbt_resultE <- runPBT pbtConfig server verifiedProps phaseRef program

                    let allResults = ((Either Text (Maybe Text) -> TestResult)
 -> [Either Text (Maybe Text)] -> [TestResult])
-> [Either Text (Maybe Text)]
-> (Either Text (Maybe Text) -> TestResult)
-> [TestResult]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Either Text (Maybe Text) -> TestResult)
-> [Either Text (Maybe Text)] -> [TestResult]
forall a b. (a -> b) -> [a] -> [b]
map [Either Text (Maybe Text)]
pbt_resultE ((Either Text (Maybe Text) -> TestResult) -> [TestResult])
-> (Either Text (Maybe Text) -> TestResult) -> [TestResult]
forall a b. (a -> b) -> a -> b
$ \case
                          Left Text
err -> [Text] -> TestResult
Failure [Text
err]
                          Right (Just Text
e) -> [Text] -> TestResult
Failure [Text
e]
                          Right Maybe Text
Nothing -> TestResult
Success

                    let hasFailures = (TestResult -> Bool) -> [TestResult] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\case Failure [Text]
_ -> Bool
True; TestResult
_ -> Bool
False) [TestResult]
allResults

                    when hasFailures $
                      liftIO $
                        propToFile program allResults

                    pure $ normal_test_result ++ allResults

      when (mode == Interpreted) $
        context "Interpreting" $
          accErrors_ $
            map (runInterpretedEntry (FutharkExe futhark) program) ios

      when (mode == InterpretedSOACS) $
        context "Interpreting SOACS" $
          accErrors_ $
            map (runIRInterpretedEntry (FutharkExe futhark) SOACSInterpreter program) ios

      when (mode == InterpretedGPU) $
        context "Interpreting GPU IR" $
          accErrors_ $
            map (runIRInterpretedEntry (FutharkExe futhark) GPUInterpreter program) ios

liftCommand ::
  (MonadError T.Text m, MonadIO m) =>
  IO (Maybe CmdFailure) ->
  m ()
liftCommand :: forall (m :: * -> *).
(MonadError Text m, MonadIO m) =>
IO (Maybe CmdFailure) -> m ()
liftCommand IO (Maybe CmdFailure)
m = do
  r <- IO (Maybe CmdFailure) -> m (Maybe CmdFailure)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO (Maybe CmdFailure)
m
  case r of
    Just (CmdFailure [Text]
_ [Text]
err) -> Text -> m ()
forall a. Text -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
E.throwError (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.unlines [Text]
err
    Maybe CmdFailure
Nothing -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

runCompiledEntry :: FutharkExe -> Server -> FilePath -> InputOutputs -> IO [TestResult]
runCompiledEntry :: FutharkExe -> Server -> String -> InputOutputs -> IO [TestResult]
runCompiledEntry FutharkExe
futhark Server
server String
program (InputOutputs Text
entry [TestRun]
run_cases) = do
  input_types <- Server -> Text -> IO (Either CmdFailure [InputType])
cmdInputs Server
server Text
entry
  output_type <- fmap outputType <$> cmdOutput server entry
  case (,) <$> input_types <*> output_type of
    Left (CmdFailure [Text]
_ [Text]
err) ->
      [TestResult] -> IO [TestResult]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [[Text] -> TestResult
Failure [Text]
err]
    Right ([InputType]
input_types', Text
out_t) -> do
      let out :: Text
out = Text
"out"
          ins :: [Text]
ins = [Text
"in" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
showText Int
i | Int
i <- [Int
0 .. [InputType] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [InputType]
input_types' Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1]]
          onRes :: Either Text b -> TestResult
onRes = (Text -> TestResult)
-> (b -> TestResult) -> Either Text b -> TestResult
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ([Text] -> TestResult
Failure ([Text] -> TestResult) -> (Text -> [Text]) -> Text -> TestResult
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure) (TestResult -> b -> TestResult
forall a b. a -> b -> a
const TestResult
Success)
      (TestRun -> IO TestResult) -> [TestRun] -> IO [TestResult]
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 ((Either Text () -> TestResult)
-> IO (Either Text ()) -> IO TestResult
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Either Text () -> TestResult
forall {b}. Either Text b -> TestResult
onRes (IO (Either Text ()) -> IO TestResult)
-> (TestRun -> IO (Either Text ())) -> TestRun -> IO TestResult
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [InputType]
-> (Text, Text) -> [Text] -> TestRun -> IO (Either Text ())
forall {m :: * -> *}.
(MonadFail m, MonadIO m) =>
[InputType]
-> (Text, Text) -> [Text] -> TestRun -> m (Either Text ())
runCompiledCase [InputType]
input_types' (Text
out, Text
out_t) [Text]
ins) [TestRun]
run_cases
  where
    runCompiledCase :: [InputType]
-> (Text, Text) -> [Text] -> TestRun -> m (Either Text ())
runCompiledCase [InputType]
input_types (Text
out, Text
out_t) [Text]
ins TestRun
run = ExceptT Text m () -> m (Either Text ())
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT Text m () -> m (Either Text ()))
-> ExceptT Text m () -> m (Either Text ())
forall a b. (a -> b) -> a -> b
$ do
      let TestRun [Text]
_ Values
input_spec ExpectedResult Success
_ Int
index Text
_ = TestRun
run
          case_ctx :: Text
case_ctx =
            Text
"Entry point: "
              Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
entry
              Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"; dataset: "
              Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> TestRun -> Text
runDescription TestRun
run

      Text -> ExceptT Text m () -> ExceptT Text m ()
forall (m :: * -> *) a.
Monad m =>
Text -> ExceptT Text m a -> ExceptT Text m a
context1 Text
case_ctx (ExceptT Text m () -> ExceptT Text m ())
-> ExceptT Text m () -> ExceptT Text m ()
forall a b. (a -> b) -> a -> b
$ do
        expected <- FutharkExe
-> String
-> Text
-> TestRun
-> ExceptT Text m (ExpectedResult [Value])
forall (m :: * -> *).
(MonadFail m, MonadIO m) =>
FutharkExe
-> String -> Text -> TestRun -> m (ExpectedResult [Value])
getExpectedResult FutharkExe
futhark String
program Text
entry TestRun
run

        ins' <- valuesAsVars server entry (zip ins (map inputType input_types)) futhark program input_spec

        call_r <- liftIO $ cmdCall server entry out ins'
        liftCommand $ cmdFree server $ nubOrd ins'

        let res = case Either CmdFailure [Text]
call_r of
              Left (CmdFailure [Text]
_ [Text]
err) ->
                Text -> RunResult (ExceptT Text m)
forall (m :: * -> *). Text -> RunResult m
ErrorResult (Text -> RunResult (ExceptT Text m))
-> Text -> RunResult (ExceptT Text m)
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.unlines [Text]
err
              Right [Text]
_ ->
                ExceptT Text m [Value]
-> ExceptT Text m () -> RunResult (ExceptT Text m)
forall (m :: * -> *). m [Value] -> m () -> RunResult m
SuccessResult
                  (Server -> (Text, Text) -> ExceptT Text m [Value]
forall (m :: * -> *).
(MonadIO m, MonadError Text m) =>
Server -> (Text, Text) -> m [Value]
readResults Server
server (Text
out, Text
out_t) ExceptT Text m [Value]
-> ExceptT Text m () -> ExceptT Text m [Value]
forall a b.
ExceptT Text m a -> ExceptT Text m b -> ExceptT Text m a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* IO (Maybe CmdFailure) -> ExceptT Text m ()
forall (m :: * -> *).
(MonadError Text m, MonadIO m) =>
IO (Maybe CmdFailure) -> m ()
liftCommand (Server -> [Text] -> IO (Maybe CmdFailure)
cmdFree Server
server [Text
out]))
                  (IO (Maybe CmdFailure) -> ExceptT Text m ()
forall (m :: * -> *).
(MonadError Text m, MonadIO m) =>
IO (Maybe CmdFailure) -> m ()
liftCommand (Server -> [Text] -> IO (Maybe CmdFailure)
cmdFree Server
server [Text
out]))

        compareResult entry index program expected res

checkError :: (MonadError T.Text m) => ExpectedError -> T.Text -> m ()
checkError :: forall (m :: * -> *).
MonadError Text m =>
ExpectedError -> Text -> m ()
checkError (ThisError Text
regex_s Regex
regex) Text
err
  | Bool -> Bool
not (Regex -> String -> Bool
forall regex source target.
RegexContext regex source target =>
regex -> source -> target
match Regex
regex (String -> Bool) -> String -> Bool
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
err) =
      Text -> m ()
forall a. Text -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
E.throwError (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$
        Text
"Expected error:\n  "
          Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
regex_s
          Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\nGot error:\n"
          Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
T.unlines ((Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Text
"  " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>) (Text -> [Text]
T.lines Text
err))
checkError ExpectedError
_ Text
_ =
  () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

runResult ::
  (MonadIO m, MonadError T.Text m) =>
  FilePath ->
  ExitCode ->
  SBS.ByteString ->
  SBS.ByteString ->
  RunResult m
runResult :: forall (m :: * -> *).
(MonadIO m, MonadError Text m) =>
String -> ExitCode -> ByteString -> ByteString -> RunResult m
runResult String
program ExitCode
ExitSuccess ByteString
stdout_s ByteString
_ =
  m [Value] -> m () -> RunResult m
forall (m :: * -> *). m [Value] -> m () -> RunResult m
SuccessResult m [Value]
fetch (() -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
  where
    fetch :: m [Value]
fetch = case String -> ByteString -> Either String [Value]
valuesFromByteString String
"stdout" (ByteString -> Either String [Value])
-> ByteString -> Either String [Value]
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
LBS.fromStrict ByteString
stdout_s of
      Left String
e -> do
        let actualf :: String
actualf = String
program String -> String -> String
`addExtension` String
"actual"
        IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ String -> ByteString -> IO ()
SBS.writeFile String
actualf ByteString
stdout_s
        Text -> m [Value]
forall a. Text -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
E.throwError (Text -> m [Value]) -> Text -> m [Value]
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack String
e Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\n(See " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack String
actualf Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")"
      Right [Value]
vs -> [Value] -> m [Value]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Value]
vs
runResult String
_ (ExitFailure Int
_) ByteString
_ ByteString
stderr_s =
  Text -> RunResult m
forall (m :: * -> *). Text -> RunResult m
ErrorResult (Text -> RunResult m) -> Text -> RunResult m
forall a b. (a -> b) -> a -> b
$ ByteString -> Text
T.decodeUtf8 ByteString
stderr_s

compileTestProgram :: [String] -> FutharkExe -> String -> FilePath -> [WarningTest] -> TestM ()
compileTestProgram :: [String]
-> FutharkExe -> String -> String -> [WarningTest] -> TestM ()
compileTestProgram [String]
extra_options FutharkExe
futhark String
backend String
program [WarningTest]
warnings = do
  (_, futerr) <-
    (Text -> [Text])
-> ExceptT Text IO (ByteString, ByteString)
-> ExceptT [Text] IO (ByteString, ByteString)
forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT Text -> [Text]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ExceptT Text IO (ByteString, ByteString)
 -> ExceptT [Text] IO (ByteString, ByteString))
-> ExceptT Text IO (ByteString, ByteString)
-> ExceptT [Text] IO (ByteString, ByteString)
forall a b. (a -> b) -> a -> b
$
      [String]
-> FutharkExe
-> String
-> String
-> ExceptT Text IO (ByteString, ByteString)
forall (m :: * -> *).
(MonadIO m, MonadError Text m) =>
[String]
-> FutharkExe -> String -> String -> m (ByteString, ByteString)
compileProgram (String
"--server" String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
extra_options) FutharkExe
futhark String
backend String
program
  testWarnings warnings futerr

compareResult ::
  (MonadIO m, MonadError T.Text m) =>
  T.Text ->
  Int ->
  FilePath ->
  ExpectedResult [Value] ->
  RunResult m ->
  m ()
compareResult :: forall (m :: * -> *).
(MonadIO m, MonadError Text m) =>
Text
-> Int -> String -> ExpectedResult [Value] -> RunResult m -> m ()
compareResult Text
_ Int
_ String
_ (Succeeds Maybe [Value]
Nothing) (SuccessResult m [Value]
_ m ()
free_vs) =
  m ()
free_vs
compareResult Text
entry Int
index String
program (Succeeds (Just [Value]
expected_vs)) (SuccessResult m [Value]
get_actual_vs m ()
_) = do
  actual_vs <- m [Value]
get_actual_vs
  checkResult
    (program <.> T.unpack entry <.> show index)
    expected_vs
    actual_vs
compareResult Text
_ Int
_ String
_ (RunTimeFailure ExpectedError
expectedError) (ErrorResult Text
actualError) =
  ExpectedError -> Text -> m ()
forall (m :: * -> *).
MonadError Text m =>
ExpectedError -> Text -> m ()
checkError ExpectedError
expectedError Text
actualError
compareResult Text
_ Int
_ String
_ (Succeeds Maybe [Value]
_) (ErrorResult Text
err) =
  Text -> m ()
forall a. Text -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
E.throwError (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Text
"Function failed with error:\n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
err
compareResult Text
_ Int
_ String
_ (RunTimeFailure ExpectedError
f) (SuccessResult m [Value]
_ m ()
free_vs) = do
  m ()
free_vs
  Text -> m ()
forall a. Text -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
E.throwError (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Text
"Program succeeded, but expected failure:\n  " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ExpectedError -> Text
forall a. Show a => a -> Text
showText ExpectedError
f

---
--- Test manager
---

data TestStatus = TestStatus
  { TestStatus -> [TestCase]
testStatusRemain :: [TestCase],
    TestStatus -> [TestCase]
testStatusRun :: [TestCase],
    TestStatus -> Int
testStatusTotal :: Int,
    TestStatus -> Int
testStatusFail :: Int,
    TestStatus -> Int
testStatusPass :: Int,
    TestStatus -> Int
testStatusRuns :: Int,
    TestStatus -> Int
testStatusRunsRemain :: Int,
    TestStatus -> Int
testStatusRunPass :: Int,
    TestStatus -> Int
testStatusRunFail :: Int
  }

catching :: IO TestResult -> IO TestResult
catching :: IO TestResult -> IO TestResult
catching IO TestResult
m = IO TestResult
m IO TestResult -> (SomeException -> IO TestResult) -> IO TestResult
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` SomeException -> IO TestResult
save
  where
    save :: SomeException -> IO TestResult
    save :: SomeException -> IO TestResult
save SomeException
e = TestResult -> IO TestResult
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TestResult -> IO TestResult) -> TestResult -> IO TestResult
forall a b. (a -> b) -> a -> b
$ [Text] -> TestResult
Failure [SomeException -> Text
forall a. Show a => a -> Text
showText SomeException
e]

doTest :: TestCase -> IO TestResult
doTest :: TestCase -> IO TestResult
doTest = IO TestResult -> IO TestResult
catching (IO TestResult -> IO TestResult)
-> (TestCase -> IO TestResult) -> TestCase -> IO TestResult
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TestM () -> IO TestResult
runTestM (TestM () -> IO TestResult)
-> (TestCase -> TestM ()) -> TestCase -> IO TestResult
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TestCase -> TestM ()
runTestCase

makeTestCase :: TestConfig -> TestMode -> (FilePath, ProgramTest) -> TestCase
makeTestCase :: TestConfig -> TestMode -> (String, ProgramTest) -> TestCase
makeTestCase TestConfig
config TestMode
mode (String
file, ProgramTest
spec) =
  TestConfig -> TestCase -> TestCase
excludeCases TestConfig
config (TestCase -> TestCase) -> TestCase -> TestCase
forall a b. (a -> b) -> a -> b
$ TestMode
-> String -> ProgramTest -> ProgConfig -> PBTConfig -> TestCase
TestCase TestMode
mode String
file ProgramTest
spec (TestConfig -> ProgConfig
configPrograms TestConfig
config) (TestConfig -> PBTConfig
configPBTConfig TestConfig
config)

data ReportMsg
  = TestStarted TestCase
  | TestDone TestCase TestResult

runTest :: MVar TestCase -> MVar ReportMsg -> IO ()
runTest :: MVar TestCase -> MVar ReportMsg -> IO ()
runTest MVar TestCase
testmvar MVar ReportMsg
resmvar = IO () -> IO ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
  test <- MVar TestCase -> IO TestCase
forall a. MVar a -> IO a
takeMVar MVar TestCase
testmvar
  putMVar resmvar $ TestStarted test
  res <- doTest test
  putMVar resmvar $ TestDone test res

excludedTest :: TestConfig -> TestCase -> Bool
excludedTest :: TestConfig -> TestCase -> Bool
excludedTest TestConfig
config =
  (Text -> Bool) -> [Text] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Text -> [Text] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` TestConfig -> [Text]
configExclude TestConfig
config) ([Text] -> Bool) -> (TestCase -> [Text]) -> TestCase -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ProgramTest -> [Text]
testTags (ProgramTest -> [Text])
-> (TestCase -> ProgramTest) -> TestCase -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TestCase -> ProgramTest
testCaseTest

-- | Exclude those test cases that have tags we do not wish to run or
-- exclude based on entry point name.
excludeCases :: TestConfig -> TestCase -> TestCase
excludeCases :: TestConfig -> TestCase -> TestCase
excludeCases TestConfig
config TestCase
tcase =
  TestCase
tcase {testCaseTest = onTest $ testCaseTest tcase}
  where
    onTest :: ProgramTest -> ProgramTest
onTest (ProgramTest Text
desc [Text]
tags TestAction
action) =
      Text -> [Text] -> TestAction -> ProgramTest
ProgramTest Text
desc [Text]
tags (TestAction -> ProgramTest) -> TestAction -> ProgramTest
forall a b. (a -> b) -> a -> b
$ TestAction -> TestAction
onAction TestAction
action
    onAction :: TestAction -> TestAction
onAction (RunCases [InputOutputs]
ios [StructureTest]
stest [WarningTest]
wtest [PropertyCase]
properties) =
      [InputOutputs]
-> [StructureTest] -> [WarningTest] -> [PropertyCase] -> TestAction
RunCases ((InputOutputs -> InputOutputs) -> [InputOutputs] -> [InputOutputs]
forall a b. (a -> b) -> [a] -> [b]
map InputOutputs -> InputOutputs
onIOs ([InputOutputs] -> [InputOutputs])
-> [InputOutputs] -> [InputOutputs]
forall a b. (a -> b) -> a -> b
$ (InputOutputs -> Bool) -> [InputOutputs] -> [InputOutputs]
forall a. (a -> Bool) -> [a] -> [a]
filter InputOutputs -> Bool
relevantEntry [InputOutputs]
ios) [StructureTest]
stest [WarningTest]
wtest [PropertyCase]
properties
    onAction TestAction
action = TestAction
action
    onIOs :: InputOutputs -> InputOutputs
onIOs (InputOutputs Text
entry [TestRun]
runs) =
      Text -> [TestRun] -> InputOutputs
InputOutputs Text
entry ([TestRun] -> InputOutputs) -> [TestRun] -> InputOutputs
forall a b. (a -> b) -> a -> b
$ (TestRun -> Bool) -> [TestRun] -> [TestRun]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (TestRun -> Bool) -> TestRun -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Bool) -> [Text] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Text -> Bool
excluded ([Text] -> Bool) -> (TestRun -> [Text]) -> TestRun -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TestRun -> [Text]
runTags) [TestRun]
runs
    relevantEntry :: InputOutputs -> Bool
relevantEntry (InputOutputs Text
entry [TestRun]
_) =
      Bool -> (String -> Bool) -> Maybe String -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True (String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== Text -> String
T.unpack Text
entry) (TestConfig -> Maybe String
configEntryPoint TestConfig
config)
    excluded :: Text -> Bool
excluded = (Text -> [Text] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` TestConfig -> [Text]
configExclude TestConfig
config)

putStatusTable :: TestStatus -> IO ()
putStatusTable :: TestStatus -> IO ()
putStatusTable TestStatus
ts = Handle -> [[Entry]] -> Int -> IO ()
hPutTable Handle
stdout [[Entry]]
rows Int
1
  where
    rows :: [[Entry]]
rows =
      [ [String -> AnsiStyle -> Entry
mkEntry String
"" AnsiStyle
forall a. Monoid a => a
mempty, Entry
passed, Entry
failed, String -> AnsiStyle -> Entry
mkEntry String
"remaining" AnsiStyle
forall a. Monoid a => a
mempty],
        (String -> Entry) -> [String] -> [Entry]
forall a b. (a -> b) -> [a] -> [b]
map (String -> AnsiStyle -> Entry
`mkEntry` AnsiStyle
forall a. Monoid a => a
mempty) [String
"programs", String
passedProgs, String
failedProgs, String
remainProgs'],
        (String -> Entry) -> [String] -> [Entry]
forall a b. (a -> b) -> [a] -> [b]
map (String -> AnsiStyle -> Entry
`mkEntry` AnsiStyle
forall a. Monoid a => a
mempty) [String
"runs", String
passedRuns, String
failedRuns, String
remainRuns']
      ]
    passed :: Entry
passed = String -> AnsiStyle -> Entry
mkEntry String
"passed" (AnsiStyle -> Entry) -> AnsiStyle -> Entry
forall a b. (a -> b) -> a -> b
$ Color -> AnsiStyle
color Color
Green
    failed :: Entry
failed = String -> AnsiStyle -> Entry
mkEntry String
"failed" (AnsiStyle -> Entry) -> AnsiStyle -> Entry
forall a b. (a -> b) -> a -> b
$ Color -> AnsiStyle
color Color
Red
    passedProgs :: String
passedProgs = Int -> String
forall a. Show a => a -> String
show (Int -> String) -> Int -> String
forall a b. (a -> b) -> a -> b
$ TestStatus -> Int
testStatusPass TestStatus
ts
    failedProgs :: String
failedProgs = Int -> String
forall a. Show a => a -> String
show (Int -> String) -> Int -> String
forall a b. (a -> b) -> a -> b
$ TestStatus -> Int
testStatusFail TestStatus
ts
    totalProgs :: String
totalProgs = Int -> String
forall a. Show a => a -> String
show (Int -> String) -> Int -> String
forall a b. (a -> b) -> a -> b
$ TestStatus -> Int
testStatusTotal TestStatus
ts
    totalRuns :: String
totalRuns = Int -> String
forall a. Show a => a -> String
show (Int -> String) -> Int -> String
forall a b. (a -> b) -> a -> b
$ TestStatus -> Int
testStatusRuns TestStatus
ts
    passedRuns :: String
passedRuns = Int -> String
forall a. Show a => a -> String
show (Int -> String) -> Int -> String
forall a b. (a -> b) -> a -> b
$ TestStatus -> Int
testStatusRunPass TestStatus
ts
    failedRuns :: String
failedRuns = Int -> String
forall a. Show a => a -> String
show (Int -> String) -> Int -> String
forall a b. (a -> b) -> a -> b
$ TestStatus -> Int
testStatusRunFail TestStatus
ts
    remainProgs :: String
remainProgs = Int -> String
forall a. Show a => a -> String
show (Int -> String) -> ([TestCase] -> Int) -> [TestCase] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [TestCase] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([TestCase] -> String) -> [TestCase] -> String
forall a b. (a -> b) -> a -> b
$ TestStatus -> [TestCase]
testStatusRemain TestStatus
ts
    remainProgs' :: String
remainProgs' = String
remainProgs String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"/" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
totalProgs
    remainRuns :: String
remainRuns = Int -> String
forall a. Show a => a -> String
show (Int -> String) -> Int -> String
forall a b. (a -> b) -> a -> b
$ TestStatus -> Int
testStatusRunsRemain TestStatus
ts
    remainRuns' :: String
remainRuns' = String
remainRuns String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"/" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
totalRuns

tableLines :: Int
tableLines :: Int
tableLines = Int
8

spaceTable :: IO ()
spaceTable :: IO ()
spaceTable = String -> IO ()
putStr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> Char -> String
forall a. Int -> a -> [a]
replicate Int
tableLines Char
'\n'

reportTable :: TestStatus -> IO ()
reportTable :: TestStatus -> IO ()
reportTable TestStatus
ts = do
  IO ()
moveCursorToTableTop
  TestStatus -> IO ()
putStatusTable TestStatus
ts
  IO ()
clearLine
  w <- Int -> (Window Int -> Int) -> Maybe (Window Int) -> Int
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Int
80 Window Int -> Int
forall a. Window a -> a
Terminal.width (Maybe (Window Int) -> Int) -> IO (Maybe (Window Int)) -> IO Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (Maybe (Window Int))
forall n. Integral n => IO (Maybe (Window n))
Terminal.size
  T.putStrLn $ atMostChars (w - T.length labelstr) running
  where
    running :: Text
running = Text
labelstr Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ([Text] -> Text
T.unwords ([Text] -> Text) -> (TestStatus -> [Text]) -> TestStatus -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> [Text]
forall a. [a] -> [a]
reverse ([Text] -> [Text])
-> (TestStatus -> [Text]) -> TestStatus -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TestCase -> Text) -> [TestCase] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (String -> Text
T.pack (String -> Text) -> (TestCase -> String) -> TestCase -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TestCase -> String
testCaseProgram) ([TestCase] -> [Text])
-> (TestStatus -> [TestCase]) -> TestStatus -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TestStatus -> [TestCase]
testStatusRun) TestStatus
ts
    labelstr :: Text
labelstr = Text
"Now testing: "

reportLine :: MVar SystemTime -> TestStatus -> IO ()
reportLine :: MVar SystemTime -> TestStatus -> IO ()
reportLine MVar SystemTime
time_mvar TestStatus
ts =
  MVar SystemTime -> (SystemTime -> IO SystemTime) -> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ MVar SystemTime
time_mvar ((SystemTime -> IO SystemTime) -> IO ())
-> (SystemTime -> IO SystemTime) -> IO ()
forall a b. (a -> b) -> a -> b
$ \SystemTime
time -> do
    time_now <- IO SystemTime
getSystemTime
    if systemSeconds time_now - systemSeconds time >= period
      then do
        T.putStrLn $
          showText (testStatusFail ts)
            <> " failed, "
            <> showText (testStatusPass ts)
            <> " passed, "
            <> showText num_remain
            <> " to go."
        pure time_now
      else pure time
  where
    num_remain :: Int
num_remain = [TestCase] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([TestCase] -> Int) -> [TestCase] -> Int
forall a b. (a -> b) -> a -> b
$ TestStatus -> [TestCase]
testStatusRemain TestStatus
ts
    period :: Int64
period = Int64
60

moveCursorToTableTop :: IO ()
moveCursorToTableTop :: IO ()
moveCursorToTableTop = Int -> IO ()
cursorUpLine Int
tableLines

runTests :: TestConfig -> [FilePath] -> IO ()
runTests :: TestConfig -> [String] -> IO ()
runTests TestConfig
config [String]
paths = do
  -- We force line buffering to ensure that we produce running output.
  -- Otherwise, CI tools and the like may believe we are hung and kill
  -- us.
  Handle -> BufferMode -> IO ()
hSetBuffering Handle
stdout BufferMode
LineBuffering

  let mode :: TestMode
mode = TestConfig -> TestMode
configTestMode TestConfig
config
  all_tests <-
    ((String, ProgramTest) -> TestCase)
-> [(String, ProgramTest)] -> [TestCase]
forall a b. (a -> b) -> [a] -> [b]
map (TestConfig -> TestMode -> (String, ProgramTest) -> TestCase
makeTestCase TestConfig
config TestMode
mode)
      ([(String, ProgramTest)] -> [TestCase])
-> IO [(String, ProgramTest)] -> IO [TestCase]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [String] -> IO [(String, ProgramTest)]
testSpecsFromPathsOrDie [String]
paths
  -- putStrLn $ "Test cases are: " ++ show (map testCaseProgram all_tests)
  testmvar <- newEmptyMVar
  reportmvar <- newEmptyMVar
  concurrency <- maybe getNumCapabilities pure $ configConcurrency config
  replicateM_ concurrency $ forkIO $ runTest testmvar reportmvar

  let (excluded, included) = partition (excludedTest config) all_tests
  _ <- forkIO $ mapM_ (putMVar testmvar . excludeCases config) included

  time_mvar <- newMVar $ MkSystemTime 0 0

  let fancy = Bool -> Bool
not (TestConfig -> Bool
configLineOutput TestConfig
config) Bool -> Bool -> Bool
&& Bool
fancyTerminal

      report
        | Bool
fancy = TestStatus -> IO ()
reportTable
        | Bool
otherwise = MVar SystemTime -> TestStatus -> IO ()
reportLine MVar SystemTime
time_mvar
      clear
        | Bool
fancy = IO ()
clearFromCursorToScreenEnd
        | Bool
otherwise = () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

      numTestCases TestCase
tc =
        case ProgramTest -> TestAction
testAction (ProgramTest -> TestAction) -> ProgramTest -> TestAction
forall a b. (a -> b) -> a -> b
$ TestCase -> ProgramTest
testCaseTest TestCase
tc of
          CompileTimeFailure ExpectedError
_ -> Int
1
          RunCases [InputOutputs]
ios [StructureTest]
sts [WarningTest]
wts [PropertyCase]
pbts ->
            [TestRun] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ((InputOutputs -> [TestRun]) -> [InputOutputs] -> [TestRun]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap InputOutputs -> [TestRun]
iosTestRuns [InputOutputs]
ios)
              Int -> Int -> Int
forall a. Num a => a -> a -> a
+ [StructureTest] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [StructureTest]
sts
              Int -> Int -> Int
forall a. Num a => a -> a -> a
+ [WarningTest] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [WarningTest]
wts
              Int -> Int -> Int
forall a. Num a => a -> a -> a
+ [PropertyCase] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [PropertyCase]
pbts
      getResults TestStatus
ts
        | [TestCase] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (TestStatus -> [TestCase]
testStatusRemain TestStatus
ts) = TestStatus -> IO ()
report TestStatus
ts IO () -> IO TestStatus -> IO TestStatus
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> TestStatus -> IO TestStatus
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TestStatus
ts
        | Bool
otherwise = do
            TestStatus -> IO ()
report TestStatus
ts
            msg <- MVar ReportMsg -> IO ReportMsg
forall a. MVar a -> IO a
takeMVar MVar ReportMsg
reportmvar
            case msg of
              TestStarted TestCase
test ->
                TestStatus -> IO TestStatus
getResults (TestStatus -> IO TestStatus) -> TestStatus -> IO TestStatus
forall a b. (a -> b) -> a -> b
$ TestStatus
ts {testStatusRun = test : testStatusRun ts}
              TestDone TestCase
test TestResult
res -> do
                let ts' :: TestStatus
ts' =
                      TestStatus
ts
                        { testStatusRemain = test `delete` testStatusRemain ts,
                          testStatusRun = test `delete` testStatusRun ts,
                          testStatusRunsRemain =
                            testStatusRunsRemain ts - numTestCases test
                        }
                case TestResult
res of
                  TestResult
Success -> do
                    let ts'' :: TestStatus
ts'' =
                          TestStatus
ts'
                            { testStatusRunPass =
                                testStatusRunPass ts' + numTestCases test
                            }
                    TestStatus -> IO TestStatus
getResults (TestStatus -> IO TestStatus) -> TestStatus -> IO TestStatus
forall a b. (a -> b) -> a -> b
$ TestStatus
ts'' {testStatusPass = testStatusPass ts + 1}
                  Failure [Text]
s -> do
                    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
fancy IO ()
moveCursorToTableTop
                    IO ()
clear
                    Doc AnsiStyle -> IO ()
putDoc (Doc AnsiStyle -> IO ()) -> Doc AnsiStyle -> IO ()
forall a b. (a -> b) -> a -> b
$
                      AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. ann -> Doc ann -> Doc ann
annotate (AnsiStyle
bold AnsiStyle -> AnsiStyle -> AnsiStyle
forall a. Semigroup a => a -> a -> a
<> Color -> AnsiStyle
bgColor Color
Red) (String -> Doc AnsiStyle
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (TestCase -> String
testCaseProgram TestCase
test) Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> Doc AnsiStyle
":")
                        Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> Doc AnsiStyle
forall ann. Doc ann
hardline
                        Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> [Doc AnsiStyle] -> Doc AnsiStyle
forall ann. [Doc ann] -> Doc ann
vsep ((Text -> Doc AnsiStyle) -> [Text] -> [Doc AnsiStyle]
forall a b. (a -> b) -> [a] -> [b]
map Text -> Doc AnsiStyle
forall ann. Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty [Text]
s)
                        Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> Doc AnsiStyle
forall ann. Doc ann
hardline
                    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
fancy IO ()
spaceTable
                    TestStatus -> IO TestStatus
getResults (TestStatus -> IO TestStatus) -> TestStatus -> IO TestStatus
forall a b. (a -> b) -> a -> b
$
                      TestStatus
ts'
                        { testStatusFail = testStatusFail ts' + 1,
                          testStatusRunPass =
                            testStatusRunPass ts'
                              + max 0 (numTestCases test - length s),
                          testStatusRunFail =
                            testStatusRunFail ts'
                              + min (numTestCases test) (length s)
                        }
  when fancy spaceTable

  ts <-
    getResults
      TestStatus
        { testStatusRemain = included,
          testStatusRun = [],
          testStatusTotal = length included,
          testStatusFail = 0,
          testStatusPass = 0,
          testStatusRuns = sum $ map numTestCases included,
          testStatusRunsRemain = sum $ map numTestCases included,
          testStatusRunPass = 0,
          testStatusRunFail = 0
        }

  -- Removes "Now testing" output.
  if fancy
    then cursorUpLine 1 >> clearLine
    else
      putStrLn $
        show (testStatusPass ts)
          <> "/"
          <> show (testStatusTotal ts)
          <> " passed."

  unless (null excluded) . putStrLn $
    show (length excluded) ++ " program(s) excluded."

  exitWith $ case testStatusFail ts of
    Int
0 -> ExitCode
ExitSuccess
    Int
_ -> Int -> ExitCode
ExitFailure Int
1

---
--- Configuration and command line parsing
---

data TestConfig = TestConfig
  { TestConfig -> TestMode
configTestMode :: TestMode,
    TestConfig -> ProgConfig
configPrograms :: ProgConfig,
    TestConfig -> [Text]
configExclude :: [T.Text],
    TestConfig -> Bool
configLineOutput :: Bool,
    TestConfig -> Maybe Int
configConcurrency :: Maybe Int,
    TestConfig -> Maybe String
configEntryPoint :: Maybe String,
    TestConfig -> PBTConfig
configPBTConfig :: PBTConfig
  }

defaultConfig :: TestConfig
defaultConfig :: TestConfig
defaultConfig =
  TestConfig
    { configTestMode :: TestMode
configTestMode = TestMode
Compiled,
      configExclude :: [Text]
configExclude = [Text
"disable", Text
"notest"],
      configPrograms :: ProgConfig
configPrograms =
        ProgConfig
          { configBackend :: String
configBackend = String
"c",
            configFuthark :: Maybe String
configFuthark = Maybe String
forall a. Maybe a
Nothing,
            configRunner :: String
configRunner = String
"",
            configExtraOptions :: [String]
configExtraOptions = [],
            configExtraCompilerOptions :: [String]
configExtraCompilerOptions = [],
            configTuning :: Maybe String
configTuning = String -> Maybe String
forall a. a -> Maybe a
Just String
"tuning",
            configCacheExt :: Maybe String
configCacheExt = Maybe String
forall a. Maybe a
Nothing
          },
      configLineOutput :: Bool
configLineOutput = Bool
False,
      configConcurrency :: Maybe Int
configConcurrency = Maybe Int
forall a. Maybe a
Nothing,
      configEntryPoint :: Maybe String
configEntryPoint = Maybe String
forall a. Maybe a
Nothing,
      configPBTConfig :: PBTConfig
configPBTConfig =
        PBTConfig
          { configNumTests :: Int32
configNumTests = Int32
100,
            configMaxSize :: Int64
configMaxSize = Int64
50,
            configSeed :: Word64
configSeed = Word64
randomSeed,
            configShrinkTries :: Int
configShrinkTries = Int
5
          }
    }

data ProgConfig = ProgConfig
  { ProgConfig -> String
configBackend :: String,
    ProgConfig -> Maybe String
configFuthark :: Maybe FilePath,
    ProgConfig -> String
configRunner :: FilePath,
    ProgConfig -> [String]
configExtraCompilerOptions :: [String],
    ProgConfig -> Maybe String
configTuning :: Maybe String,
    ProgConfig -> Maybe String
configCacheExt :: Maybe String,
    -- | Extra options passed to the programs being run.
    ProgConfig -> [String]
configExtraOptions :: [String]
  }
  deriving (Int -> ProgConfig -> String -> String
[ProgConfig] -> String -> String
ProgConfig -> String
(Int -> ProgConfig -> String -> String)
-> (ProgConfig -> String)
-> ([ProgConfig] -> String -> String)
-> Show ProgConfig
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> ProgConfig -> String -> String
showsPrec :: Int -> ProgConfig -> String -> String
$cshow :: ProgConfig -> String
show :: ProgConfig -> String
$cshowList :: [ProgConfig] -> String -> String
showList :: [ProgConfig] -> String -> String
Show)

changeProgConfig :: (ProgConfig -> ProgConfig) -> TestConfig -> TestConfig
changeProgConfig :: (ProgConfig -> ProgConfig) -> TestConfig -> TestConfig
changeProgConfig ProgConfig -> ProgConfig
f TestConfig
config = TestConfig
config {configPrograms = f $ configPrograms config}

changePBTConfig :: (PBTConfig -> PBTConfig) -> TestConfig -> TestConfig
changePBTConfig :: (PBTConfig -> PBTConfig) -> TestConfig -> TestConfig
changePBTConfig PBTConfig -> PBTConfig
f TestConfig
config = TestConfig
config {configPBTConfig = f $ configPBTConfig config}

setBackend :: FilePath -> ProgConfig -> ProgConfig
setBackend :: String -> ProgConfig -> ProgConfig
setBackend String
backend ProgConfig
config =
  ProgConfig
config {configBackend = backend}

setFuthark :: FilePath -> ProgConfig -> ProgConfig
setFuthark :: String -> ProgConfig -> ProgConfig
setFuthark String
futhark ProgConfig
config =
  ProgConfig
config {configFuthark = Just futhark}

setRunner :: FilePath -> ProgConfig -> ProgConfig
setRunner :: String -> ProgConfig -> ProgConfig
setRunner String
runner ProgConfig
config =
  ProgConfig
config {configRunner = runner}

addCompilerOption :: String -> ProgConfig -> ProgConfig
addCompilerOption :: String -> ProgConfig -> ProgConfig
addCompilerOption String
option ProgConfig
config =
  ProgConfig
config {configExtraCompilerOptions = configExtraCompilerOptions config ++ [option]}

addOption :: String -> ProgConfig -> ProgConfig
addOption :: String -> ProgConfig -> ProgConfig
addOption String
option ProgConfig
config =
  ProgConfig
config {configExtraOptions = configExtraOptions config ++ [option]}

commandLineOptions :: [FunOptDescr TestConfig]
commandLineOptions :: [FunOptDescr TestConfig]
commandLineOptions =
  [ String
-> [String]
-> ArgDescr (Either (IO ()) (TestConfig -> TestConfig))
-> String
-> FunOptDescr TestConfig
forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
Option
      String
"t"
      [String
"typecheck"]
      (Either (IO ()) (TestConfig -> TestConfig)
-> ArgDescr (Either (IO ()) (TestConfig -> TestConfig))
forall a. a -> ArgDescr a
NoArg (Either (IO ()) (TestConfig -> TestConfig)
 -> ArgDescr (Either (IO ()) (TestConfig -> TestConfig)))
-> Either (IO ()) (TestConfig -> TestConfig)
-> ArgDescr (Either (IO ()) (TestConfig -> TestConfig))
forall a b. (a -> b) -> a -> b
$ (TestConfig -> TestConfig)
-> Either (IO ()) (TestConfig -> TestConfig)
forall a b. b -> Either a b
Right ((TestConfig -> TestConfig)
 -> Either (IO ()) (TestConfig -> TestConfig))
-> (TestConfig -> TestConfig)
-> Either (IO ()) (TestConfig -> TestConfig)
forall a b. (a -> b) -> a -> b
$ \TestConfig
config -> TestConfig
config {configTestMode = TypeCheck})
      String
"Only perform type-checking",
    String
-> [String]
-> ArgDescr (Either (IO ()) (TestConfig -> TestConfig))
-> String
-> FunOptDescr TestConfig
forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
Option
      String
"i"
      [String
"interpreted"]
      (Either (IO ()) (TestConfig -> TestConfig)
-> ArgDescr (Either (IO ()) (TestConfig -> TestConfig))
forall a. a -> ArgDescr a
NoArg (Either (IO ()) (TestConfig -> TestConfig)
 -> ArgDescr (Either (IO ()) (TestConfig -> TestConfig)))
-> Either (IO ()) (TestConfig -> TestConfig)
-> ArgDescr (Either (IO ()) (TestConfig -> TestConfig))
forall a b. (a -> b) -> a -> b
$ (TestConfig -> TestConfig)
-> Either (IO ()) (TestConfig -> TestConfig)
forall a b. b -> Either a b
Right ((TestConfig -> TestConfig)
 -> Either (IO ()) (TestConfig -> TestConfig))
-> (TestConfig -> TestConfig)
-> Either (IO ()) (TestConfig -> TestConfig)
forall a b. (a -> b) -> a -> b
$ \TestConfig
config -> TestConfig
config {configTestMode = Interpreted})
      String
"Only interpret",
    String
-> [String]
-> ArgDescr (Either (IO ()) (TestConfig -> TestConfig))
-> String
-> FunOptDescr TestConfig
forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
Option
      []
      [String
"interpret-soacs"]
      (Either (IO ()) (TestConfig -> TestConfig)
-> ArgDescr (Either (IO ()) (TestConfig -> TestConfig))
forall a. a -> ArgDescr a
NoArg (Either (IO ()) (TestConfig -> TestConfig)
 -> ArgDescr (Either (IO ()) (TestConfig -> TestConfig)))
-> Either (IO ()) (TestConfig -> TestConfig)
-> ArgDescr (Either (IO ()) (TestConfig -> TestConfig))
forall a b. (a -> b) -> a -> b
$ (TestConfig -> TestConfig)
-> Either (IO ()) (TestConfig -> TestConfig)
forall a b. b -> Either a b
Right ((TestConfig -> TestConfig)
 -> Either (IO ()) (TestConfig -> TestConfig))
-> (TestConfig -> TestConfig)
-> Either (IO ()) (TestConfig -> TestConfig)
forall a b. (a -> b) -> a -> b
$ \TestConfig
config -> TestConfig
config {configTestMode = InterpretedSOACS})
      String
"Only interpret SOACS IR",
    String
-> [String]
-> ArgDescr (Either (IO ()) (TestConfig -> TestConfig))
-> String
-> FunOptDescr TestConfig
forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
Option
      []
      [String
"interpret-gpu"]
      (Either (IO ()) (TestConfig -> TestConfig)
-> ArgDescr (Either (IO ()) (TestConfig -> TestConfig))
forall a. a -> ArgDescr a
NoArg (Either (IO ()) (TestConfig -> TestConfig)
 -> ArgDescr (Either (IO ()) (TestConfig -> TestConfig)))
-> Either (IO ()) (TestConfig -> TestConfig)
-> ArgDescr (Either (IO ()) (TestConfig -> TestConfig))
forall a b. (a -> b) -> a -> b
$ (TestConfig -> TestConfig)
-> Either (IO ()) (TestConfig -> TestConfig)
forall a b. b -> Either a b
Right ((TestConfig -> TestConfig)
 -> Either (IO ()) (TestConfig -> TestConfig))
-> (TestConfig -> TestConfig)
-> Either (IO ()) (TestConfig -> TestConfig)
forall a b. (a -> b) -> a -> b
$ \TestConfig
config -> TestConfig
config {configTestMode = InterpretedGPU})
      String
"Only interpret GPU IR",
    String
-> [String]
-> ArgDescr (Either (IO ()) (TestConfig -> TestConfig))
-> String
-> FunOptDescr TestConfig
forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
Option
      String
"c"
      [String
"compiled"]
      (Either (IO ()) (TestConfig -> TestConfig)
-> ArgDescr (Either (IO ()) (TestConfig -> TestConfig))
forall a. a -> ArgDescr a
NoArg (Either (IO ()) (TestConfig -> TestConfig)
 -> ArgDescr (Either (IO ()) (TestConfig -> TestConfig)))
-> Either (IO ()) (TestConfig -> TestConfig)
-> ArgDescr (Either (IO ()) (TestConfig -> TestConfig))
forall a b. (a -> b) -> a -> b
$ (TestConfig -> TestConfig)
-> Either (IO ()) (TestConfig -> TestConfig)
forall a b. b -> Either a b
Right ((TestConfig -> TestConfig)
 -> Either (IO ()) (TestConfig -> TestConfig))
-> (TestConfig -> TestConfig)
-> Either (IO ()) (TestConfig -> TestConfig)
forall a b. (a -> b) -> a -> b
$ \TestConfig
config -> TestConfig
config {configTestMode = Compiled})
      String
"Only run compiled code (the default)",
    String
-> [String]
-> ArgDescr (Either (IO ()) (TestConfig -> TestConfig))
-> String
-> FunOptDescr TestConfig
forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
Option
      String
"C"
      [String
"compile"]
      (Either (IO ()) (TestConfig -> TestConfig)
-> ArgDescr (Either (IO ()) (TestConfig -> TestConfig))
forall a. a -> ArgDescr a
NoArg (Either (IO ()) (TestConfig -> TestConfig)
 -> ArgDescr (Either (IO ()) (TestConfig -> TestConfig)))
-> Either (IO ()) (TestConfig -> TestConfig)
-> ArgDescr (Either (IO ()) (TestConfig -> TestConfig))
forall a b. (a -> b) -> a -> b
$ (TestConfig -> TestConfig)
-> Either (IO ()) (TestConfig -> TestConfig)
forall a b. b -> Either a b
Right ((TestConfig -> TestConfig)
 -> Either (IO ()) (TestConfig -> TestConfig))
-> (TestConfig -> TestConfig)
-> Either (IO ()) (TestConfig -> TestConfig)
forall a b. (a -> b) -> a -> b
$ \TestConfig
config -> TestConfig
config {configTestMode = Compile})
      String
"Only compile, do not run.",
    String
-> [String]
-> ArgDescr (Either (IO ()) (TestConfig -> TestConfig))
-> String
-> FunOptDescr TestConfig
forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
Option
      String
"s"
      [String
"structure"]
      (Either (IO ()) (TestConfig -> TestConfig)
-> ArgDescr (Either (IO ()) (TestConfig -> TestConfig))
forall a. a -> ArgDescr a
NoArg (Either (IO ()) (TestConfig -> TestConfig)
 -> ArgDescr (Either (IO ()) (TestConfig -> TestConfig)))
-> Either (IO ()) (TestConfig -> TestConfig)
-> ArgDescr (Either (IO ()) (TestConfig -> TestConfig))
forall a b. (a -> b) -> a -> b
$ (TestConfig -> TestConfig)
-> Either (IO ()) (TestConfig -> TestConfig)
forall a b. b -> Either a b
Right ((TestConfig -> TestConfig)
 -> Either (IO ()) (TestConfig -> TestConfig))
-> (TestConfig -> TestConfig)
-> Either (IO ()) (TestConfig -> TestConfig)
forall a b. (a -> b) -> a -> b
$ \TestConfig
config -> TestConfig
config {configTestMode = Structure})
      String
"Perform structure tests.",
    String
-> [String]
-> ArgDescr (Either (IO ()) (TestConfig -> TestConfig))
-> String
-> FunOptDescr TestConfig
forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
Option
      String
"I"
      [String
"internalise"]
      (Either (IO ()) (TestConfig -> TestConfig)
-> ArgDescr (Either (IO ()) (TestConfig -> TestConfig))
forall a. a -> ArgDescr a
NoArg (Either (IO ()) (TestConfig -> TestConfig)
 -> ArgDescr (Either (IO ()) (TestConfig -> TestConfig)))
-> Either (IO ()) (TestConfig -> TestConfig)
-> ArgDescr (Either (IO ()) (TestConfig -> TestConfig))
forall a b. (a -> b) -> a -> b
$ (TestConfig -> TestConfig)
-> Either (IO ()) (TestConfig -> TestConfig)
forall a b. b -> Either a b
Right ((TestConfig -> TestConfig)
 -> Either (IO ()) (TestConfig -> TestConfig))
-> (TestConfig -> TestConfig)
-> Either (IO ()) (TestConfig -> TestConfig)
forall a b. (a -> b) -> a -> b
$ \TestConfig
config -> TestConfig
config {configTestMode = Internalise})
      String
"Only run the compiler frontend.",
    String
-> [String]
-> ArgDescr (Either (IO ()) (TestConfig -> TestConfig))
-> String
-> FunOptDescr TestConfig
forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
Option
      []
      [String
"no-terminal", String
"notty"]
      (Either (IO ()) (TestConfig -> TestConfig)
-> ArgDescr (Either (IO ()) (TestConfig -> TestConfig))
forall a. a -> ArgDescr a
NoArg (Either (IO ()) (TestConfig -> TestConfig)
 -> ArgDescr (Either (IO ()) (TestConfig -> TestConfig)))
-> Either (IO ()) (TestConfig -> TestConfig)
-> ArgDescr (Either (IO ()) (TestConfig -> TestConfig))
forall a b. (a -> b) -> a -> b
$ (TestConfig -> TestConfig)
-> Either (IO ()) (TestConfig -> TestConfig)
forall a b. b -> Either a b
Right ((TestConfig -> TestConfig)
 -> Either (IO ()) (TestConfig -> TestConfig))
-> (TestConfig -> TestConfig)
-> Either (IO ()) (TestConfig -> TestConfig)
forall a b. (a -> b) -> a -> b
$ \TestConfig
config -> TestConfig
config {configLineOutput = True})
      String
"Provide simpler line-based output.",
    String
-> [String]
-> ArgDescr (Either (IO ()) (TestConfig -> TestConfig))
-> String
-> FunOptDescr TestConfig
forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
Option
      []
      [String
"backend"]
      ((String -> Either (IO ()) (TestConfig -> TestConfig))
-> String -> ArgDescr (Either (IO ()) (TestConfig -> TestConfig))
forall a. (String -> a) -> String -> ArgDescr a
ReqArg ((TestConfig -> TestConfig)
-> Either (IO ()) (TestConfig -> TestConfig)
forall a b. b -> Either a b
Right ((TestConfig -> TestConfig)
 -> Either (IO ()) (TestConfig -> TestConfig))
-> (String -> TestConfig -> TestConfig)
-> String
-> Either (IO ()) (TestConfig -> TestConfig)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ProgConfig -> ProgConfig) -> TestConfig -> TestConfig
changeProgConfig ((ProgConfig -> ProgConfig) -> TestConfig -> TestConfig)
-> (String -> ProgConfig -> ProgConfig)
-> String
-> TestConfig
-> TestConfig
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ProgConfig -> ProgConfig
setBackend) String
"BACKEND")
      String
"Backend used for compilation (defaults to 'c').",
    String
-> [String]
-> ArgDescr (Either (IO ()) (TestConfig -> TestConfig))
-> String
-> FunOptDescr TestConfig
forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
Option
      []
      [String
"futhark"]
      ((String -> Either (IO ()) (TestConfig -> TestConfig))
-> String -> ArgDescr (Either (IO ()) (TestConfig -> TestConfig))
forall a. (String -> a) -> String -> ArgDescr a
ReqArg ((TestConfig -> TestConfig)
-> Either (IO ()) (TestConfig -> TestConfig)
forall a b. b -> Either a b
Right ((TestConfig -> TestConfig)
 -> Either (IO ()) (TestConfig -> TestConfig))
-> (String -> TestConfig -> TestConfig)
-> String
-> Either (IO ()) (TestConfig -> TestConfig)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ProgConfig -> ProgConfig) -> TestConfig -> TestConfig
changeProgConfig ((ProgConfig -> ProgConfig) -> TestConfig -> TestConfig)
-> (String -> ProgConfig -> ProgConfig)
-> String
-> TestConfig
-> TestConfig
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ProgConfig -> ProgConfig
setFuthark) String
"PROGRAM")
      String
"Program to run for subcommands (defaults to same binary as 'futhark test').",
    String
-> [String]
-> ArgDescr (Either (IO ()) (TestConfig -> TestConfig))
-> String
-> FunOptDescr TestConfig
forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
Option
      []
      [String
"runner"]
      ((String -> Either (IO ()) (TestConfig -> TestConfig))
-> String -> ArgDescr (Either (IO ()) (TestConfig -> TestConfig))
forall a. (String -> a) -> String -> ArgDescr a
ReqArg ((TestConfig -> TestConfig)
-> Either (IO ()) (TestConfig -> TestConfig)
forall a b. b -> Either a b
Right ((TestConfig -> TestConfig)
 -> Either (IO ()) (TestConfig -> TestConfig))
-> (String -> TestConfig -> TestConfig)
-> String
-> Either (IO ()) (TestConfig -> TestConfig)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ProgConfig -> ProgConfig) -> TestConfig -> TestConfig
changeProgConfig ((ProgConfig -> ProgConfig) -> TestConfig -> TestConfig)
-> (String -> ProgConfig -> ProgConfig)
-> String
-> TestConfig
-> TestConfig
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ProgConfig -> ProgConfig
setRunner) String
"PROGRAM")
      String
"The program used to run the Futhark-generated programs (defaults to nothing).",
    String
-> [String]
-> ArgDescr (Either (IO ()) (TestConfig -> TestConfig))
-> String
-> FunOptDescr TestConfig
forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
Option
      []
      [String
"exclude"]
      ( (String -> Either (IO ()) (TestConfig -> TestConfig))
-> String -> ArgDescr (Either (IO ()) (TestConfig -> TestConfig))
forall a. (String -> a) -> String -> ArgDescr a
ReqArg
          ( \String
tag ->
              (TestConfig -> TestConfig)
-> Either (IO ()) (TestConfig -> TestConfig)
forall a b. b -> Either a b
Right ((TestConfig -> TestConfig)
 -> Either (IO ()) (TestConfig -> TestConfig))
-> (TestConfig -> TestConfig)
-> Either (IO ()) (TestConfig -> TestConfig)
forall a b. (a -> b) -> a -> b
$ \TestConfig
config ->
                TestConfig
config {configExclude = T.pack tag : configExclude config}
          )
          String
"TAG"
      )
      String
"Exclude test programs that define this tag.",
    String
-> [String]
-> ArgDescr (Either (IO ()) (TestConfig -> TestConfig))
-> String
-> FunOptDescr TestConfig
forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
Option
      String
"p"
      [String
"pass-option"]
      ((String -> Either (IO ()) (TestConfig -> TestConfig))
-> String -> ArgDescr (Either (IO ()) (TestConfig -> TestConfig))
forall a. (String -> a) -> String -> ArgDescr a
ReqArg ((TestConfig -> TestConfig)
-> Either (IO ()) (TestConfig -> TestConfig)
forall a b. b -> Either a b
Right ((TestConfig -> TestConfig)
 -> Either (IO ()) (TestConfig -> TestConfig))
-> (String -> TestConfig -> TestConfig)
-> String
-> Either (IO ()) (TestConfig -> TestConfig)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ProgConfig -> ProgConfig) -> TestConfig -> TestConfig
changeProgConfig ((ProgConfig -> ProgConfig) -> TestConfig -> TestConfig)
-> (String -> ProgConfig -> ProgConfig)
-> String
-> TestConfig
-> TestConfig
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ProgConfig -> ProgConfig
addOption) String
"OPT")
      String
"Pass this option to programs being run.",
    String
-> [String]
-> ArgDescr (Either (IO ()) (TestConfig -> TestConfig))
-> String
-> FunOptDescr TestConfig
forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
Option
      []
      [String
"pass-compiler-option"]
      ((String -> Either (IO ()) (TestConfig -> TestConfig))
-> String -> ArgDescr (Either (IO ()) (TestConfig -> TestConfig))
forall a. (String -> a) -> String -> ArgDescr a
ReqArg ((TestConfig -> TestConfig)
-> Either (IO ()) (TestConfig -> TestConfig)
forall a b. b -> Either a b
Right ((TestConfig -> TestConfig)
 -> Either (IO ()) (TestConfig -> TestConfig))
-> (String -> TestConfig -> TestConfig)
-> String
-> Either (IO ()) (TestConfig -> TestConfig)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ProgConfig -> ProgConfig) -> TestConfig -> TestConfig
changeProgConfig ((ProgConfig -> ProgConfig) -> TestConfig -> TestConfig)
-> (String -> ProgConfig -> ProgConfig)
-> String
-> TestConfig
-> TestConfig
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ProgConfig -> ProgConfig
addCompilerOption) String
"OPT")
      String
"Pass this option to the compiler (or typechecker if in -t mode).",
    String
-> [String]
-> ArgDescr (Either (IO ()) (TestConfig -> TestConfig))
-> String
-> FunOptDescr TestConfig
forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
Option
      []
      [String
"tuning"]
      ( (String -> Either (IO ()) (TestConfig -> TestConfig))
-> String -> ArgDescr (Either (IO ()) (TestConfig -> TestConfig))
forall a. (String -> a) -> String -> ArgDescr a
ReqArg
          (\String
s -> (TestConfig -> TestConfig)
-> Either (IO ()) (TestConfig -> TestConfig)
forall a b. b -> Either a b
Right ((TestConfig -> TestConfig)
 -> Either (IO ()) (TestConfig -> TestConfig))
-> (TestConfig -> TestConfig)
-> Either (IO ()) (TestConfig -> TestConfig)
forall a b. (a -> b) -> a -> b
$ (ProgConfig -> ProgConfig) -> TestConfig -> TestConfig
changeProgConfig ((ProgConfig -> ProgConfig) -> TestConfig -> TestConfig)
-> (ProgConfig -> ProgConfig) -> TestConfig -> TestConfig
forall a b. (a -> b) -> a -> b
$ \ProgConfig
config -> ProgConfig
config {configTuning = Just s})
          String
"EXTENSION"
      )
      String
"Look for tuning files with this extension (defaults to .tuning).",
    String
-> [String]
-> ArgDescr (Either (IO ()) (TestConfig -> TestConfig))
-> String
-> FunOptDescr TestConfig
forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
Option
      []
      [String
"no-tuning"]
      (Either (IO ()) (TestConfig -> TestConfig)
-> ArgDescr (Either (IO ()) (TestConfig -> TestConfig))
forall a. a -> ArgDescr a
NoArg (Either (IO ()) (TestConfig -> TestConfig)
 -> ArgDescr (Either (IO ()) (TestConfig -> TestConfig)))
-> Either (IO ()) (TestConfig -> TestConfig)
-> ArgDescr (Either (IO ()) (TestConfig -> TestConfig))
forall a b. (a -> b) -> a -> b
$ (TestConfig -> TestConfig)
-> Either (IO ()) (TestConfig -> TestConfig)
forall a b. b -> Either a b
Right ((TestConfig -> TestConfig)
 -> Either (IO ()) (TestConfig -> TestConfig))
-> (TestConfig -> TestConfig)
-> Either (IO ()) (TestConfig -> TestConfig)
forall a b. (a -> b) -> a -> b
$ (ProgConfig -> ProgConfig) -> TestConfig -> TestConfig
changeProgConfig ((ProgConfig -> ProgConfig) -> TestConfig -> TestConfig)
-> (ProgConfig -> ProgConfig) -> TestConfig -> TestConfig
forall a b. (a -> b) -> a -> b
$ \ProgConfig
config -> ProgConfig
config {configTuning = Nothing})
      String
"Do not load tuning files.",
    String
-> [String]
-> ArgDescr (Either (IO ()) (TestConfig -> TestConfig))
-> String
-> FunOptDescr TestConfig
forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
Option
      []
      [String
"cache-extension"]
      ( (String -> Either (IO ()) (TestConfig -> TestConfig))
-> String -> ArgDescr (Either (IO ()) (TestConfig -> TestConfig))
forall a. (String -> a) -> String -> ArgDescr a
ReqArg
          (\String
s -> (TestConfig -> TestConfig)
-> Either (IO ()) (TestConfig -> TestConfig)
forall a b. b -> Either a b
Right ((TestConfig -> TestConfig)
 -> Either (IO ()) (TestConfig -> TestConfig))
-> (TestConfig -> TestConfig)
-> Either (IO ()) (TestConfig -> TestConfig)
forall a b. (a -> b) -> a -> b
$ (ProgConfig -> ProgConfig) -> TestConfig -> TestConfig
changeProgConfig ((ProgConfig -> ProgConfig) -> TestConfig -> TestConfig)
-> (ProgConfig -> ProgConfig) -> TestConfig -> TestConfig
forall a b. (a -> b) -> a -> b
$ \ProgConfig
config -> ProgConfig
config {configCacheExt = Just s})
          String
"EXTENSION"
      )
      String
"Use cache files with this extension (none by default).",
    String
-> [String]
-> ArgDescr (Either (IO ()) (TestConfig -> TestConfig))
-> String
-> FunOptDescr TestConfig
forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
Option
      []
      [String
"concurrency"]
      ( (String -> Either (IO ()) (TestConfig -> TestConfig))
-> String -> ArgDescr (Either (IO ()) (TestConfig -> TestConfig))
forall a. (String -> a) -> String -> ArgDescr a
ReqArg
          ( \String
n ->
              case ReadS Int
forall a. Read a => ReadS a
reads String
n of
                [(Int
n', String
"")]
                  | Int
n' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 ->
                      (TestConfig -> TestConfig)
-> Either (IO ()) (TestConfig -> TestConfig)
forall a b. b -> Either a b
Right ((TestConfig -> TestConfig)
 -> Either (IO ()) (TestConfig -> TestConfig))
-> (TestConfig -> TestConfig)
-> Either (IO ()) (TestConfig -> TestConfig)
forall a b. (a -> b) -> a -> b
$ \TestConfig
config -> TestConfig
config {configConcurrency = Just n'}
                [(Int, String)]
_ ->
                  IO () -> Either (IO ()) (TestConfig -> TestConfig)
forall a b. a -> Either a b
Left (IO () -> Either (IO ()) (TestConfig -> TestConfig))
-> (String -> IO ())
-> String
-> Either (IO ()) (TestConfig -> TestConfig)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO ()
optionsError (String -> Either (IO ()) (TestConfig -> TestConfig))
-> String -> Either (IO ()) (TestConfig -> TestConfig)
forall a b. (a -> b) -> a -> b
$ String
"'" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"' is not a positive integer."
          )
          String
"NUM"
      )
      String
"Number of tests to run concurrently.",
    String
-> [String]
-> ArgDescr (Either (IO ()) (TestConfig -> TestConfig))
-> String
-> FunOptDescr TestConfig
forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
Option
      String
"e"
      [String
"entry-point"]
      ( (String -> Either (IO ()) (TestConfig -> TestConfig))
-> String -> ArgDescr (Either (IO ()) (TestConfig -> TestConfig))
forall a. (String -> a) -> String -> ArgDescr a
ReqArg
          ( \String
s -> (TestConfig -> TestConfig)
-> Either (IO ()) (TestConfig -> TestConfig)
forall a b. b -> Either a b
Right ((TestConfig -> TestConfig)
 -> Either (IO ()) (TestConfig -> TestConfig))
-> (TestConfig -> TestConfig)
-> Either (IO ()) (TestConfig -> TestConfig)
forall a b. (a -> b) -> a -> b
$ \TestConfig
config ->
              TestConfig
config {configEntryPoint = Just s}
          )
          String
"NAME"
      )
      String
"Only run entry points with this name.",
    String
-> [String]
-> ArgDescr (Either (IO ()) (TestConfig -> TestConfig))
-> String
-> FunOptDescr TestConfig
forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
Option
      String
"n"
      [String
"num-tests"]
      ( (String -> Either (IO ()) (TestConfig -> TestConfig))
-> String -> ArgDescr (Either (IO ()) (TestConfig -> TestConfig))
forall a. (String -> a) -> String -> ArgDescr a
ReqArg
          ( \String
n ->
              case ReadS Int32
forall a. Read a => ReadS a
reads String
n of
                [(Int32
n', String
"")]
                  | Int32
n' Int32 -> Int32 -> Bool
forall a. Ord a => a -> a -> Bool
>= Int32
0 ->
                      (TestConfig -> TestConfig)
-> Either (IO ()) (TestConfig -> TestConfig)
forall a b. b -> Either a b
Right ((TestConfig -> TestConfig)
 -> Either (IO ()) (TestConfig -> TestConfig))
-> (TestConfig -> TestConfig)
-> Either (IO ()) (TestConfig -> TestConfig)
forall a b. (a -> b) -> a -> b
$ (PBTConfig -> PBTConfig) -> TestConfig -> TestConfig
changePBTConfig ((PBTConfig -> PBTConfig) -> TestConfig -> TestConfig)
-> (PBTConfig -> PBTConfig) -> TestConfig -> TestConfig
forall a b. (a -> b) -> a -> b
$ \PBTConfig
pbt -> PBTConfig
pbt {configNumTests = n'}
                [(Int32, String)]
_ ->
                  IO () -> Either (IO ()) (TestConfig -> TestConfig)
forall a b. a -> Either a b
Left (IO () -> Either (IO ()) (TestConfig -> TestConfig))
-> (String -> IO ())
-> String
-> Either (IO ()) (TestConfig -> TestConfig)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO ()
optionsError (String -> Either (IO ()) (TestConfig -> TestConfig))
-> String -> Either (IO ()) (TestConfig -> TestConfig)
forall a b. (a -> b) -> a -> b
$ String
"'" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"' is not a non-negative integer."
          )
          String
"NUM"
      )
      (String -> FunOptDescr TestConfig)
-> String -> FunOptDescr TestConfig
forall a b. (a -> b) -> a -> b
$ String
"Number of tests to run per property (default: "
        String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int32 -> String
forall a. Show a => a -> String
show (PBTConfig -> Int32
configNumTests (PBTConfig -> Int32)
-> (TestConfig -> PBTConfig) -> TestConfig -> Int32
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TestConfig -> PBTConfig
configPBTConfig (TestConfig -> Int32) -> TestConfig -> Int32
forall a b. (a -> b) -> a -> b
$ TestConfig
defaultConfig)
        String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
").",
    String
-> [String]
-> ArgDescr (Either (IO ()) (TestConfig -> TestConfig))
-> String
-> FunOptDescr TestConfig
forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
Option
      String
"m"
      [String
"max-size"]
      ( (String -> Either (IO ()) (TestConfig -> TestConfig))
-> String -> ArgDescr (Either (IO ()) (TestConfig -> TestConfig))
forall a. (String -> a) -> String -> ArgDescr a
ReqArg
          ( \String
n ->
              case ReadS Int64
forall a. Read a => ReadS a
reads String
n of
                [(Int64
n', String
"")]
                  | Int64
n' Int64 -> Int64 -> Bool
forall a. Ord a => a -> a -> Bool
>= Int64
0 ->
                      (TestConfig -> TestConfig)
-> Either (IO ()) (TestConfig -> TestConfig)
forall a b. b -> Either a b
Right ((TestConfig -> TestConfig)
 -> Either (IO ()) (TestConfig -> TestConfig))
-> (TestConfig -> TestConfig)
-> Either (IO ()) (TestConfig -> TestConfig)
forall a b. (a -> b) -> a -> b
$ (PBTConfig -> PBTConfig) -> TestConfig -> TestConfig
changePBTConfig ((PBTConfig -> PBTConfig) -> TestConfig -> TestConfig)
-> (PBTConfig -> PBTConfig) -> TestConfig -> TestConfig
forall a b. (a -> b) -> a -> b
$ \PBTConfig
pbt -> PBTConfig
pbt {configMaxSize = n'}
                [(Int64, String)]
_ ->
                  IO () -> Either (IO ()) (TestConfig -> TestConfig)
forall a b. a -> Either a b
Left (IO () -> Either (IO ()) (TestConfig -> TestConfig))
-> (String -> IO ())
-> String
-> Either (IO ()) (TestConfig -> TestConfig)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO ()
optionsError (String -> Either (IO ()) (TestConfig -> TestConfig))
-> String -> Either (IO ()) (TestConfig -> TestConfig)
forall a b. (a -> b) -> a -> b
$ String
"'" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"' is not a non-negative integer."
          )
          String
"NUM"
      )
      (String -> FunOptDescr TestConfig)
-> String -> FunOptDescr TestConfig
forall a b. (a -> b) -> a -> b
$ String
"Maximum size parameter to use for generators (default: "
        String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int64 -> String
forall a. Show a => a -> String
show (PBTConfig -> Int64
configMaxSize (PBTConfig -> Int64)
-> (TestConfig -> PBTConfig) -> TestConfig -> Int64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TestConfig -> PBTConfig
configPBTConfig (TestConfig -> Int64) -> TestConfig -> Int64
forall a b. (a -> b) -> a -> b
$ TestConfig
defaultConfig)
        String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
").",
    String
-> [String]
-> ArgDescr (Either (IO ()) (TestConfig -> TestConfig))
-> String
-> FunOptDescr TestConfig
forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
Option
      []
      [String
"seed"]
      ( (String -> Either (IO ()) (TestConfig -> TestConfig))
-> String -> ArgDescr (Either (IO ()) (TestConfig -> TestConfig))
forall a. (String -> a) -> String -> ArgDescr a
ReqArg
          ( \String
n ->
              case (ReadS Word64
forall a. Read a => ReadS a
reads String
n :: [(Word64, String)]) of
                [(Word64
n', String
"")] ->
                  (TestConfig -> TestConfig)
-> Either (IO ()) (TestConfig -> TestConfig)
forall a b. b -> Either a b
Right ((TestConfig -> TestConfig)
 -> Either (IO ()) (TestConfig -> TestConfig))
-> (TestConfig -> TestConfig)
-> Either (IO ()) (TestConfig -> TestConfig)
forall a b. (a -> b) -> a -> b
$ (PBTConfig -> PBTConfig) -> TestConfig -> TestConfig
changePBTConfig ((PBTConfig -> PBTConfig) -> TestConfig -> TestConfig)
-> (PBTConfig -> PBTConfig) -> TestConfig -> TestConfig
forall a b. (a -> b) -> a -> b
$ \PBTConfig
pbt -> PBTConfig
pbt {configSeed = n'}
                [(Word64, String)]
_ ->
                  IO () -> Either (IO ()) (TestConfig -> TestConfig)
forall a b. a -> Either a b
Left (IO () -> Either (IO ()) (TestConfig -> TestConfig))
-> (String -> IO ())
-> String
-> Either (IO ()) (TestConfig -> TestConfig)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO ()
optionsError (String -> Either (IO ()) (TestConfig -> TestConfig))
-> String -> Either (IO ()) (TestConfig -> TestConfig)
forall a b. (a -> b) -> a -> b
$ String
"'" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"' is not a valid integer."
          )
          String
"NUM"
      )
      String
"Set seed for all tests to use for generators.",
    String
-> [String]
-> ArgDescr (Either (IO ()) (TestConfig -> TestConfig))
-> String
-> FunOptDescr TestConfig
forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
Option
      []
      [String
"num-tries"]
      ( (String -> Either (IO ()) (TestConfig -> TestConfig))
-> String -> ArgDescr (Either (IO ()) (TestConfig -> TestConfig))
forall a. (String -> a) -> String -> ArgDescr a
ReqArg
          ( \String
n ->
              case ReadS Int
forall a. Read a => ReadS a
reads String
n of
                [(Int
n', String
"")]
                  | Int
n' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
0 ->
                      (TestConfig -> TestConfig)
-> Either (IO ()) (TestConfig -> TestConfig)
forall a b. b -> Either a b
Right ((TestConfig -> TestConfig)
 -> Either (IO ()) (TestConfig -> TestConfig))
-> (TestConfig -> TestConfig)
-> Either (IO ()) (TestConfig -> TestConfig)
forall a b. (a -> b) -> a -> b
$ (PBTConfig -> PBTConfig) -> TestConfig -> TestConfig
changePBTConfig ((PBTConfig -> PBTConfig) -> TestConfig -> TestConfig)
-> (PBTConfig -> PBTConfig) -> TestConfig -> TestConfig
forall a b. (a -> b) -> a -> b
$ \PBTConfig
pbt -> PBTConfig
pbt {configShrinkTries = n'}
                [(Int, String)]
_ ->
                  IO () -> Either (IO ()) (TestConfig -> TestConfig)
forall a b. a -> Either a b
Left (IO () -> Either (IO ()) (TestConfig -> TestConfig))
-> (String -> IO ())
-> String
-> Either (IO ()) (TestConfig -> TestConfig)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO ()
optionsError (String -> Either (IO ()) (TestConfig -> TestConfig))
-> String -> Either (IO ()) (TestConfig -> TestConfig)
forall a b. (a -> b) -> a -> b
$ String
"'" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"' is not a non-negative integer."
          )
          String
"NUM"
      )
      (String -> FunOptDescr TestConfig)
-> String -> FunOptDescr TestConfig
forall a b. (a -> b) -> a -> b
$ String
"The number of tries the shrinker will perform before giving up (default: "
        String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show (PBTConfig -> Int
configShrinkTries (PBTConfig -> Int)
-> (TestConfig -> PBTConfig) -> TestConfig -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TestConfig -> PBTConfig
configPBTConfig (TestConfig -> Int) -> TestConfig -> Int
forall a b. (a -> b) -> a -> b
$ TestConfig
defaultConfig)
        String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
")."
  ]

excludeBackend :: TestConfig -> TestConfig
excludeBackend :: TestConfig -> TestConfig
excludeBackend TestConfig
config =
  TestConfig
config
    { configExclude =
        "no_" <> T.pack (configBackend (configPrograms config))
          : configExclude config
    }

selectRequestedPropSpecs :: [PropertyCase] -> [PropSpec] -> [PropSpec]
selectRequestedPropSpecs :: [PropertyCase] -> [PropSpec] -> [PropSpec]
selectRequestedPropSpecs [PropertyCase]
properties [PropSpec]
specs =
  (PropertyCase -> Maybe PropSpec) -> [PropertyCase] -> [PropSpec]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe PropertyCase -> Maybe PropSpec
lookupSpec [PropertyCase]
properties
  where
    lookupSpec :: PropertyCase -> Maybe PropSpec
lookupSpec (PropertyCase Text
name) =
      Text -> [PropSpec] -> Maybe PropSpec
firstMatching Text
name [PropSpec]
specs

    firstMatching :: Text -> [PropSpec] -> Maybe PropSpec
firstMatching Text
_ [] =
      Maybe PropSpec
forall a. Maybe a
Nothing
    firstMatching Text
name (PropSpec
spec : [PropSpec]
rest)
      | PropSpec -> Text
psProp PropSpec
spec Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
name = PropSpec -> Maybe PropSpec
forall a. a -> Maybe a
Just PropSpec
spec
      | Bool
otherwise = Text -> [PropSpec] -> Maybe PropSpec
firstMatching Text
name [PropSpec]
rest

-- Save to file helper functions
propToFile :: FilePath -> [TestResult] -> IO ()
propToFile :: String -> [TestResult] -> IO ()
propToFile String
testFile [TestResult]
results = do
  let fileName :: String
fileName = String -> String
dropExtension String
testFile String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
".prop_result"
      textResults :: Text
textResults = [Text] -> Text
T.unlines ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ (TestResult -> [Text]) -> [TestResult] -> [Text]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap TestResult -> [Text]
resultLines [TestResult]
results
  String -> IOMode -> (Handle -> IO ()) -> IO ()
forall r. String -> IOMode -> (Handle -> IO r) -> IO r
withFile String
fileName IOMode
WriteMode ((Handle -> IO ()) -> IO ()) -> (Handle -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Handle
h ->
    Handle -> Text -> IO ()
T.hPutStr Handle
h Text
textResults
  where
    resultLines :: TestResult -> [T.Text]
    resultLines :: TestResult -> [Text]
resultLines TestResult
Success = []
    resultLines (Failure [Text]
msgs) = [Text]
msgs

-- | Run @futhark test@.
main :: String -> [String] -> IO ()
main :: String -> [String] -> IO ()
main =
  TestConfig
-> [FunOptDescr TestConfig]
-> String
-> ([String] -> TestConfig -> Maybe (IO ()))
-> String
-> [String]
-> IO ()
forall cfg.
cfg
-> [FunOptDescr cfg]
-> String
-> ([String] -> cfg -> Maybe (IO ()))
-> String
-> [String]
-> IO ()
mainWithOptions TestConfig
defaultConfig [FunOptDescr TestConfig]
commandLineOptions String
"options... programs..." (([String] -> TestConfig -> Maybe (IO ()))
 -> String -> [String] -> IO ())
-> ([String] -> TestConfig -> Maybe (IO ()))
-> String
-> [String]
-> IO ()
forall a b. (a -> b) -> a -> b
$ \[String]
progs TestConfig
config ->
    case [String]
progs of
      [] -> Maybe (IO ())
forall a. Maybe a
Nothing
      [String]
_ -> IO () -> Maybe (IO ())
forall a. a -> Maybe a
Just (IO () -> Maybe (IO ())) -> IO () -> Maybe (IO ())
forall a b. (a -> b) -> a -> b
$ TestConfig -> [String] -> IO ()
runTests (TestConfig -> TestConfig
excludeBackend TestConfig
config) [String]
progs