{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}

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

import Control.Applicative.Lift (Errors, Lift (..), failure, runErrors)
import Control.Concurrent
import Control.Exception
import Control.Monad
import Control.Monad.Except hiding (throwError)
import qualified Control.Monad.Except as E
import qualified Data.ByteString as SBS
import qualified Data.ByteString.Lazy as LBS
import Data.List (delete, partition)
import qualified Data.Map.Strict as M
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import qualified Data.Text.IO as T
import Futhark.Analysis.Metrics
import Futhark.Test
import Futhark.Util (fancyTerminal)
import Futhark.Util.Console
import Futhark.Util.Options
import Futhark.Util.Pretty (prettyText)
import Futhark.Util.Table
import System.Console.ANSI
import System.Console.GetOpt
import qualified System.Console.Terminal.Size 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

type TestM = ExceptT [T.Text] IO

-- Taken from transformers-0.5.5.0.
eitherToErrors :: Either e a -> Errors e a
eitherToErrors :: 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 :: e -> m a
throwError e
e = [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 (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

io :: IO a -> TestM a
io :: IO a -> TestM a
io = IO a -> TestM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO

context :: T.Text -> TestM a -> TestM a
context :: Text -> TestM a -> TestM a
context Text
s = ([Text] -> [Text]) -> TestM a -> TestM a
forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT (([Text] -> [Text]) -> TestM a -> TestM a)
-> ([Text] -> [Text]) -> TestM a -> TestM 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'

accErrors :: [TestM a] -> TestM [a]
accErrors :: [TestM a] -> TestM [a]
accErrors [TestM a]
tests = do
  [Either [Text] a]
eithers <- IO [Either [Text] a] -> ExceptT [Text] IO [Either [Text] 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)
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 :: Lift (Constant [Text]) [a]
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)
traverse Either [Text] a -> Lift (Constant [Text]) a
forall e a. Either e a -> Errors e a
eitherToErrors [Either [Text] a]
eithers
  IO (Either [Text] [a]) -> TestM [a]
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (IO (Either [Text] [a]) -> TestM [a])
-> IO (Either [Text] [a]) -> TestM [a]
forall a b. (a -> b) -> a -> b
$ Either [Text] [a] -> IO (Either [Text] [a])
forall (m :: * -> *) a. Monad m => a -> m a
return (Either [Text] [a] -> IO (Either [Text] [a]))
-> Either [Text] [a] -> IO (Either [Text] [a])
forall a b. (a -> b) -> a -> b
$ Lift (Constant [Text]) [a] -> Either [Text] [a]
forall e a. Errors e a -> Either e a
runErrors Lift (Constant [Text]) [a]
errors

accErrors_ :: [TestM a] -> TestM ()
accErrors_ :: [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
/= :: TestResult -> TestResult -> Bool
$c/= :: TestResult -> TestResult -> Bool
== :: TestResult -> TestResult -> Bool
$c== :: TestResult -> TestResult -> Bool
Eq, Int -> TestResult -> ShowS
[TestResult] -> ShowS
TestResult -> String
(Int -> TestResult -> ShowS)
-> (TestResult -> String)
-> ([TestResult] -> ShowS)
-> Show TestResult
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TestResult] -> ShowS
$cshowList :: [TestResult] -> ShowS
show :: TestResult -> String
$cshow :: TestResult -> String
showsPrec :: Int -> TestResult -> ShowS
$cshowsPrec :: Int -> TestResult -> ShowS
Show)

data TestCase = TestCase
  { TestCase -> TestMode
_testCaseMode :: TestMode,
    TestCase -> String
testCaseProgram :: FilePath,
    TestCase -> ProgramTest
testCaseTest :: ProgramTest,
    TestCase -> ProgConfig
_testCasePrograms :: ProgConfig
  }
  deriving (Int -> TestCase -> ShowS
[TestCase] -> ShowS
TestCase -> String
(Int -> TestCase -> ShowS)
-> (TestCase -> String) -> ([TestCase] -> ShowS) -> Show TestCase
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TestCase] -> ShowS
$cshowList :: [TestCase] -> ShowS
show :: TestCase -> String
$cshow :: TestCase -> String
showsPrec :: Int -> TestCase -> ShowS
$cshowsPrec :: Int -> TestCase -> ShowS
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
  = ErrorResult Int SBS.ByteString
  | SuccessResult [Value]

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 b. Read b => String -> ExceptT [Text] IO b
check String
"-s"
    StructurePipeline
KernelsPipeline ->
      String -> TestM AstMetrics
forall b. Read b => String -> ExceptT [Text] IO b
check String
"--kernels"
    StructurePipeline
SequentialCpuPipeline ->
      String -> TestM AstMetrics
forall b. Read b => String -> ExceptT [Text] IO b
check String
"--cpu"
    StructurePipeline
GpuPipeline ->
      String -> TestM AstMetrics
forall b. Read b => String -> ExceptT [Text] IO b
check String
"--gpu"
  where
    check :: String -> ExceptT [Text] IO b
check String
opt = do
      String
futhark <- IO String -> TestM String
forall a. IO a -> TestM a
io (IO String -> TestM String) -> IO String -> TestM 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 (m :: * -> *) a. Monad m => a -> m a
return (Maybe String -> IO String) -> Maybe String -> IO String
forall a b. (a -> b) -> a -> b
$ ProgConfig -> Maybe String
configFuthark ProgConfig
programs
      (ExitCode
code, ByteString
output, ByteString
err) <-
        IO (ExitCode, ByteString, ByteString)
-> TestM (ExitCode, ByteString, ByteString)
forall a. IO a -> TestM a
io (IO (ExitCode, ByteString, ByteString)
 -> TestM (ExitCode, ByteString, ByteString))
-> IO (ExitCode, ByteString, ByteString)
-> TestM (ExitCode, ByteString, ByteString)
forall a b. (a -> b) -> a -> b
$ String
-> [String] -> ByteString -> IO (ExitCode, ByteString, ByteString)
readProcessWithExitCode String
futhark [String
"dev", String
opt, String
"--metrics", String
program] ByteString
""
      let output' :: Text
output' = ByteString -> Text
T.decodeUtf8 ByteString
output
      case ExitCode
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 -> ExceptT [Text] IO b
forall (m :: * -> *) a. Monad m => a -> m a
return b
m
          | Bool
otherwise -> Text -> ExceptT [Text] IO b
forall e (m :: * -> *) a. MonadError [e] m => e -> m a
throwError (Text -> ExceptT [Text] IO b) -> Text -> ExceptT [Text] IO 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 -> ExceptT [Text] IO b
forall e (m :: * -> *) a. MonadError [e] m => e -> m a
throwError (Text -> ExceptT [Text] IO b) -> Text -> ExceptT [Text] IO 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 -> ExceptT [Text] IO b
forall e (m :: * -> *) a. MonadError [e] m => e -> m a
throwError (Text -> ExceptT [Text] IO b) -> Text -> ExceptT [Text] IO 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
    AstMetrics
actual <- ProgConfig -> StructurePipeline -> String -> TestM AstMetrics
optimisedProgramMetrics ProgConfig
programs StructurePipeline
pipeline String
program
    [TestM ()] -> TestM ()
forall a. [TestM a] -> TestM ()
accErrors_ ([TestM ()] -> TestM ()) -> [TestM ()] -> TestM ()
forall a b. (a -> b) -> a -> b
$ ((Text, Int) -> TestM ()) -> [(Text, Int)] -> [TestM ()]
forall a b. (a -> b) -> [a] -> [b]
map (AstMetrics -> (Text, Int) -> TestM ()
forall (m :: * -> *).
MonadError [Text] m =>
AstMetrics -> (Text, Int) -> m ()
ok AstMetrics
actual) ([(Text, Int)] -> [TestM ()]) -> [(Text, Int)] -> [TestM ()]
forall a b. (a -> b) -> a -> b
$ Map Text Int -> [(Text, Int)]
forall k a. Map k a -> [(k, a)]
M.toList Map Text Int
expected
  where
    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
<> Text
" should have occurred " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (Int -> String
forall a. Show a => a -> String
show 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
<> Text
" should have occurred " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (Int -> String
forall a. Show a => a -> String
show 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
<> String -> Text
T.pack (Int -> String
forall a. Show a => a -> String
show Int
actual_occurences)
                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" times."
        Maybe Int
_ -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

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 (m :: * -> *) a. Monad m => a -> m a
return ()

runTestCase :: TestCase -> TestM ()
runTestCase :: TestCase -> TestM ()
runTestCase (TestCase TestMode
mode String
program ProgramTest
testcase ProgConfig
progs) = do
  String
futhark <- IO String -> TestM String
forall a. IO a -> TestM a
io (IO String -> TestM String) -> IO String -> TestM 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 (m :: * -> *) a. Monad m => a -> m a
return (Maybe String -> IO String) -> Maybe String -> IO String
forall a b. (a -> b) -> a -> b
$ ProgConfig -> Maybe String
configFuthark ProgConfig
progs
  case ProgramTest -> TestAction
testAction ProgramTest
testcase of
    CompileTimeFailure ExpectedError
expected_error ->
      Text -> TestM () -> TestM ()
forall a. Text -> TestM a -> TestM a
context
        ( [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
"'"
            ]
        )
        (TestM () -> TestM ()) -> TestM () -> TestM ()
forall a b. (a -> b) -> a -> b
$ do
          (ExitCode
code, ByteString
_, ByteString
err) <-
            IO (ExitCode, ByteString, ByteString)
-> TestM (ExitCode, ByteString, ByteString)
forall a. IO a -> TestM a
io (IO (ExitCode, ByteString, ByteString)
 -> TestM (ExitCode, ByteString, ByteString))
-> IO (ExitCode, ByteString, ByteString)
-> TestM (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 ExitCode
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
_ -> ExpectedError -> ByteString -> TestM ()
checkError ExpectedError
expected_error 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] -> 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
"'"
            ]
        )
        (TestM () -> TestM ()) -> TestM () -> TestM ()
forall a b. (a -> b) -> a -> b
$ do
          (ExitCode
code, ByteString
_, ByteString
err) <- IO (ExitCode, ByteString, ByteString)
-> TestM (ExitCode, ByteString, ByteString)
forall a. IO a -> TestM a
io (IO (ExitCode, ByteString, ByteString)
 -> TestM (ExitCode, ByteString, ByteString))
-> IO (ExitCode, ByteString, ByteString)
-> TestM (ExitCode, ByteString, ByteString)
forall a b. (a -> b) -> a -> b
$ String
-> [String] -> ByteString -> IO (ExitCode, ByteString, ByteString)
readProcessWithExitCode String
futhark [String]
options ByteString
""

          case ExitCode
code of
            ExitCode
ExitSuccess -> () -> TestM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
            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 -> do
      -- Compile up-front and reuse same executable for several entry points.
      let backend :: String
backend = ProgConfig -> String
configBackend ProgConfig
progs
          extra_options :: [String]
extra_options = ProgConfig -> [String]
configExtraCompilerOptions ProgConfig
progs
      Bool -> TestM () -> TestM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (TestMode
mode TestMode -> TestMode -> Bool
forall a. Eq a => a -> a -> Bool
== TestMode
Compile) (TestM () -> TestM ()) -> TestM () -> TestM ()
forall a b. (a -> b) -> a -> b
$
        Text -> TestM () -> TestM ()
forall a. Text -> TestM a -> TestM a
context Text
"Generating reference outputs" (TestM () -> TestM ()) -> TestM () -> TestM ()
forall a b. (a -> b) -> a -> b
$
          -- We probably get the concurrency at the test program level,
          -- so force just one data set at a time here.
          Maybe Int
-> String -> String -> String -> [InputOutputs] -> TestM ()
forall (m :: * -> *).
(MonadIO m, MonadError [Text] m) =>
Maybe Int -> String -> String -> String -> [InputOutputs] -> m ()
ensureReferenceOutput (Int -> Maybe Int
forall a. a -> Maybe a
Just Int
1) String
futhark String
"c" String
program [InputOutputs]
ios
      Bool -> TestM () -> TestM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (TestMode
mode TestMode -> TestMode -> Bool
forall a. Eq a => a -> a -> Bool
== TestMode
Interpreted) (TestM () -> TestM ()) -> TestM () -> TestM ()
forall a b. (a -> b) -> a -> b
$
        Text -> TestM () -> TestM ()
forall a. Text -> TestM a -> TestM a
context (Text
"Compiling with --backend=" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack String
backend) (TestM () -> TestM ()) -> TestM () -> TestM ()
forall a b. (a -> b) -> a -> b
$ do
          [String] -> String -> String -> String -> [WarningTest] -> TestM ()
compileTestProgram [String]
extra_options String
futhark String
backend String
program [WarningTest]
warnings
          (StructureTest -> TestM ()) -> [StructureTest] -> TestM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (ProgConfig -> String -> StructureTest -> TestM ()
testMetrics ProgConfig
progs String
program) [StructureTest]
structures
          Bool -> TestM () -> TestM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (TestMode
mode TestMode -> TestMode -> Bool
forall a. Eq a => a -> a -> Bool
== TestMode
Compile) (TestM () -> TestM ()) -> TestM () -> TestM ()
forall a b. (a -> b) -> a -> b
$ do
            ([String]
tuning_opts, String
_) <-
              IO ([String], String) -> ExceptT [Text] IO ([String], String)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ([String], String) -> ExceptT [Text] IO ([String], String))
-> IO ([String], String) -> ExceptT [Text] IO ([String], String)
forall a b. (a -> b) -> a -> b
$ Maybe String -> String -> IO ([String], String)
forall (m :: * -> *).
MonadIO m =>
Maybe String -> String -> m ([String], String)
determineTuning (ProgConfig -> Maybe String
configTuning ProgConfig
progs) String
program
            let progs' :: ProgConfig
progs' =
                  ProgConfig
progs
                    { configExtraOptions :: [String]
configExtraOptions =
                        [String]
tuning_opts [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ ProgConfig -> [String]
configExtraOptions ProgConfig
progs
                    }
            Text -> TestM () -> TestM ()
forall a. Text -> TestM a -> TestM a
context Text
"Running compiled program" (TestM () -> TestM ()) -> TestM () -> TestM ()
forall a b. (a -> b) -> a -> b
$
              [TestM ()] -> TestM ()
forall a. [TestM a] -> TestM ()
accErrors_ ([TestM ()] -> TestM ()) -> [TestM ()] -> TestM ()
forall a b. (a -> b) -> a -> b
$ (InputOutputs -> TestM ()) -> [InputOutputs] -> [TestM ()]
forall a b. (a -> b) -> [a] -> [b]
map (String -> ProgConfig -> InputOutputs -> TestM ()
runCompiledEntry String
program ProgConfig
progs') [InputOutputs]
ios
      Bool -> TestM () -> TestM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (TestMode
mode TestMode -> TestMode -> Bool
forall a. Eq a => a -> a -> Bool
== TestMode
Compile Bool -> Bool -> Bool
|| TestMode
mode TestMode -> TestMode -> Bool
forall a. Eq a => a -> a -> Bool
== TestMode
Compiled) (TestM () -> TestM ()) -> TestM () -> TestM ()
forall a b. (a -> b) -> a -> b
$
        Text -> TestM () -> TestM ()
forall a. Text -> TestM a -> TestM a
context Text
"Interpreting" (TestM () -> TestM ()) -> TestM () -> TestM ()
forall a b. (a -> b) -> a -> b
$
          [TestM ()] -> TestM ()
forall a. [TestM a] -> TestM ()
accErrors_ ([TestM ()] -> TestM ()) -> [TestM ()] -> TestM ()
forall a b. (a -> b) -> a -> b
$ (InputOutputs -> TestM ()) -> [InputOutputs] -> [TestM ()]
forall a b. (a -> b) -> [a] -> [b]
map (String -> String -> InputOutputs -> TestM ()
runInterpretedEntry String
futhark String
program) [InputOutputs]
ios

runInterpretedEntry :: String -> FilePath -> InputOutputs -> TestM ()
runInterpretedEntry :: String -> String -> InputOutputs -> TestM ()
runInterpretedEntry String
futhark String
program (InputOutputs Text
entry [TestRun]
run_cases) =
  let dir :: String
dir = ShowS
takeDirectory String
program
      runInterpretedCase :: TestRun -> TestM ()
runInterpretedCase run :: TestRun
run@(TestRun [String]
_ Values
inputValues ExpectedResult Success
_ Int
index String
_) =
        Bool -> TestM () -> TestM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (String
"compiled" String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` TestRun -> [String]
runTags TestRun
run) (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
<> String -> Text
T.pack (TestRun -> String
runDescription TestRun
run)
            )
            (TestM () -> TestM ()) -> TestM () -> TestM ()
forall a b. (a -> b) -> a -> b
$ do
              Text
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
forall a. Pretty a => a -> Text
prettyText ([Value] -> Text)
-> ExceptT [Text] IO [Value] -> ExceptT [Text] IO Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Values -> ExceptT [Text] IO [Value]
forall (m :: * -> *).
(MonadFail m, MonadIO m) =>
String -> Values -> m [Value]
getValues String
dir Values
inputValues
              ExpectedResult [Value]
expectedResult' <- String
-> Text -> TestRun -> ExceptT [Text] IO (ExpectedResult [Value])
forall (m :: * -> *).
(MonadFail m, MonadIO m) =>
String -> Text -> TestRun -> m (ExpectedResult [Value])
getExpectedResult String
program Text
entry TestRun
run
              (ExitCode
code, ByteString
output, ByteString
err) <-
                IO (ExitCode, ByteString, ByteString)
-> TestM (ExitCode, ByteString, ByteString)
forall a. IO a -> TestM a
io (IO (ExitCode, ByteString, ByteString)
 -> TestM (ExitCode, ByteString, ByteString))
-> IO (ExitCode, ByteString, ByteString)
-> TestM (ExitCode, ByteString, ByteString)
forall a b. (a -> b) -> a -> b
$
                  String
-> [String] -> ByteString -> IO (ExitCode, ByteString, ByteString)
readProcessWithExitCode String
futhark [String
"run", String
"-e", Text -> String
T.unpack Text
entry, String
program] (ByteString -> IO (ExitCode, ByteString, ByteString))
-> ByteString -> IO (ExitCode, ByteString, ByteString)
forall a b. (a -> b) -> a -> b
$
                    Text -> ByteString
T.encodeUtf8 Text
input
              case ExitCode
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
_ ->
                  Text
-> Int -> String -> ExpectedResult [Value] -> RunResult -> TestM ()
compareResult Text
entry Int
index String
program ExpectedResult [Value]
expectedResult'
                    (RunResult -> TestM ()) -> ExceptT [Text] IO RunResult -> TestM ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< String
-> ExitCode
-> ByteString
-> ByteString
-> ExceptT [Text] IO RunResult
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

runCompiledEntry :: FilePath -> ProgConfig -> InputOutputs -> TestM ()
runCompiledEntry :: String -> ProgConfig -> InputOutputs -> TestM ()
runCompiledEntry String
program ProgConfig
progs (InputOutputs Text
entry [TestRun]
run_cases) =
  -- Explicitly prefixing the current directory is necessary for
  -- readProcessWithExitCode to find the binary when binOutputf has
  -- no path component.
  let binOutputf :: String
binOutputf = ShowS
dropExtension String
program
      binpath :: String
binpath = String
"." String -> ShowS
</> String
binOutputf
      entry_options :: [String]
entry_options = [String
"-e", Text -> String
T.unpack Text
entry]

      runner :: String
runner = ProgConfig -> String
configRunner ProgConfig
progs
      extra_options :: [String]
extra_options = ProgConfig -> [String]
configExtraOptions ProgConfig
progs

      runCompiledCase :: TestRun -> TestM ()
runCompiledCase run :: TestRun
run@(TestRun [String]
_ Values
inputValues ExpectedResult Success
_ Int
index String
_) =
        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
<> String -> Text
T.pack (TestRun -> String
runDescription TestRun
run)
          )
          (TestM () -> TestM ()) -> TestM () -> TestM ()
forall a b. (a -> b) -> a -> b
$ do
            ExpectedResult [Value]
expected <- String
-> Text -> TestRun -> ExceptT [Text] IO (ExpectedResult [Value])
forall (m :: * -> *).
(MonadFail m, MonadIO m) =>
String -> Text -> TestRun -> m (ExpectedResult [Value])
getExpectedResult String
program Text
entry TestRun
run
            (ExitCode
progCode, ByteString
output, ByteString
progerr) <-
              String
-> [String]
-> String
-> Text
-> Values
-> TestM (ExitCode, ByteString, ByteString)
forall (m :: * -> *).
MonadIO m =>
String
-> [String]
-> String
-> Text
-> Values
-> m (ExitCode, ByteString, ByteString)
runProgram String
runner [String]
extra_options String
program Text
entry Values
inputValues
            Text
-> Int -> String -> ExpectedResult [Value] -> RunResult -> TestM ()
compareResult Text
entry Int
index String
program ExpectedResult [Value]
expected
              (RunResult -> TestM ()) -> ExceptT [Text] IO RunResult -> TestM ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< String
-> ExitCode
-> ByteString
-> ByteString
-> ExceptT [Text] IO RunResult
runResult String
program ExitCode
progCode ByteString
output ByteString
progerr
   in Text -> TestM () -> TestM ()
forall a. Text -> TestM a -> TestM a
context (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]
entry_options [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
extra_options)) (TestM () -> TestM ()) -> TestM () -> TestM ()
forall a b. (a -> b) -> a -> b
$
        [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 ()
runCompiledCase [TestRun]
run_cases

checkError :: ExpectedError -> SBS.ByteString -> TestM ()
checkError :: ExpectedError -> ByteString -> TestM ()
checkError (ThisError Text
regex_s Regex
regex) ByteString
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 -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ ByteString -> Text
T.decodeUtf8 ByteString
err) =
    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
"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
<> ByteString -> Text
T.decodeUtf8 ByteString
err
checkError ExpectedError
_ ByteString
_ =
  () -> TestM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

runResult :: FilePath -> ExitCode -> SBS.ByteString -> SBS.ByteString -> TestM RunResult
runResult :: String
-> ExitCode
-> ByteString
-> ByteString
-> ExceptT [Text] IO RunResult
runResult String
program ExitCode
ExitSuccess ByteString
stdout_s ByteString
_ =
  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 -> ShowS
`addExtension` String
"actual"
      IO () -> TestM ()
forall a. IO a -> TestM a
io (IO () -> TestM ()) -> IO () -> TestM ()
forall a b. (a -> b) -> a -> b
$ String -> ByteString -> IO ()
SBS.writeFile String
actualf ByteString
stdout_s
      Text -> ExceptT [Text] IO RunResult
forall e (m :: * -> *) a. MonadError [e] m => e -> m a
throwError (Text -> ExceptT [Text] IO RunResult)
-> Text -> ExceptT [Text] IO RunResult
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 -> RunResult -> ExceptT [Text] IO RunResult
forall (m :: * -> *) a. Monad m => a -> m a
return (RunResult -> ExceptT [Text] IO RunResult)
-> RunResult -> ExceptT [Text] IO RunResult
forall a b. (a -> b) -> a -> b
$ [Value] -> RunResult
SuccessResult [Value]
vs
runResult String
_ (ExitFailure Int
code) ByteString
_ ByteString
stderr_s =
  RunResult -> ExceptT [Text] IO RunResult
forall (m :: * -> *) a. Monad m => a -> m a
return (RunResult -> ExceptT [Text] IO RunResult)
-> RunResult -> ExceptT [Text] IO RunResult
forall a b. (a -> b) -> a -> b
$ Int -> ByteString -> RunResult
ErrorResult Int
code ByteString
stderr_s

compileTestProgram :: [String] -> FilePath -> String -> FilePath -> [WarningTest] -> TestM ()
compileTestProgram :: [String] -> String -> String -> String -> [WarningTest] -> TestM ()
compileTestProgram [String]
extra_options String
futhark String
backend String
program [WarningTest]
warnings = do
  (ByteString
_, ByteString
futerr) <- [String]
-> String
-> String
-> String
-> ExceptT [Text] IO (ByteString, ByteString)
forall (m :: * -> *).
(MonadIO m, MonadError [Text] m) =>
[String]
-> String -> String -> String -> m (ByteString, ByteString)
compileProgram [String]
extra_options String
futhark String
backend String
program
  [WarningTest] -> ByteString -> TestM ()
testWarnings [WarningTest]
warnings ByteString
futerr

compareResult ::
  T.Text ->
  Int ->
  FilePath ->
  ExpectedResult [Value] ->
  RunResult ->
  TestM ()
compareResult :: Text
-> Int -> String -> ExpectedResult [Value] -> RunResult -> TestM ()
compareResult Text
_ Int
_ String
_ (Succeeds Maybe [Value]
Nothing) SuccessResult {} =
  () -> TestM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
compareResult Text
entry Int
index String
program (Succeeds (Just [Value]
expectedResult)) (SuccessResult [Value]
actualResult) =
  case [Value] -> [Value] -> Maybe Mismatch
compareValues1 [Value]
actualResult [Value]
expectedResult of
    Just Mismatch
mismatch -> do
      let actualf :: String
actualf = String
program String -> ShowS
<.> Text -> String
T.unpack Text
entry String -> ShowS
<.> Int -> String
forall a. Show a => a -> String
show Int
index String -> ShowS
<.> String
"actual"
          expectedf :: String
expectedf = String
program String -> ShowS
<.> Text -> String
T.unpack Text
entry String -> ShowS
<.> Int -> String
forall a. Show a => a -> String
show Int
index String -> ShowS
<.> String
"expected"
      IO () -> TestM ()
forall a. IO a -> TestM a
io (IO () -> TestM ()) -> IO () -> TestM ()
forall a b. (a -> b) -> a -> b
$
        String -> ByteString -> IO ()
SBS.writeFile String
actualf (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$
          Text -> ByteString
T.encodeUtf8 (Text -> ByteString) -> Text -> ByteString
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.unlines ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ (Value -> Text) -> [Value] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Value -> Text
forall a. Pretty a => a -> Text
prettyText [Value]
actualResult
      IO () -> TestM ()
forall a. IO a -> TestM a
io (IO () -> TestM ()) -> IO () -> TestM ()
forall a b. (a -> b) -> a -> b
$
        String -> ByteString -> IO ()
SBS.writeFile String
expectedf (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$
          Text -> ByteString
T.encodeUtf8 (Text -> ByteString) -> Text -> ByteString
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.unlines ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ (Value -> Text) -> [Value] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Value -> Text
forall a. Pretty a => a -> Text
prettyText [Value]
expectedResult
      Text -> TestM ()
forall e (m :: * -> *) a. MonadError [e] m => e -> m a
throwError (Text -> TestM ()) -> Text -> TestM ()
forall a b. (a -> b) -> a -> b
$
        String -> Text
T.pack String
actualf Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" and " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack String
expectedf
          Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" do not match:\n"
          Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (Mismatch -> String
forall a. Show a => a -> String
show Mismatch
mismatch)
          Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\n"
    Maybe Mismatch
Nothing ->
      () -> TestM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
compareResult Text
_ Int
_ String
_ (RunTimeFailure ExpectedError
expectedError) (ErrorResult Int
_ ByteString
actualError) =
  ExpectedError -> ByteString -> TestM ()
checkError ExpectedError
expectedError ByteString
actualError
compareResult Text
_ Int
_ String
_ (Succeeds Maybe [Value]
_) (ErrorResult Int
code ByteString
err) =
  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
"Program failed with error code "
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (Int -> String
forall a. Show a => a -> String
show Int
code)
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" and stderr:\n  "
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ByteString -> Text
T.decodeUtf8 ByteString
err
compareResult Text
_ Int
_ String
_ (RunTimeFailure ExpectedError
f) (SuccessResult [Value]
_) =
  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
"Program succeeded, but expected failure:\n  " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (ExpectedError -> String
forall a. Show a => a -> String
show 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 (m :: * -> *) a. Monad m => a -> m a
return (TestResult -> IO TestResult) -> TestResult -> IO TestResult
forall a b. (a -> b) -> a -> b
$ [Text] -> TestResult
Failure [String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ SomeException -> String
forall a. Show a => a -> String
show 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) =
  TestMode -> String -> ProgramTest -> ProgConfig -> TestCase
TestCase TestMode
mode String
file ProgramTest
spec (ProgConfig -> TestCase) -> ProgConfig -> TestCase
forall a b. (a -> b) -> a -> b
$ TestConfig -> ProgConfig
configPrograms 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
  TestCase
test <- MVar TestCase -> IO TestCase
forall a. MVar a -> IO a
takeMVar MVar TestCase
testmvar
  MVar ReportMsg -> ReportMsg -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar ReportMsg
resmvar (ReportMsg -> IO ()) -> ReportMsg -> IO ()
forall a b. (a -> b) -> a -> b
$ TestCase -> ReportMsg
TestStarted TestCase
test
  TestResult
res <- TestCase -> IO TestResult
doTest TestCase
test
  MVar ReportMsg -> ReportMsg -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar ReportMsg
resmvar (ReportMsg -> IO ()) -> ReportMsg -> IO ()
forall a b. (a -> b) -> a -> b
$ TestCase -> TestResult -> ReportMsg
TestDone TestCase
test TestResult
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 (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.
excludeCases :: TestConfig -> TestCase -> TestCase
excludeCases :: TestConfig -> TestCase -> TestCase
excludeCases TestConfig
config TestCase
tcase =
  TestCase
tcase {testCaseTest :: ProgramTest
testCaseTest = ProgramTest -> ProgramTest
onTest (ProgramTest -> ProgramTest) -> ProgramTest -> ProgramTest
forall a b. (a -> b) -> a -> b
$ TestCase -> ProgramTest
testCaseTest TestCase
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) =
      [InputOutputs] -> [StructureTest] -> [WarningTest] -> TestAction
RunCases ((InputOutputs -> InputOutputs) -> [InputOutputs] -> [InputOutputs]
forall a b. (a -> b) -> [a] -> [b]
map InputOutputs -> InputOutputs
onIOs [InputOutputs]
ios) [StructureTest]
stest [WarningTest]
wtest
    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
. (String -> Bool) -> [String] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any String -> Bool
excluded ([String] -> Bool) -> (TestRun -> [String]) -> TestRun -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TestRun -> [String]
runTags) [TestRun]
runs
    excluded :: String -> Bool
excluded = (Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` TestConfig -> [Text]
configExclude TestConfig
config) (Text -> Bool) -> (String -> Text) -> String -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack

statusTable :: TestStatus -> String
statusTable :: TestStatus -> String
statusTable TestStatus
ts = [[Entry]] -> Int -> String
buildTable [[Entry]]
rows Int
1
  where
    rows :: [[Entry]]
rows =
      [ [String -> Entry
mkEntry String
"", Entry
passed, Entry
failed, String -> Entry
mkEntry String
"remaining"],
        (String -> Entry) -> [String] -> [Entry]
forall a b. (a -> b) -> [a] -> [b]
map String -> Entry
mkEntry [String
"programs", String
passedProgs, String
failedProgs, String
remainProgs'],
        (String -> Entry) -> [String] -> [Entry]
forall a b. (a -> b) -> [a] -> [b]
map String -> Entry
mkEntry [String
"runs", String
passedRuns, String
failedRuns, String
remainRuns']
      ]
    passed :: Entry
passed = (String
"passed", [ConsoleLayer -> ColorIntensity -> Color -> SGR
SetColor ConsoleLayer
Foreground ColorIntensity
Vivid Color
Green])
    failed :: Entry
failed = (String
"failed", [ConsoleLayer -> ColorIntensity -> Color -> SGR
SetColor ConsoleLayer
Foreground ColorIntensity
Vivid 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 (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 -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"/" String -> ShowS
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 -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"/" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
totalRuns

tableLines :: Int
tableLines :: Int
tableLines = Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ ([String] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([String] -> Int) -> (String -> [String]) -> String -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
lines (String -> Int) -> String -> Int
forall a b. (a -> b) -> a -> b
$ String
blankTable)
  where
    blankTable :: String
blankTable = TestStatus -> String
statusTable (TestStatus -> String) -> TestStatus -> String
forall a b. (a -> b) -> a -> b
$ [TestCase]
-> [TestCase]
-> Int
-> Int
-> Int
-> Int
-> Int
-> Int
-> Int
-> TestStatus
TestStatus [] [] Int
0 Int
0 Int
0 Int
0 Int
0 Int
0 Int
0

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
  String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ TestStatus -> String
statusTable TestStatus
ts
  IO ()
clearLine
  Int
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
  String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> ShowS
atMostChars (Int
w Int -> Int -> Int
forall a. Num a => a -> a -> a
- String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
labelstr) String
running
  where
    running :: String
running = String
labelstr String -> ShowS
forall a. [a] -> [a] -> [a]
++ ([String] -> String
unwords ([String] -> String)
-> (TestStatus -> [String]) -> TestStatus -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> [String]
forall a. [a] -> [a]
reverse ([String] -> [String])
-> (TestStatus -> [String]) -> TestStatus -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TestCase -> String) -> [TestCase] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map TestCase -> String
testCaseProgram ([TestCase] -> [String])
-> (TestStatus -> [TestCase]) -> TestStatus -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TestStatus -> [TestCase]
testStatusRun) TestStatus
ts
    labelstr :: String
labelstr = String
"Now testing: "

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

atMostChars :: Int -> String -> String
atMostChars :: Int -> ShowS
atMostChars Int
n String
s
  | String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
s Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
n = Int -> ShowS
forall a. Int -> [a] -> [a]
take (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
-Int
3) String
s String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"..."
  | Bool
otherwise = String
s

reportText :: TestStatus -> IO ()
reportText :: TestStatus -> IO ()
reportText TestStatus
ts =
  String -> IO ()
putStr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
    String
"(" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (TestStatus -> Int
testStatusFail TestStatus
ts) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" failed, "
      String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (TestStatus -> Int
testStatusPass TestStatus
ts)
      String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" passed, "
      String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
num_remain
      String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" to go).\n"
  where
    num_remain :: Int
num_remain = [TestCase] -> 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

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
  [TestCase]
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
  MVar TestCase
testmvar <- IO (MVar TestCase)
forall a. IO (MVar a)
newEmptyMVar
  MVar ReportMsg
reportmvar <- IO (MVar ReportMsg)
forall a. IO (MVar a)
newEmptyMVar
  Int
concurrency <- IO Int -> (Int -> IO Int) -> Maybe Int -> IO Int
forall b a. b -> (a -> b) -> Maybe a -> b
maybe IO Int
getNumCapabilities Int -> IO Int
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Int -> IO Int) -> Maybe Int -> IO Int
forall a b. (a -> b) -> a -> b
$ TestConfig -> Maybe Int
configConcurrency TestConfig
config
  Int -> IO ThreadId -> IO ()
forall (m :: * -> *) a. Applicative m => Int -> m a -> m ()
replicateM_ Int
concurrency (IO ThreadId -> IO ()) -> IO ThreadId -> IO ()
forall a b. (a -> b) -> a -> b
$ IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ MVar TestCase -> MVar ReportMsg -> IO ()
runTest MVar TestCase
testmvar MVar ReportMsg
reportmvar

  let ([TestCase]
excluded, [TestCase]
included) = (TestCase -> Bool) -> [TestCase] -> ([TestCase], [TestCase])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (TestConfig -> TestCase -> Bool
excludedTest TestConfig
config) [TestCase]
all_tests
  ThreadId
_ <- IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ (TestCase -> IO ()) -> [TestCase] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (MVar TestCase -> TestCase -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar TestCase
testmvar (TestCase -> IO ()) -> (TestCase -> TestCase) -> TestCase -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TestConfig -> TestCase -> TestCase
excludeCases TestConfig
config) [TestCase]
included

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

      report :: TestStatus -> IO ()
report
        | Bool
fancy = TestStatus -> IO ()
reportTable
        | Bool
otherwise = TestStatus -> IO ()
reportText
      clear :: IO ()
clear
        | Bool
fancy = IO ()
clearFromCursorToScreenEnd
        | Bool
otherwise = String -> IO ()
putStr String
"\n"

      numTestCases :: TestCase -> Int
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 ->
            ([TestRun] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([TestRun] -> Int)
-> ([[TestRun]] -> [TestRun]) -> [[TestRun]] -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[TestRun]] -> [TestRun]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat) (InputOutputs -> [TestRun]
iosTestRuns (InputOutputs -> [TestRun]) -> [InputOutputs] -> [[TestRun]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [InputOutputs]
ios)
              Int -> Int -> Int
forall a. Num a => a -> a -> a
+ [StructureTest] -> 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 (t :: * -> *) a. Foldable t => t a -> Int
length [WarningTest]
wts

      getResults :: TestStatus -> IO TestStatus
getResults TestStatus
ts
        | [TestCase] -> 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 (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> TestStatus -> IO TestStatus
forall (m :: * -> *) a. Monad m => a -> m a
return TestStatus
ts
        | Bool
otherwise = do
          TestStatus -> IO ()
report TestStatus
ts
          ReportMsg
msg <- MVar ReportMsg -> IO ReportMsg
forall a. MVar a -> IO a
takeMVar MVar ReportMsg
reportmvar
          case ReportMsg
msg of
            TestStarted TestCase
test -> do
              Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
fancy (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
                String -> IO ()
putStr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Started testing " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> TestCase -> String
testCaseProgram TestCase
test String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" "
              TestStatus -> IO TestStatus
getResults (TestStatus -> IO TestStatus) -> TestStatus -> IO TestStatus
forall a b. (a -> b) -> a -> b
$ TestStatus
ts {testStatusRun :: [TestCase]
testStatusRun = TestCase
test TestCase -> [TestCase] -> [TestCase]
forall a. a -> [a] -> [a]
: TestStatus -> [TestCase]
testStatusRun TestStatus
ts}
            TestDone TestCase
test TestResult
res -> do
              let ts' :: TestStatus
ts' =
                    TestStatus
ts
                      { testStatusRemain :: [TestCase]
testStatusRemain = TestCase
test TestCase -> [TestCase] -> [TestCase]
forall a. Eq a => a -> [a] -> [a]
`delete` TestStatus -> [TestCase]
testStatusRemain TestStatus
ts,
                        testStatusRun :: [TestCase]
testStatusRun = TestCase
test TestCase -> [TestCase] -> [TestCase]
forall a. Eq a => a -> [a] -> [a]
`delete` TestStatus -> [TestCase]
testStatusRun TestStatus
ts,
                        testStatusRunsRemain :: Int
testStatusRunsRemain =
                          TestStatus -> Int
testStatusRunsRemain TestStatus
ts
                            Int -> Int -> Int
forall a. Num a => a -> a -> a
- TestCase -> Int
numTestCases TestCase
test
                      }
              case TestResult
res of
                TestResult
Success -> do
                  let ts'' :: TestStatus
ts'' =
                        TestStatus
ts'
                          { testStatusRunPass :: Int
testStatusRunPass =
                              TestStatus -> Int
testStatusRunPass TestStatus
ts' Int -> Int -> Int
forall a. Num a => a -> a -> a
+ TestCase -> Int
numTestCases TestCase
test
                          }
                  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
fancy (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
                    String -> IO ()
putStr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Finished testing " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> TestCase -> String
testCaseProgram TestCase
test String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" "
                  TestStatus -> IO TestStatus
getResults (TestStatus -> IO TestStatus) -> TestStatus -> IO TestStatus
forall a b. (a -> b) -> a -> b
$ TestStatus
ts'' {testStatusPass :: Int
testStatusPass = TestStatus -> Int
testStatusPass TestStatus
ts Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1}
                Failure [Text]
s -> do
                  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
fancy IO ()
moveCursorToTableTop
                  IO ()
clear
                  Text -> IO ()
T.putStr (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ (String -> Text
T.pack (ShowS
inRed ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ TestCase -> String
testCaseProgram TestCase
test) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
":\n") Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
T.unlines [Text]
s
                  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 :: Int
testStatusFail = TestStatus -> Int
testStatusFail TestStatus
ts' Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1,
                        testStatusRunPass :: Int
testStatusRunPass =
                          TestStatus -> Int
testStatusRunPass TestStatus
ts'
                            Int -> Int -> Int
forall a. Num a => a -> a -> a
+ TestCase -> Int
numTestCases TestCase
test Int -> Int -> Int
forall a. Num a => a -> a -> a
- [Text] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Text]
s,
                        testStatusRunFail :: Int
testStatusRunFail =
                          TestStatus -> Int
testStatusRunFail TestStatus
ts'
                            Int -> Int -> Int
forall a. Num a => a -> a -> a
+ [Text] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Text]
s
                      }

  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
fancy IO ()
spaceTable

  TestStatus
ts <-
    TestStatus -> IO TestStatus
getResults
      TestStatus :: [TestCase]
-> [TestCase]
-> Int
-> Int
-> Int
-> Int
-> Int
-> Int
-> Int
-> TestStatus
TestStatus
        { testStatusRemain :: [TestCase]
testStatusRemain = [TestCase]
included,
          testStatusRun :: [TestCase]
testStatusRun = [],
          testStatusTotal :: Int
testStatusTotal = [TestCase] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [TestCase]
included,
          testStatusFail :: Int
testStatusFail = Int
0,
          testStatusPass :: Int
testStatusPass = Int
0,
          testStatusRuns :: Int
testStatusRuns = [Int] -> Int
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ([Int] -> Int) -> [Int] -> Int
forall a b. (a -> b) -> a -> b
$ (TestCase -> Int) -> [TestCase] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map TestCase -> Int
numTestCases [TestCase]
included,
          testStatusRunsRemain :: Int
testStatusRunsRemain = [Int] -> Int
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ([Int] -> Int) -> [Int] -> Int
forall a b. (a -> b) -> a -> b
$ (TestCase -> Int) -> [TestCase] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map TestCase -> Int
numTestCases [TestCase]
included,
          testStatusRunPass :: Int
testStatusRunPass = Int
0,
          testStatusRunFail :: Int
testStatusRunFail = Int
0
        }

  -- Removes "Now testing" output.
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
fancy (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> IO ()
cursorUpLine Int
1 IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
clearLine

  let excluded_str :: String
excluded_str
        | [TestCase] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TestCase]
excluded = String
""
        | Bool
otherwise = String
" (" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show ([TestCase] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [TestCase]
excluded) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" program(s) excluded).\n"
  String -> IO ()
putStr String
excluded_str
  ExitCode -> IO ()
forall a. ExitCode -> IO a
exitWith (ExitCode -> IO ()) -> ExitCode -> IO ()
forall a b. (a -> b) -> a -> b
$ case TestStatus -> Int
testStatusFail TestStatus
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
  }

defaultConfig :: TestConfig
defaultConfig :: TestConfig
defaultConfig =
  TestConfig :: TestMode -> ProgConfig -> [Text] -> Bool -> Maybe Int -> TestConfig
TestConfig
    { configTestMode :: TestMode
configTestMode = TestMode
Everything,
      configExclude :: [Text]
configExclude = [Text
"disable"],
      configPrograms :: ProgConfig
configPrograms =
        ProgConfig :: String
-> Maybe String
-> String
-> [String]
-> Maybe String
-> [String]
-> ProgConfig
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"
          },
      configLineOutput :: Bool
configLineOutput = Bool
False,
      configConcurrency :: Maybe Int
configConcurrency = Maybe Int
forall a. Maybe a
Nothing
    }

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,
    -- | Extra options passed to the programs being run.
    ProgConfig -> [String]
configExtraOptions :: [String]
  }
  deriving (Int -> ProgConfig -> ShowS
[ProgConfig] -> ShowS
ProgConfig -> String
(Int -> ProgConfig -> ShowS)
-> (ProgConfig -> String)
-> ([ProgConfig] -> ShowS)
-> Show ProgConfig
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ProgConfig] -> ShowS
$cshowList :: [ProgConfig] -> ShowS
show :: ProgConfig -> String
$cshow :: ProgConfig -> String
showsPrec :: Int -> ProgConfig -> ShowS
$cshowsPrec :: Int -> ProgConfig -> ShowS
Show)

changeProgConfig :: (ProgConfig -> ProgConfig) -> TestConfig -> TestConfig
changeProgConfig :: (ProgConfig -> ProgConfig) -> TestConfig -> TestConfig
changeProgConfig ProgConfig -> ProgConfig
f TestConfig
config = TestConfig
config {configPrograms :: ProgConfig
configPrograms = ProgConfig -> ProgConfig
f (ProgConfig -> ProgConfig) -> ProgConfig -> ProgConfig
forall a b. (a -> b) -> a -> b
$ TestConfig -> ProgConfig
configPrograms TestConfig
config}

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

setFuthark :: FilePath -> ProgConfig -> ProgConfig
setFuthark :: String -> ProgConfig -> ProgConfig
setFuthark String
futhark ProgConfig
config =
  ProgConfig
config {configFuthark :: Maybe String
configFuthark = String -> Maybe String
forall a. a -> Maybe a
Just String
futhark}

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

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

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

data TestMode
  = TypeCheck
  | Compile
  | Compiled
  | Interpreted
  | Everything
  deriving (TestMode -> TestMode -> Bool
(TestMode -> TestMode -> Bool)
-> (TestMode -> TestMode -> Bool) -> Eq TestMode
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TestMode -> TestMode -> Bool
$c/= :: TestMode -> TestMode -> Bool
== :: TestMode -> TestMode -> Bool
$c== :: TestMode -> TestMode -> Bool
Eq, Int -> TestMode -> ShowS
[TestMode] -> ShowS
TestMode -> String
(Int -> TestMode -> ShowS)
-> (TestMode -> String) -> ([TestMode] -> ShowS) -> Show TestMode
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TestMode] -> ShowS
$cshowList :: [TestMode] -> ShowS
show :: TestMode -> String
$cshow :: TestMode -> String
showsPrec :: Int -> TestMode -> ShowS
$cshowsPrec :: Int -> TestMode -> ShowS
Show)

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 :: TestMode
configTestMode = TestMode
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 :: TestMode
configTestMode = TestMode
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
"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 :: TestMode
configTestMode = TestMode
Compiled})
      String
"Only run compiled code",
    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 :: TestMode
configTestMode = TestMode
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
"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 :: Bool
configLineOutput = Bool
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 :: [Text]
configExclude = String -> Text
T.pack String
tag Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: TestConfig -> [Text]
configExclude TestConfig
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
"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 :: Maybe String
configTuning = Maybe String
forall a. Maybe a
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
"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 :: Maybe Int
configConcurrency = Int -> Maybe Int
forall a. a -> Maybe a
Just Int
n'}
                [(Int, String)]
_ ->
                  IO () -> Either (IO ()) (TestConfig -> TestConfig)
forall a b. a -> Either a b
Left (IO () -> Either (IO ()) (TestConfig -> TestConfig))
-> IO () -> Either (IO ()) (TestConfig -> TestConfig)
forall a b. (a -> b) -> a -> b
$ String -> IO ()
forall a. HasCallStack => String -> a
error (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"'" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
n String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"' is not a positive integer."
          )
          String
"NUM"
      )
      String
"Number of tests to run concurrently."
  ]

-- | 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 ->
  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
config [String]
progs