{-# LANGUAGE LambdaCase #-}

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

import Control.Applicative.Lift (Errors, Lift (..), failure, runErrors)
import Control.Concurrent
import Control.Exception
import Control.Monad
import Control.Monad.Except (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

--- Test execution

type TestM = ExceptT [T.Text] IO

-- Taken from transformers-0.5.5.0.
eitherToErrors :: Either e a -> Errors e a
eitherToErrors :: forall e a. Either e a -> Errors e a
eitherToErrors = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall e a. e -> Errors e a
failure 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 = forall e (m :: * -> *) a. MonadError e m => e -> m a
E.throwError [e
e]

runTestM :: TestM () -> IO TestResult
runTestM :: TestM () -> IO TestResult
runTestM = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either [Text] -> TestResult
Failure forall a b. (a -> b) -> a -> b
$ forall a b. a -> b -> a
const TestResult
Success) forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall e (m :: * -> *) a. MonadError e m => e -> m a
E.throwError forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Applicative f => a -> f a
pure) forall (f :: * -> *) a. Applicative f => a -> f a
pure forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 = forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT forall a b. (a -> b) -> a -> b
$
  \case
    [] -> []
    (Text
e : [Text]
es') -> (Text
s forall a. Semigroup a => a -> a -> a
<> Text
":\n" forall a. Semigroup a => a -> a -> a
<> Text
e) 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 = forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT forall a b. (a -> b) -> a -> b
$ \Text
e -> Text
s forall a. Semigroup a => a -> a -> a
<> Text
":\n" 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 <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT [TestM a]
tests
  let errors :: Lift (Constant [Text]) [a]
errors = forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall e a. Either e a -> Errors e a
eitherToErrors [Either [Text] a]
eithers
  forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ 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_ = forall (f :: * -> *) a. Functor f => f a -> f ()
void forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [TestM a] -> TestM [a]
accErrors

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

pureTestResults :: IO [TestResult] -> TestM ()
pureTestResults :: IO [TestResult] -> TestM ()
pureTestResults IO [TestResult]
m = do
  [[Text]]
errs <- forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr TestResult -> [[Text]] -> [[Text]]
collectErrors forall a. Monoid a => a
mempty forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO [TestResult]
m
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [[Text]]
errs) forall a b. (a -> b) -> a -> b
$ forall e (m :: * -> *) a. MonadError e m => e -> m a
E.throwError forall a b. (a -> b) -> a -> b
$ 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 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
  -- Explicitly prefixing the current directory is necessary for
  -- readProcessWithExitCode to find the binary when binOutputf has
  -- no path component.
  let binOutputf :: String
binOutputf = ShowS
dropExtension String
program
      binpath :: String
binpath = String
"." String -> ShowS
</> String
binOutputf

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

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

  forall a. Text -> TestM a -> TestM a
context Text
prog_ctx forall a b. (a -> b) -> a -> b
$
    IO [TestResult] -> TestM ()
pureTestResults forall a b. (a -> b) -> a -> b
$
      forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$
        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
  = -- | Only type check.
    TypeCheck
  | -- | Only compile (do not run).
    Compile
  | -- | Only internalise (do not run).
    Internalise
  | -- | Test compiled code.
    Compiled
  | -- | Test interpreted code.
    Interpreted
  deriving (TestMode -> TestMode -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TestMode -> TestMode -> Bool
$c/= :: TestMode -> TestMode -> Bool
== :: TestMode -> TestMode -> Bool
$c== :: TestMode -> TestMode -> Bool
Eq, Int -> TestMode -> ShowS
[TestMode] -> ShowS
TestMode -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TestMode] -> ShowS
$cshowList :: [TestMode] -> ShowS
show :: TestMode -> String
$cshow :: TestMode -> String
showsPrec :: Int -> TestMode -> ShowS
$cshowsPrec :: Int -> TestMode -> ShowS
Show)

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
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TestCase] -> ShowS
$cshowList :: [TestCase] -> ShowS
show :: TestCase -> String
$cshow :: TestCase -> String
showsPrec :: Int -> TestCase -> ShowS
$cshowsPrec :: Int -> TestCase -> ShowS
Show)

instance Eq TestCase where
  TestCase
x == :: TestCase -> TestCase -> Bool
== TestCase
y = TestCase -> String
testCaseProgram TestCase
x 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 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 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 ->
      forall {m :: * -> *} {b}.
(MonadIO m, Read b, MonadError [Text] m) =>
[String] -> m b
check [String
"-s"]
    StructurePipeline
GpuPipeline ->
      forall {m :: * -> *} {b}.
(MonadIO m, Read b, MonadError [Text] m) =>
[String] -> m b
check [String
"--gpu"]
    StructurePipeline
MCPipeline ->
      forall {m :: * -> *} {b}.
(MonadIO m, Read b, MonadError [Text] m) =>
[String] -> m b
check [String
"--mc"]
    StructurePipeline
SeqMemPipeline ->
      forall {m :: * -> *} {b}.
(MonadIO m, Read b, MonadError [Text] m) =>
[String] -> m b
check [String
"--seq-mem"]
    StructurePipeline
GpuMemPipeline ->
      forall {m :: * -> *} {b}.
(MonadIO m, Read b, MonadError [Text] m) =>
[String] -> m b
check [String
"--gpu-mem"]
    StructurePipeline
MCMemPipeline ->
      forall {m :: * -> *} {b}.
(MonadIO m, Read b, MonadError [Text] m) =>
[String] -> m b
check [String
"--mc-mem"]
    StructurePipeline
NoPipeline ->
      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 <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall b a. b -> (a -> b) -> Maybe a -> b
maybe IO String
getExecutablePath forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ ProgConfig -> Maybe String
configFuthark ProgConfig
programs
      let opts :: [String]
opts = [String
"dev"] forall a. [a] -> [a] -> [a]
++ [String]
opt forall a. [a] -> [a] -> [a]
++ [String
"--metrics", String
program]
      (ExitCode
code, ByteString
output, ByteString
err) <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO 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, [])] <- forall a. Read a => ReadS a
reads forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
output' -> forall (f :: * -> *) a. Applicative f => a -> f a
pure b
m
          | Bool
otherwise -> forall e (m :: * -> *) a. MonadError [e] m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ Text
"Could not read metrics output:\n" forall a. Semigroup a => a -> a -> a
<> Text
output'
        ExitFailure Int
127 -> forall e (m :: * -> *) a. MonadError [e] m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ Text -> Text
progNotFound forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack String
futhark
        ExitFailure Int
_ -> forall e (m :: * -> *) a. MonadError [e] m => e -> m a
throwError 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)) =
  forall a. Text -> TestM a -> TestM a
context Text
"Checking metrics" forall a b. (a -> b) -> a -> b
$ do
    AstMetrics
actual <- ProgConfig -> StructurePipeline -> String -> TestM AstMetrics
optimisedProgramMetrics ProgConfig
programs StructurePipeline
pipeline String
program
    forall a. [TestM a] -> TestM ()
accErrors_ forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall {m :: * -> *}.
MonadError [Text] m =>
AstMetrics -> (Text, Int) -> m ()
ok AstMetrics
actual) forall a b. (a -> b) -> a -> b
$ 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 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 forall a. Ord a => a -> a -> Bool
> Int
0 ->
              forall e (m :: * -> *) a. MonadError [e] m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$
                Text
name
                  forall a. Semigroup a => a -> a -> a
<> StructurePipeline -> Text
maybePipeline StructurePipeline
pipeline
                  forall a. Semigroup a => a -> a -> a
<> Text
" should have occurred "
                  forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showText Int
expected_occurences
                  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 forall a. Eq a => a -> a -> Bool
/= Int
actual_occurences ->
              forall e (m :: * -> *) a. MonadError [e] m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$
                Text
name
                  forall a. Semigroup a => a -> a -> a
<> StructurePipeline -> Text
maybePipeline StructurePipeline
pipeline
                  forall a. Semigroup a => a -> a -> a
<> Text
" should have occurred "
                  forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showText Int
expected_occurences
                  forall a. Semigroup a => a -> a -> a
<> Text
" times, but occurred "
                  forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showText Int
actual_occurences
                  forall a. Semigroup a => a -> a -> a
<> Text
" times."
        Maybe Int
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

testWarnings :: [WarningTest] -> SBS.ByteString -> TestM ()
testWarnings :: [WarningTest] -> ByteString -> TestM ()
testWarnings [WarningTest]
warnings ByteString
futerr = forall a. [TestM a] -> TestM ()
accErrors_ forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall {m :: * -> *}. MonadError [Text] m => WarningTest -> m ()
testWarning [WarningTest]
warnings
  where
    testWarning :: WarningTest -> m ()
testWarning (ExpectedWarning Text
regex_s Regex
regex)
      | Bool -> Bool
not (forall regex source target.
RegexContext regex source target =>
regex -> source -> target
match Regex
regex forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack forall a b. (a -> b) -> a -> b
$ ByteString -> Text
T.decodeUtf8 ByteString
futerr) =
          forall e (m :: * -> *) a. MonadError [e] m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$
            Text
"Expected warning:\n  "
              forall a. Semigroup a => a -> a -> a
<> Text
regex_s
              forall a. Semigroup a => a -> a -> a
<> Text
"\nGot warnings:\n  "
              forall a. Semigroup a => a -> a -> a
<> ByteString -> Text
T.decodeUtf8 ByteString
futerr
      | Bool
otherwise = 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
_) =
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` TestRun -> [String]
runTags TestRun
run) [String
"compiled", String
"script"]) forall a b. (a -> b) -> a -> b
$
          forall a. Text -> TestM a -> TestM a
context (Text
"Entry point: " forall a. Semigroup a => a -> a -> a
<> Text
entry forall a. Semigroup a => a -> a -> a
<> Text
"; dataset: " forall a. Semigroup a => a -> a -> a
<> TestRun -> Text
runDescription TestRun
run) forall a b. (a -> b) -> a -> b
$ do
            Text
input <- [Text] -> Text
T.unlines forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map Value -> Text
valueText forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *).
(MonadFail m, MonadIO m) =>
FutharkExe -> String -> Values -> m [Value]
getValues (String -> FutharkExe
FutharkExe String
futhark) String
dir Values
inputValues
            ExpectedResult [Value]
expectedResult' <- 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) <-
              forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO 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] forall a b. (a -> b) -> a -> b
$
                  Text -> ByteString
T.encodeUtf8 Text
input
            case ExitCode
code of
              ExitFailure Int
127 ->
                forall e (m :: * -> *) a. MonadError [e] m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ Text -> Text
progNotFound forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack String
futhark
              ExitCode
_ ->
                forall a. ExceptT Text IO a -> TestM a
liftExcept forall a b. (a -> b) -> a -> b
$
                  forall (m :: * -> *).
(MonadIO m, MonadError Text m) =>
Text
-> Int -> String -> ExpectedResult [Value] -> RunResult -> m ()
compareResult Text
entry Int
index String
program ExpectedResult [Value]
expectedResult'
                    forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *).
(MonadIO m, MonadError Text m) =>
String -> ExitCode -> ByteString -> ByteString -> m RunResult
runResult String
program ExitCode
code ByteString
output ByteString
err
   in forall a. [TestM a] -> TestM ()
accErrors_ forall a b. (a -> b) -> a -> b
$ 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 <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall b a. b -> (a -> b) -> Maybe a -> b
maybe IO String
getExecutablePath forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ ProgConfig -> Maybe String
configFuthark ProgConfig
progs
  let checkctx :: Text
checkctx =
        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 ->
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (TestMode
mode forall a. Eq a => a -> a -> Bool
== TestMode
Internalise) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Text -> TestM a -> TestM a
context Text
checkctx forall a b. (a -> b) -> a -> b
$ do
        (ExitCode
code, ByteString
_, ByteString
err) <-
          forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO 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 -> forall e (m :: * -> *) a. MonadError [e] m => e -> m a
throwError Text
"Expected failure\n"
          ExitFailure Int
127 -> forall e (m :: * -> *) a. MonadError [e] m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ Text -> Text
progNotFound forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack String
futhark
          ExitFailure Int
1 -> forall e (m :: * -> *) a. MonadError [e] m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ ByteString -> Text
T.decodeUtf8 ByteString
err
          ExitFailure Int
_ -> forall a. ExceptT Text IO a -> TestM a
liftExcept forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
MonadError Text m =>
ExpectedError -> Text -> m ()
checkError ExpectedError
expected_error forall a b. (a -> b) -> a -> b
$ ByteString -> Text
T.decodeUtf8 ByteString
err
    RunCases {}
      | TestMode
mode forall a. Eq a => a -> a -> Bool
== TestMode
TypeCheck -> do
          let options :: [String]
options = [String
"check", String
program] forall a. [a] -> [a] -> [a]
++ ProgConfig -> [String]
configExtraCompilerOptions ProgConfig
progs
          forall a. Text -> TestM a -> TestM a
context Text
checkctx forall a b. (a -> b) -> a -> b
$ do
            (ExitCode
code, ByteString
_, ByteString
err) <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO 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 -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
              ExitFailure Int
127 -> forall e (m :: * -> *) a. MonadError [e] m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ Text -> Text
progNotFound forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack String
futhark
              ExitFailure Int
_ -> forall e (m :: * -> *) a. MonadError [e] m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ ByteString -> Text
T.decodeUtf8 ByteString
err
      | TestMode
mode forall a. Eq a => a -> a -> Bool
== TestMode
Internalise -> do
          let options :: [String]
options = [String
"dev", String
program] forall a. [a] -> [a] -> [a]
++ ProgConfig -> [String]
configExtraCompilerOptions ProgConfig
progs
          forall a. Text -> TestM a -> TestM a
context Text
checkctx forall a b. (a -> b) -> a -> b
$ do
            (ExitCode
code, ByteString
_, ByteString
err) <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO 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 -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
              ExitFailure Int
127 -> forall e (m :: * -> *) a. MonadError [e] m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ Text -> Text
progNotFound forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack String
futhark
              ExitFailure Int
_ -> forall e (m :: * -> *) a. MonadError [e] m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ ByteString -> Text
T.decodeUtf8 ByteString
err
    RunCases [InputOutputs]
ios [StructureTest]
structures [WarningTest]
warnings -> do
      -- Compile up-front and reuse same executable for several entry points.
      let backend :: String
backend = ProgConfig -> String
configBackend ProgConfig
progs
          extra_compiler_options :: [String]
extra_compiler_options = ProgConfig -> [String]
configExtraCompilerOptions ProgConfig
progs

      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (TestMode
mode forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [TestMode
Compiled, TestMode
Interpreted]) forall a b. (a -> b) -> a -> b
$
        forall a. Text -> TestM a -> TestM a
context Text
"Generating reference outputs" forall a b. (a -> b) -> a -> b
$
          -- We probably get the concurrency at the test program level,
          -- so force just one data set at a time here.
          forall (m :: * -> *).
(MonadIO m, MonadError [Text] m) =>
Maybe Int
-> FutharkExe -> String -> String -> [InputOutputs] -> m ()
ensureReferenceOutput (forall a. a -> Maybe a
Just Int
1) (String -> FutharkExe
FutharkExe String
futhark) String
"c" String
program [InputOutputs]
ios

      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (TestMode
mode forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [TestMode
Compile, TestMode
Compiled]) forall a b. (a -> b) -> a -> b
$
        forall a. Text -> TestM a -> TestM a
context (Text
"Compiling with --backend=" forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack String
backend) 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
          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
          forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (TestMode
mode forall a. Eq a => a -> a -> Bool
== TestMode
Compile) forall a b. (a -> b) -> a -> b
$ do
            ([String]
tuning_opts, String
_) <-
              forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ 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
                    forall a. [a] -> [a] -> [a]
++ [String]
tuning_opts
                    forall a. [a] -> [a] -> [a]
++ ProgConfig -> [String]
configExtraOptions ProgConfig
progs
                runner :: String
runner = ProgConfig -> String
configRunner ProgConfig
progs
            forall a. Text -> TestM a -> TestM a
context Text
"Running compiled program" forall a b. (a -> b) -> a -> b
$
              String
-> String -> [String] -> (Server -> IO [TestResult]) -> TestM ()
withProgramServer String
program String
runner [String]
extra_options 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
                forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM InputOutputs -> IO [TestResult]
run [InputOutputs]
ios

      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (TestMode
mode forall a. Eq a => a -> a -> Bool
== TestMode
Interpreted) forall a b. (a -> b) -> a -> b
$
        forall a. Text -> TestM a -> TestM a
context Text
"Interpreting" forall a b. (a -> b) -> a -> b
$
          forall a. [TestM a] -> TestM ()
accErrors_ forall a b. (a -> b) -> a -> b
$
            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 <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO (Maybe CmdFailure)
m
  case Maybe CmdFailure
r of
    Just (CmdFailure [Text]
_ [Text]
err) -> forall e (m :: * -> *) a. MonadError e m => e -> m a
E.throwError forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.unlines [Text]
err
    Maybe CmdFailure
Nothing -> 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 (,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Either CmdFailure [OutputType]
output_types forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Either CmdFailure [InputType]
input_types of
    Left (CmdFailure [Text]
_ [Text]
err) ->
      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" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showText Int
i | Int
i <- [Int
0 .. forall (t :: * -> *) a. Foldable t => t a -> Int
length [OutputType]
output_types' forall a. Num a => a -> a -> a
- Int
1]]
          ins :: [Text]
ins = [Text
"in" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showText Int
i | Int
i <- [Int
0 .. forall (t :: * -> *) a. Foldable t => t a -> Int
length [InputType]
input_types' forall a. Num a => a -> a -> a
- Int
1]]
          onRes :: Either Text b -> TestResult
onRes = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ([Text] -> TestResult
Failure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Applicative f => a -> f a
pure) (forall a b. a -> b -> a
const TestResult
Success)
      forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall {b}. Either Text b -> TestResult
onRes forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 = forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT 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: "
              forall a. Semigroup a => a -> a -> a
<> Text
entry
              forall a. Semigroup a => a -> a -> a
<> Text
"; dataset: "
              forall a. Semigroup a => a -> a -> a
<> TestRun -> Text
runDescription TestRun
run

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

        forall (m :: * -> *).
(MonadError Text m, MonadIO m) =>
Server -> [(Text, Text)] -> FutharkExe -> String -> Values -> m ()
valuesAsVars Server
server (forall a b. [a] -> [b] -> [(a, b)]
zip [Text]
ins (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 <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Server -> Text -> [Text] -> [Text] -> IO (Either CmdFailure [Text])
cmdCall Server
server Text
entry [Text]
outs [Text]
ins
        forall (m :: * -> *).
(MonadError Text m, MonadIO m) =>
IO (Maybe CmdFailure) -> m ()
liftCommand 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) ->
            forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Text -> RunResult
ErrorResult forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.unlines [Text]
err
          Right [Text]
_ ->
            [Value] -> RunResult
SuccessResult
              forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *).
(MonadIO m, MonadError Text m) =>
Server -> [Text] -> m [Value]
readResults Server
server [Text]
outs
              forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall (m :: * -> *).
(MonadError Text m, MonadIO m) =>
IO (Maybe CmdFailure) -> m ()
liftCommand (Server -> [Text] -> IO (Maybe CmdFailure)
cmdFree Server
server [Text]
outs)

        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 (forall regex source target.
RegexContext regex source target =>
regex -> source -> target
match Regex
regex forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
err) =
      forall e (m :: * -> *) a. MonadError e m => e -> m a
E.throwError forall a b. (a -> b) -> a -> b
$
        Text
"Expected error:\n  "
          forall a. Semigroup a => a -> a -> a
<> Text
regex_s
          forall a. Semigroup a => a -> a -> a
<> Text
"\nGot error:\n"
          forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
T.unlines (forall a b. (a -> b) -> [a] -> [b]
map (Text
"  " <>) (Text -> [Text]
T.lines Text
err))
checkError ExpectedError
_ Text
_ =
  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" 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"
      forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ String -> ByteString -> IO ()
SBS.writeFile String
actualf ByteString
stdout_s
      forall e (m :: * -> *) a. MonadError e m => e -> m a
E.throwError forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack String
e forall a. Semigroup a => a -> a -> a
<> Text
"\n(See " forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack String
actualf forall a. Semigroup a => a -> a -> a
<> Text
")"
    Right [Value]
vs -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ [Value] -> RunResult
SuccessResult [Value]
vs
runResult String
_ (ExitFailure Int
_) ByteString
_ ByteString
stderr_s =
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Text -> RunResult
ErrorResult 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) <- forall (m :: * -> *).
(MonadIO m, MonadError [Text] m) =>
[String]
-> FutharkExe -> String -> String -> m (ByteString, ByteString)
compileProgram (String
"--server" 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 {} =
  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) =
  forall (m :: * -> *).
(MonadError Text m, MonadIO m) =>
String -> [Value] -> [Value] -> m ()
checkResult
    (String
program String -> ShowS
<.> Text -> String
T.unpack Text
entry String -> ShowS
<.> 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) =
  forall (m :: * -> *).
MonadError Text m =>
ExpectedError -> Text -> m ()
checkError ExpectedError
expectedError Text
actualError
compareResult Text
_ Int
_ String
_ (Succeeds Maybe [Value]
_) (ErrorResult Text
err) =
  forall e (m :: * -> *) a. MonadError e m => e -> m a
E.throwError forall a b. (a -> b) -> a -> b
$ Text
"Function failed with error:\n" forall a. Semigroup a => a -> a -> a
<> Text
err
compareResult Text
_ Int
_ String
_ (RunTimeFailure ExpectedError
f) (SuccessResult [Value]
_) =
  forall e (m :: * -> *) a. MonadError e m => e -> m a
E.throwError forall a b. (a -> b) -> a -> b
$ Text
"Program succeeded, but expected failure:\n  " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showText ExpectedError
f

---
--- Test manager
---

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

catching :: IO TestResult -> IO TestResult
catching :: IO TestResult -> IO TestResult
catching IO TestResult
m = IO TestResult
m 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 = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ [Text] -> TestResult
Failure [forall a. Show a => a -> Text
showText SomeException
e]

doTest :: TestCase -> IO TestResult
doTest :: TestCase -> IO TestResult
doTest = IO TestResult -> IO TestResult
catching forall b c a. (b -> c) -> (a -> b) -> a -> c
. TestM () -> IO TestResult
runTestM 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 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 = forall (f :: * -> *) a b. Applicative f => f a -> f b
forever forall a b. (a -> b) -> a -> b
$ do
  TestCase
test <- forall a. MVar a -> IO a
takeMVar MVar TestCase
testmvar
  forall a. MVar a -> a -> IO ()
putMVar MVar ReportMsg
resmvar forall a b. (a -> b) -> a -> b
$ TestCase -> ReportMsg
TestStarted TestCase
test
  TestResult
res <- TestCase -> IO TestResult
doTest TestCase
test
  forall a. MVar a -> a -> IO ()
putMVar MVar ReportMsg
resmvar 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 =
  forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` TestConfig -> [Text]
configExclude TestConfig
config) forall b c a. (b -> c) -> (a -> b) -> a -> c
. ProgramTest -> [Text]
testTags forall b c a. (b -> c) -> (a -> b) -> a -> c
. TestCase -> ProgramTest
testCaseTest

-- | Exclude those test cases that have tags we do not wish to run.
excludeCases :: TestConfig -> TestCase -> TestCase
excludeCases :: TestConfig -> TestCase -> TestCase
excludeCases TestConfig
config TestCase
tcase =
  TestCase
tcase {testCaseTest :: ProgramTest
testCaseTest = ProgramTest -> ProgramTest
onTest forall a b. (a -> b) -> a -> b
$ TestCase -> ProgramTest
testCaseTest TestCase
tcase}
  where
    onTest :: ProgramTest -> ProgramTest
onTest (ProgramTest Text
desc [Text]
tags TestAction
action) =
      Text -> [Text] -> TestAction -> ProgramTest
ProgramTest Text
desc [Text]
tags 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 (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 forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any String -> Bool
excluded forall b c a. (b -> c) -> (a -> b) -> a -> c
. TestRun -> [String]
runTags) [TestRun]
runs
    excluded :: String -> Bool
excluded = (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` TestConfig -> [Text]
configExclude TestConfig
config) 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
"" forall a. Monoid a => a
mempty, Entry
passed, Entry
failed, String -> AnsiStyle -> Entry
mkEntry String
"remaining" forall a. Monoid a => a
mempty],
        forall a b. (a -> b) -> [a] -> [b]
map (String -> AnsiStyle -> Entry
`mkEntry` forall a. Monoid a => a
mempty) [String
"programs", String
passedProgs, String
failedProgs, String
remainProgs'],
        forall a b. (a -> b) -> [a] -> [b]
map (String -> AnsiStyle -> Entry
`mkEntry` forall a. Monoid a => a
mempty) [String
"runs", String
passedRuns, String
failedRuns, String
remainRuns']
      ]
    passed :: Entry
passed = String -> AnsiStyle -> Entry
mkEntry String
"passed" forall a b. (a -> b) -> a -> b
$ Color -> AnsiStyle
color Color
Green
    failed :: Entry
failed = String -> AnsiStyle -> Entry
mkEntry String
"failed" forall a b. (a -> b) -> a -> b
$ Color -> AnsiStyle
color Color
Red
    passedProgs :: String
passedProgs = forall a. Show a => a -> String
show forall a b. (a -> b) -> a -> b
$ TestStatus -> Int
testStatusPass TestStatus
ts
    failedProgs :: String
failedProgs = forall a. Show a => a -> String
show forall a b. (a -> b) -> a -> b
$ TestStatus -> Int
testStatusFail TestStatus
ts
    totalProgs :: String
totalProgs = forall a. Show a => a -> String
show forall a b. (a -> b) -> a -> b
$ TestStatus -> Int
testStatusTotal TestStatus
ts
    totalRuns :: String
totalRuns = forall a. Show a => a -> String
show forall a b. (a -> b) -> a -> b
$ TestStatus -> Int
testStatusRuns TestStatus
ts
    passedRuns :: String
passedRuns = forall a. Show a => a -> String
show forall a b. (a -> b) -> a -> b
$ TestStatus -> Int
testStatusRunPass TestStatus
ts
    failedRuns :: String
failedRuns = forall a. Show a => a -> String
show forall a b. (a -> b) -> a -> b
$ TestStatus -> Int
testStatusRunFail TestStatus
ts
    remainProgs :: String
remainProgs = forall a. Show a => a -> String
show forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> Int
length forall a b. (a -> b) -> a -> b
$ TestStatus -> [TestCase]
testStatusRemain TestStatus
ts
    remainProgs' :: String
remainProgs' = String
remainProgs forall a. [a] -> [a] -> [a]
++ String
"/" forall a. [a] -> [a] -> [a]
++ String
totalProgs
    remainRuns :: String
remainRuns = forall a. Show a => a -> String
show forall a b. (a -> b) -> a -> b
$ TestStatus -> Int
testStatusRunsRemain TestStatus
ts
    remainRuns' :: String
remainRuns' = String
remainRuns forall a. [a] -> [a] -> [a]
++ String
"/" forall a. [a] -> [a] -> [a]
++ String
totalRuns

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

spaceTable :: IO ()
spaceTable :: IO ()
spaceTable = String -> IO ()
putStr forall a b. (a -> b) -> a -> b
$ 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 <- forall b a. b -> (a -> b) -> Maybe a -> b
maybe Int
80 forall a. Window a -> a
Terminal.width forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall n. Integral n => IO (Maybe (Window n))
Terminal.size
  Text -> IO ()
T.putStrLn forall a b. (a -> b) -> a -> b
$ Int -> Text -> Text
atMostChars (Int
w forall a. Num a => a -> a -> a
- Text -> Int
T.length Text
labelstr) Text
running
  where
    running :: Text
running = Text
labelstr forall a. Semigroup a => a -> a -> a
<> ([Text] -> Text
T.unwords forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> [a]
reverse forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (String -> Text
T.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. TestCase -> String
testCaseProgram) 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
  -- We force line buffering to ensure that we produce running output.
  -- Otherwise, CI tools and the like may believe we are hung and kill
  -- us.
  Handle -> BufferMode -> IO ()
hSetBuffering Handle
stdout BufferMode
LineBuffering

  let mode :: TestMode
mode = TestConfig -> TestMode
configTestMode TestConfig
config
  [TestCase]
all_tests <-
    forall a b. (a -> b) -> [a] -> [b]
map (TestConfig -> TestMode -> (String, ProgramTest) -> TestCase
makeTestCase TestConfig
config TestMode
mode)
      forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [String] -> IO [(String, ProgramTest)]
testSpecsFromPathsOrDie [String]
paths
  MVar TestCase
testmvar <- forall a. IO (MVar a)
newEmptyMVar
  MVar ReportMsg
reportmvar <- forall a. IO (MVar a)
newEmptyMVar
  Int
concurrency <- forall b a. b -> (a -> b) -> Maybe a -> b
maybe IO Int
getNumCapabilities forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ TestConfig -> Maybe Int
configConcurrency TestConfig
config
  forall (m :: * -> *) a. Applicative m => Int -> m a -> m ()
replicateM_ Int
concurrency forall a b. (a -> b) -> a -> b
$ IO () -> IO ThreadId
forkIO forall a b. (a -> b) -> a -> b
$ MVar TestCase -> MVar ReportMsg -> IO ()
runTest MVar TestCase
testmvar MVar ReportMsg
reportmvar

  let ([TestCase]
excluded, [TestCase]
included) = forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (TestConfig -> TestCase -> Bool
excludedTest TestConfig
config) [TestCase]
all_tests
  ThreadId
_ <- IO () -> IO ThreadId
forkIO forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall a. MVar a -> a -> IO ()
putMVar MVar TestCase
testmvar 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 = forall a b. a -> b -> a
const (forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
      clear :: IO ()
clear
        | Bool
fancy = IO ()
clearFromCursorToScreenEnd
        | Bool
otherwise = forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

      numTestCases :: TestCase -> Int
numTestCases TestCase
tc =
        case ProgramTest -> TestAction
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 ->
            forall (t :: * -> *) a. Foldable t => t a -> Int
length (forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap InputOutputs -> [TestRun]
iosTestRuns [InputOutputs]
ios)
              forall a. Num a => a -> a -> a
+ forall (t :: * -> *) a. Foldable t => t a -> Int
length [StructureTest]
sts
              forall a. Num a => a -> a -> a
+ forall (t :: * -> *) a. Foldable t => t a -> Int
length [WarningTest]
wts

      getResults :: TestStatus -> IO TestStatus
getResults TestStatus
ts
        | forall (t :: * -> *) a. Foldable t => t a -> Bool
null (TestStatus -> [TestCase]
testStatusRemain TestStatus
ts) = TestStatus -> IO ()
report TestStatus
ts forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (f :: * -> *) a. Applicative f => a -> f a
pure TestStatus
ts
        | Bool
otherwise = do
            TestStatus -> IO ()
report TestStatus
ts
            ReportMsg
msg <- forall a. MVar a -> IO a
takeMVar MVar ReportMsg
reportmvar
            case ReportMsg
msg of
              TestStarted TestCase
test ->
                TestStatus -> IO TestStatus
getResults forall a b. (a -> b) -> a -> b
$ TestStatus
ts {testStatusRun :: [TestCase]
testStatusRun = TestCase
test forall a. a -> [a] -> [a]
: TestStatus -> [TestCase]
testStatusRun TestStatus
ts}
              TestDone TestCase
test TestResult
res -> do
                let ts' :: TestStatus
ts' =
                      TestStatus
ts
                        { testStatusRemain :: [TestCase]
testStatusRemain = TestCase
test forall a. Eq a => a -> [a] -> [a]
`delete` TestStatus -> [TestCase]
testStatusRemain TestStatus
ts,
                          testStatusRun :: [TestCase]
testStatusRun = TestCase
test forall a. Eq a => a -> [a] -> [a]
`delete` TestStatus -> [TestCase]
testStatusRun TestStatus
ts,
                          testStatusRunsRemain :: Int
testStatusRunsRemain =
                            TestStatus -> Int
testStatusRunsRemain TestStatus
ts
                              forall a. Num a => a -> a -> a
- TestCase -> Int
numTestCases TestCase
test
                        }
                case TestResult
res of
                  TestResult
Success -> do
                    let ts'' :: TestStatus
ts'' =
                          TestStatus
ts'
                            { testStatusRunPass :: Int
testStatusRunPass =
                                TestStatus -> Int
testStatusRunPass TestStatus
ts' forall a. Num a => a -> a -> a
+ TestCase -> Int
numTestCases TestCase
test
                            }
                    TestStatus -> IO TestStatus
getResults forall a b. (a -> b) -> a -> b
$ TestStatus
ts'' {testStatusPass :: Int
testStatusPass = TestStatus -> Int
testStatusPass TestStatus
ts forall a. Num a => a -> a -> a
+ Int
1}
                  Failure [Text]
s -> do
                    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
fancy IO ()
moveCursorToTableTop
                    IO ()
clear
                    Doc AnsiStyle -> IO ()
putDoc forall a b. (a -> b) -> a -> b
$
                      forall ann. ann -> Doc ann -> Doc ann
annotate (AnsiStyle
bold forall a. Semigroup a => a -> a -> a
<> Color -> AnsiStyle
bgColor Color
Red) (forall a ann. Pretty a => a -> Doc ann
pretty (TestCase -> String
testCaseProgram TestCase
test) forall a. Semigroup a => a -> a -> a
<> Doc AnsiStyle
":")
                        forall a. Semigroup a => a -> a -> a
<> forall ann. Doc ann
hardline
                        forall a. Semigroup a => a -> a -> a
<> forall ann. [Doc ann] -> Doc ann
vsep (forall a b. (a -> b) -> [a] -> [b]
map forall a ann. Pretty a => a -> Doc ann
pretty [Text]
s)
                        forall a. Semigroup a => a -> a -> a
<> forall ann. Doc ann
hardline
                    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
fancy IO ()
spaceTable
                    TestStatus -> IO TestStatus
getResults forall a b. (a -> b) -> a -> b
$
                      TestStatus
ts'
                        { testStatusFail :: Int
testStatusFail = TestStatus -> Int
testStatusFail TestStatus
ts' forall a. Num a => a -> a -> a
+ Int
1,
                          testStatusRunPass :: Int
testStatusRunPass =
                            TestStatus -> Int
testStatusRunPass TestStatus
ts'
                              forall a. Num a => a -> a -> a
+ TestCase -> Int
numTestCases TestCase
test
                              forall a. Num a => a -> a -> a
- forall (t :: * -> *) a. Foldable t => t a -> Int
length [Text]
s,
                          testStatusRunFail :: Int
testStatusRunFail =
                            TestStatus -> Int
testStatusRunFail TestStatus
ts'
                              forall a. Num a => a -> a -> a
+ forall (t :: * -> *) a. Foldable t => t a -> Int
length [Text]
s
                        }

  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 = forall (t :: * -> *) a. Foldable t => t a -> Int
length [TestCase]
included,
          testStatusFail :: Int
testStatusFail = Int
0,
          testStatusPass :: Int
testStatusPass = Int
0,
          testStatusRuns :: Int
testStatusRuns = forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map TestCase -> Int
numTestCases [TestCase]
included,
          testStatusRunsRemain :: Int
testStatusRunsRemain = forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map TestCase -> Int
numTestCases [TestCase]
included,
          testStatusRunPass :: Int
testStatusRunPass = Int
0,
          testStatusRunFail :: Int
testStatusRunFail = Int
0
        }

  -- Removes "Now testing" output.
  if Bool
fancy
    then Int -> IO ()
cursorUpLine Int
1 forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
clearLine
    else String -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show (TestStatus -> Int
testStatusPass TestStatus
ts) forall a. Semigroup a => a -> a -> a
<> String
"/" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show (TestStatus -> Int
testStatusTotal TestStatus
ts) forall a. Semigroup a => a -> a -> a
<> String
" passed."

  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TestCase]
excluded) forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$
    forall a. Show a => a -> String
show (forall (t :: * -> *) a. Foldable t => t a -> Int
length [TestCase]
excluded) forall a. [a] -> [a] -> [a]
++ String
" program(s) excluded."

  forall a. ExitCode -> IO a
exitWith forall a b. (a -> b) -> a -> b
$ case TestStatus -> Int
testStatusFail TestStatus
ts of
    Int
0 -> ExitCode
ExitSuccess
    Int
_ -> Int -> ExitCode
ExitFailure Int
1

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

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

defaultConfig :: TestConfig
defaultConfig :: TestConfig
defaultConfig =
  TestConfig
    { configTestMode :: TestMode
configTestMode = TestMode
Compiled,
      configExclude :: [Text]
configExclude = [Text
"disable"],
      configPrograms :: ProgConfig
configPrograms =
        ProgConfig
          { configBackend :: String
configBackend = String
"c",
            configFuthark :: Maybe String
configFuthark = forall a. Maybe a
Nothing,
            configRunner :: String
configRunner = String
"",
            configExtraOptions :: [String]
configExtraOptions = [],
            configExtraCompilerOptions :: [String]
configExtraCompilerOptions = [],
            configTuning :: Maybe String
configTuning = forall a. a -> Maybe a
Just String
"tuning",
            configCacheExt :: Maybe String
configCacheExt = forall a. Maybe a
Nothing
          },
      configLineOutput :: Bool
configLineOutput = Bool
False,
      configConcurrency :: Maybe Int
configConcurrency = forall a. Maybe a
Nothing
    }

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

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

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

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

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

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

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

commandLineOptions :: [FunOptDescr TestConfig]
commandLineOptions :: [FunOptDescr TestConfig]
commandLineOptions =
  [ forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
Option
      String
"t"
      [String
"typecheck"]
      (forall a. a -> ArgDescr a
NoArg forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ \TestConfig
config -> TestConfig
config {configTestMode :: TestMode
configTestMode = TestMode
TypeCheck})
      String
"Only perform type-checking",
    forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
Option
      String
"i"
      [String
"interpreted"]
      (forall a. a -> ArgDescr a
NoArg forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ \TestConfig
config -> TestConfig
config {configTestMode :: TestMode
configTestMode = TestMode
Interpreted})
      String
"Only interpret",
    forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
Option
      String
"c"
      [String
"compiled"]
      (forall a. a -> ArgDescr a
NoArg forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ \TestConfig
config -> TestConfig
config {configTestMode :: TestMode
configTestMode = TestMode
Compiled})
      String
"Only run compiled code (the default)",
    forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
Option
      String
"C"
      [String
"compile"]
      (forall a. a -> ArgDescr a
NoArg forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ \TestConfig
config -> TestConfig
config {configTestMode :: TestMode
configTestMode = TestMode
Compile})
      String
"Only compile, do not run.",
    forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
Option
      String
"I"
      [String
"internalise"]
      (forall a. a -> ArgDescr a
NoArg forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ \TestConfig
config -> TestConfig
config {configTestMode :: TestMode
configTestMode = TestMode
Internalise})
      String
"Only run the compiler frontend.",
    forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
Option
      []
      [String
"no-terminal", String
"notty"]
      (forall a. a -> ArgDescr a
NoArg forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ \TestConfig
config -> TestConfig
config {configLineOutput :: Bool
configLineOutput = Bool
True})
      String
"Provide simpler line-based output.",
    forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
Option
      []
      [String
"backend"]
      (forall a. (String -> a) -> String -> ArgDescr a
ReqArg (forall a b. b -> Either a b
Right forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ProgConfig -> ProgConfig) -> TestConfig -> TestConfig
changeProgConfig forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ProgConfig -> ProgConfig
setBackend) String
"BACKEND")
      String
"Backend used for compilation (defaults to 'c').",
    forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
Option
      []
      [String
"futhark"]
      (forall a. (String -> a) -> String -> ArgDescr a
ReqArg (forall a b. b -> Either a b
Right forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ProgConfig -> ProgConfig) -> TestConfig -> TestConfig
changeProgConfig 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').",
    forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
Option
      []
      [String
"runner"]
      (forall a. (String -> a) -> String -> ArgDescr a
ReqArg (forall a b. b -> Either a b
Right forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ProgConfig -> ProgConfig) -> TestConfig -> TestConfig
changeProgConfig 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).",
    forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
Option
      []
      [String
"exclude"]
      ( forall a. (String -> a) -> String -> ArgDescr a
ReqArg
          ( \String
tag ->
              forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ \TestConfig
config ->
                TestConfig
config {configExclude :: [Text]
configExclude = String -> Text
T.pack String
tag forall a. a -> [a] -> [a]
: TestConfig -> [Text]
configExclude TestConfig
config}
          )
          String
"TAG"
      )
      String
"Exclude test programs that define this tag.",
    forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
Option
      String
"p"
      [String
"pass-option"]
      (forall a. (String -> a) -> String -> ArgDescr a
ReqArg (forall a b. b -> Either a b
Right forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ProgConfig -> ProgConfig) -> TestConfig -> TestConfig
changeProgConfig forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ProgConfig -> ProgConfig
addOption) String
"OPT")
      String
"Pass this option to programs being run.",
    forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
Option
      []
      [String
"pass-compiler-option"]
      (forall a. (String -> a) -> String -> ArgDescr a
ReqArg (forall a b. b -> Either a b
Right forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ProgConfig -> ProgConfig) -> TestConfig -> TestConfig
changeProgConfig 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).",
    forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
Option
      []
      [String
"no-tuning"]
      (forall a. a -> ArgDescr a
NoArg forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ (ProgConfig -> ProgConfig) -> TestConfig -> TestConfig
changeProgConfig forall a b. (a -> b) -> a -> b
$ \ProgConfig
config -> ProgConfig
config {configTuning :: Maybe String
configTuning = forall a. Maybe a
Nothing})
      String
"Do not load tuning files.",
    forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
Option
      []
      [String
"cache-extension"]
      ( forall a. (String -> a) -> String -> ArgDescr a
ReqArg
          (\String
s -> forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ (ProgConfig -> ProgConfig) -> TestConfig -> TestConfig
changeProgConfig forall a b. (a -> b) -> a -> b
$ \ProgConfig
config -> ProgConfig
config {configCacheExt :: Maybe String
configCacheExt = forall a. a -> Maybe a
Just String
s})
          String
"EXTENSION"
      )
      String
"Use cache files with this extension (none by default).",
    forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
Option
      []
      [String
"concurrency"]
      ( forall a. (String -> a) -> String -> ArgDescr a
ReqArg
          ( \String
n ->
              case forall a. Read a => ReadS a
reads String
n of
                [(Int
n', String
"")]
                  | Int
n' forall a. Ord a => a -> a -> Bool
> Int
0 ->
                      forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ \TestConfig
config -> TestConfig
config {configConcurrency :: Maybe Int
configConcurrency = forall a. a -> Maybe a
Just Int
n'}
                [(Int, String)]
_ ->
                  forall a b. a -> Either a b
Left forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO ()
optionsError forall a b. (a -> b) -> a -> b
$ String
"'" forall a. [a] -> [a] -> [a]
++ String
n 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 :: [Text]
configExclude =
        Text
"no_" forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (ProgConfig -> String
configBackend (TestConfig -> ProgConfig
configPrograms TestConfig
config))
          forall a. a -> [a] -> [a]
: TestConfig -> [Text]
configExclude TestConfig
config
    }

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