{-# LANGUAGE LambdaCase #-}
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 (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.List (delete, partition)
import Data.Map.Strict qualified as M
import Data.Text qualified as T
import Data.Text.Encoding qualified as T
import Data.Text.IO qualified as T
import Futhark.Analysis.Metrics.Type
import Futhark.Server
import Futhark.Test
import Futhark.Util (atMostChars, fancyTerminal, 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
type TestM = ExceptT [T.Text] IO
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
[Either [Text] a]
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 :: 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)
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
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 a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (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_ :: 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 -> 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
$cshowsPrec :: Int -> TestResult -> ShowS
showsPrec :: Int -> TestResult -> ShowS
$cshow :: TestResult -> String
show :: TestResult -> String
$cshowList :: [TestResult] -> ShowS
showList :: [TestResult] -> ShowS
Show)
pureTestResults :: IO [TestResult] -> TestM ()
pureTestResults :: IO [TestResult] -> TestM ()
pureTestResults IO [TestResult]
m = do
[[Text]]
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
Bool -> TestM () -> TestM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([[Text]] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [[Text]]
errs) (TestM () -> TestM ()) -> TestM () -> TestM ()
forall a b. (a -> b) -> a -> b
$ [Text] -> TestM ()
forall a. [Text] -> ExceptT [Text] IO a
forall e (m :: * -> *) a. MonadError e m => e -> m a
E.throwError ([Text] -> TestM ()) -> [Text] -> TestM ()
forall a b. (a -> b) -> a -> b
$ [[Text]] -> [Text]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Text]]
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
withProgramServer :: FilePath -> FilePath -> [String] -> (Server -> IO [TestResult]) -> TestM ()
withProgramServer :: String
-> String -> [String] -> (Server -> IO [TestResult]) -> TestM ()
withProgramServer String
program String
runner [String]
extra_options Server -> IO [TestResult]
f = do
let binOutputf :: String
binOutputf = ShowS
dropExtension String
program
binpath :: String
binpath = String
"." String -> ShowS
</> 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 ()) -> TestM () -> TestM ()
forall a b. (a -> b) -> a -> b
$
IO [TestResult] -> TestM ()
pureTestResults (IO [TestResult] -> TestM ()) -> IO [TestResult] -> TestM ()
forall a b. (a -> b) -> a -> b
$
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
$
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]
f
data TestMode
=
TypeCheck
|
Compile
|
Internalise
|
Compiled
|
Interpreted
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 -> 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
$cshowsPrec :: Int -> TestMode -> ShowS
showsPrec :: Int -> TestMode -> ShowS
$cshow :: TestMode -> String
show :: TestMode -> String
$cshowList :: [TestMode] -> ShowS
showList :: [TestMode] -> 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
$cshowsPrec :: Int -> TestCase -> ShowS
showsPrec :: Int -> TestCase -> ShowS
$cshow :: TestCase -> String
show :: TestCase -> String
$cshowList :: [TestCase] -> ShowS
showList :: [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 T.Text
| 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 {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
String
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]
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]
(ExitCode
code, ByteString
output, ByteString
err) <- IO (ExitCode, ByteString, ByteString)
-> m (ExitCode, ByteString, ByteString)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (ExitCode, ByteString, ByteString)
-> m (ExitCode, ByteString, ByteString))
-> IO (ExitCode, ByteString, ByteString)
-> m (ExitCode, ByteString, ByteString)
forall a b. (a -> b) -> a -> b
$ String
-> [String] -> ByteString -> IO (ExitCode, ByteString, ByteString)
readProcessWithExitCode String
futhark [String]
opts 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 -> 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
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
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 = ShowS
takeDirectory String
program
runInterpretedCase :: TestRun -> TestM ()
runInterpretedCase run :: TestRun
run@(TestRun [String]
_ Values
inputValues ExpectedResult Success
_ Int
index Text
_) =
Bool -> TestM () -> TestM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ((String -> Bool) -> [String] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (String -> [String] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` TestRun -> [String]
runTags TestRun
run) [String
"compiled", String
"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
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
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 [Value]
expectedResult' <- FutharkExe
-> String
-> Text
-> TestRun
-> ExceptT [Text] IO (ExpectedResult [Value])
forall (m :: * -> *).
(MonadFail m, MonadIO m) =>
FutharkExe
-> String -> Text -> TestRun -> m (ExpectedResult [Value])
getExpectedResult (String -> FutharkExe
FutharkExe String
futhark) String
program Text
entry TestRun
run
(ExitCode
code, ByteString
output, ByteString
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
"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
_ ->
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 ()
forall (m :: * -> *).
(MonadIO m, MonadError Text m) =>
Text
-> Int -> String -> ExpectedResult [Value] -> RunResult -> m ()
compareResult Text
entry Int
index String
program ExpectedResult [Value]
expectedResult'
(RunResult -> ExceptT Text IO ())
-> ExceptT Text IO RunResult -> ExceptT Text IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< String
-> ExitCode
-> ByteString
-> ByteString
-> ExceptT Text IO RunResult
forall (m :: * -> *).
(MonadIO m, MonadError Text m) =>
String -> ExitCode -> ByteString -> ByteString -> m 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
runTestCase :: TestCase -> TestM ()
runTestCase :: TestCase -> TestM ()
runTestCase (TestCase TestMode
mode String
program ProgramTest
testcase ProgConfig
progs) = do
String
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
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 ProgramTest -> TestAction
testAction ProgramTest
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
== 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
(ExitCode
code, ByteString
_, ByteString
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 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
_ -> 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
(ExitCode
code, ByteString
_, ByteString
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 ExitCode
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
(ExitCode
code, ByteString
_, ByteString
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 ExitCode
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 -> do
let backend :: String
backend = ProgConfig -> String
configBackend ProgConfig
progs
extra_compiler_options :: [String]
extra_compiler_options = ProgConfig -> [String]
configExtraCompilerOptions ProgConfig
progs
Bool -> TestM () -> TestM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (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
Compiled, 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
"Generating reference outputs" (TestM () -> TestM ()) -> TestM () -> TestM ()
forall a b. (a -> b) -> a -> b
$
Maybe Int
-> FutharkExe -> String -> String -> [InputOutputs] -> TestM ()
forall (m :: * -> *).
(MonadIO m, MonadError [Text] m) =>
Maybe Int
-> FutharkExe -> String -> String -> [InputOutputs] -> m ()
ensureReferenceOutput (Int -> Maybe Int
forall a. a -> Maybe a
Just Int
1) (String -> FutharkExe
FutharkExe String
futhark) String
"c" String
program [InputOutputs]
ios
Bool -> TestM () -> TestM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (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
Compile, 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
"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]
-> FutharkExe -> String -> String -> [WarningTest] -> TestM ()
compileTestProgram [String]
extra_compiler_options (String -> FutharkExe
FutharkExe 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 a. IO a -> ExceptT [Text] IO a
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 extra_options :: [String]
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 :: String
runner = ProgConfig -> String
configRunner 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
$
String
-> String -> [String] -> (Server -> IO [TestResult]) -> TestM ()
withProgramServer String
program String
runner [String]
extra_options ((Server -> IO [TestResult]) -> TestM ())
-> (Server -> IO [TestResult]) -> TestM ()
forall a b. (a -> b) -> a -> b
$ \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
[[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
Bool -> TestM () -> TestM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (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
"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 (FutharkExe -> String -> InputOutputs -> TestM ()
runInterpretedEntry (String -> FutharkExe
FutharkExe String
futhark) String
program) [InputOutputs]
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
Maybe CmdFailure
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 Maybe CmdFailure
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
Either CmdFailure [OutputType]
output_types <- Server -> Text -> IO (Either CmdFailure [OutputType])
cmdOutputs Server
server Text
entry
Either CmdFailure [InputType]
input_types <- Server -> Text -> IO (Either CmdFailure [InputType])
cmdInputs Server
server Text
entry
case (,) ([OutputType] -> [InputType] -> ([OutputType], [InputType]))
-> Either CmdFailure [OutputType]
-> Either CmdFailure ([InputType] -> ([OutputType], [InputType]))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Either CmdFailure [OutputType]
output_types Either CmdFailure ([InputType] -> ([OutputType], [InputType]))
-> Either CmdFailure [InputType]
-> Either CmdFailure ([OutputType], [InputType])
forall a b.
Either CmdFailure (a -> b)
-> Either CmdFailure a -> Either CmdFailure b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Either CmdFailure [InputType]
input_types 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 ([OutputType]
output_types', [InputType]
input_types') -> do
let outs :: [Text]
outs = [Text
"out" 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 .. [OutputType] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [OutputType]
output_types' Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1]]
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] -> TestRun -> IO (Either Text ())
forall {m :: * -> *}.
(MonadFail m, MonadIO m) =>
[InputType] -> [Text] -> [Text] -> TestRun -> m (Either Text ())
runCompiledCase [InputType]
input_types' [Text]
outs [Text]
ins) [TestRun]
run_cases
where
dir :: String
dir = ShowS
takeDirectory String
program
runCompiledCase :: [InputType] -> [Text] -> [Text] -> TestRun -> m (Either Text ())
runCompiledCase [InputType]
input_types [Text]
outs [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 [String]
_ 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
ExpectedResult [Value]
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
Server
-> [(Text, Text)]
-> FutharkExe
-> String
-> Values
-> ExceptT Text m ()
forall (m :: * -> *).
(MonadError Text m, MonadIO m) =>
Server -> [(Text, Text)] -> FutharkExe -> String -> Values -> m ()
valuesAsVars Server
server ([Text] -> [Text] -> [(Text, Text)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Text]
ins ((InputType -> Text) -> [InputType] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map InputType -> Text
inputType [InputType]
input_types)) FutharkExe
futhark String
dir Values
input_spec
Either CmdFailure [Text]
call_r <- IO (Either CmdFailure [Text])
-> ExceptT Text m (Either CmdFailure [Text])
forall a. IO a -> ExceptT Text m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either CmdFailure [Text])
-> ExceptT Text m (Either CmdFailure [Text]))
-> IO (Either CmdFailure [Text])
-> ExceptT Text m (Either CmdFailure [Text])
forall a b. (a -> b) -> a -> b
$ Server -> Text -> [Text] -> [Text] -> IO (Either CmdFailure [Text])
cmdCall Server
server Text
entry [Text]
outs [Text]
ins
IO (Maybe CmdFailure) -> ExceptT Text m ()
forall (m :: * -> *).
(MonadError Text m, MonadIO m) =>
IO (Maybe CmdFailure) -> m ()
liftCommand (IO (Maybe CmdFailure) -> ExceptT Text m ())
-> IO (Maybe CmdFailure) -> ExceptT Text m ()
forall a b. (a -> b) -> a -> b
$ Server -> [Text] -> IO (Maybe CmdFailure)
cmdFree Server
server [Text]
ins
RunResult
res <- case Either CmdFailure [Text]
call_r of
Left (CmdFailure [Text]
_ [Text]
err) ->
RunResult -> ExceptT Text m RunResult
forall a. a -> ExceptT Text m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RunResult -> ExceptT Text m RunResult)
-> RunResult -> ExceptT Text m RunResult
forall a b. (a -> b) -> a -> b
$ Text -> RunResult
ErrorResult (Text -> RunResult) -> Text -> RunResult
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.unlines [Text]
err
Right [Text]
_ ->
[Value] -> RunResult
SuccessResult
([Value] -> RunResult)
-> ExceptT Text m [Value] -> ExceptT Text m RunResult
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Server -> [Text] -> ExceptT Text m [Value]
forall (m :: * -> *).
(MonadIO m, MonadError Text m) =>
Server -> [Text] -> m [Value]
readResults Server
server [Text]
outs
ExceptT Text m RunResult
-> ExceptT Text m () -> ExceptT Text m RunResult
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]
outs)
Text
-> Int
-> String
-> ExpectedResult [Value]
-> RunResult
-> ExceptT Text m ()
forall (m :: * -> *).
(MonadIO m, MonadError Text m) =>
Text
-> Int -> String -> ExpectedResult [Value] -> RunResult -> m ()
compareResult Text
entry Int
index String
program ExpectedResult [Value]
expected RunResult
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]
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 ->
m RunResult
runResult :: forall (m :: * -> *).
(MonadIO m, MonadError Text m) =>
String -> ExitCode -> ByteString -> ByteString -> m 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 () -> 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 RunResult
forall a. Text -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
E.throwError (Text -> m RunResult) -> Text -> m 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 -> m RunResult
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RunResult -> m RunResult) -> RunResult -> m RunResult
forall a b. (a -> b) -> a -> b
$ [Value] -> RunResult
SuccessResult [Value]
vs
runResult String
_ (ExitFailure Int
_) ByteString
_ ByteString
stderr_s =
RunResult -> m RunResult
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RunResult -> m RunResult) -> RunResult -> m RunResult
forall a b. (a -> b) -> a -> b
$ Text -> RunResult
ErrorResult (Text -> RunResult) -> Text -> RunResult
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
(ByteString
_, ByteString
futerr) <- [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
[WarningTest] -> ByteString -> TestM ()
testWarnings [WarningTest]
warnings ByteString
futerr
compareResult ::
(MonadIO m, MonadError T.Text m) =>
T.Text ->
Int ->
FilePath ->
ExpectedResult [Value] ->
RunResult ->
m ()
compareResult :: forall (m :: * -> *).
(MonadIO m, MonadError Text m) =>
Text
-> Int -> String -> ExpectedResult [Value] -> RunResult -> m ()
compareResult Text
_ Int
_ String
_ (Succeeds Maybe [Value]
Nothing) SuccessResult {} =
() -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
compareResult Text
entry Int
index String
program (Succeeds (Just [Value]
expected_vs)) (SuccessResult [Value]
actual_vs) =
String -> [Value] -> [Value] -> m ()
forall (m :: * -> *).
(MonadError Text m, MonadIO m) =>
String -> [Value] -> [Value] -> m ()
checkResult
(String
program String -> ShowS
<.> Text -> String
T.unpack Text
entry String -> ShowS
<.> Int -> String
forall a. Show a => a -> String
show Int
index)
[Value]
expected_vs
[Value]
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 [Value]
_) =
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
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) =
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 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
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) =
[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 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) -> (String -> Text) -> String -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack
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 -> 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
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
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
Text -> IO ()
T.putStrLn (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> Text -> Text
atMostChars (Int
w Int -> Int -> Int
forall a. Num a => a -> a -> a
- Text -> Int
T.length Text
labelstr) Text
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: "
moveCursorToTableTop :: IO ()
moveCursorToTableTop :: IO ()
moveCursorToTableTop = Int -> IO ()
cursorUpLine Int
tableLines
runTests :: TestConfig -> [FilePath] -> IO ()
runTests :: TestConfig -> [String] -> IO ()
runTests TestConfig
config [String]
paths = do
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 a. a -> IO a
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 = IO () -> TestStatus -> IO ()
forall a b. a -> b -> a
const (() -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
clear :: IO ()
clear
| Bool
fancy = IO ()
clearFromCursorToScreenEnd
| Bool
otherwise = () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
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 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
getResults :: TestStatus -> IO TestStatus
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
ReportMsg
msg <- MVar ReportMsg -> IO ReportMsg
forall a. MVar a -> IO a
takeMVar MVar ReportMsg
reportmvar
case ReportMsg
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'
+ numTestCases test
- length s,
testStatusRunFail =
testStatusRunFail ts'
+ length s
}
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
fancy IO ()
spaceTable
TestStatus
ts <-
TestStatus -> IO TestStatus
getResults
TestStatus
{ testStatusRemain :: [TestCase]
testStatusRemain = [TestCase]
included,
testStatusRun :: [TestCase]
testStatusRun = [],
testStatusTotal :: Int
testStatusTotal = [TestCase] -> Int
forall a. [a] -> 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 a. Num a => [a] -> a
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 a. Num a => [a] -> a
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
}
if Bool
fancy
then Int -> IO ()
cursorUpLine Int
1 IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
clearLine
else String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> String
forall a. Show a => a -> String
show (TestStatus -> Int
testStatusPass TestStatus
ts) String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"/" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show (TestStatus -> Int
testStatusTotal TestStatus
ts) String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" passed."
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([TestCase] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TestCase]
excluded) (IO () -> IO ()) -> (String -> IO ()) -> String -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
Int -> String
forall a. Show a => a -> String
show ([TestCase] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [TestCase]
excluded) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" program(s) excluded."
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
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
{ configTestMode :: TestMode
configTestMode = TestMode
Compiled,
configExclude :: [Text]
configExclude = [Text
"disable"],
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
}
data ProgConfig = ProgConfig
{ ProgConfig -> String
configBackend :: String,
ProgConfig -> Maybe String
configFuthark :: Maybe FilePath,
ProgConfig -> String
configRunner :: FilePath,
:: [String],
ProgConfig -> Maybe String
configTuning :: Maybe String,
ProgConfig -> Maybe String
configCacheExt :: Maybe String,
:: [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
$cshowsPrec :: Int -> ProgConfig -> ShowS
showsPrec :: Int -> ProgConfig -> ShowS
$cshow :: ProgConfig -> String
show :: ProgConfig -> String
$cshowList :: [ProgConfig] -> ShowS
showList :: [ProgConfig] -> ShowS
Show)
changeProgConfig :: (ProgConfig -> ProgConfig) -> TestConfig -> TestConfig
changeProgConfig :: (ProgConfig -> ProgConfig) -> TestConfig -> TestConfig
changeProgConfig ProgConfig -> ProgConfig
f TestConfig
config = TestConfig
config {configPrograms = f $ configPrograms 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
"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
"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
"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 -> 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."
]
excludeBackend :: TestConfig -> TestConfig
excludeBackend :: TestConfig -> TestConfig
excludeBackend TestConfig
config =
TestConfig
config
{ configExclude =
"no_" <> T.pack (configBackend (configPrograms config))
: configExclude config
}
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