-- Copyright 2013 Evan Laforge
-- This program is distributed under the terms of the GNU General Public
-- License 3.0, see COPYING or http://www.gnu.org/licenses/gpl-3.0.txt

{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
-- | Run tests.  This is meant to be invoked via a main module generated by
-- "Util.Test.GenerateRunTests".
--
-- Since tests are in IO and write to stdout, to parallelize I can't just run a
-- bunch of threads.  So the parallelism is a bit weird: when run with
-- @--jobs@, it will fork that many subprocesses with @--subprocess@.  Each
-- one will wait for a test to run on its stdin, and the parent process will
-- dole them out when each is done.
module Util.Test.RunTests where
import qualified Control.Concurrent.Async as Async
import qualified Control.Concurrent.Chan as Chan
import qualified Control.Concurrent.MVar as MVar
import qualified Control.Exception as Exception
import qualified Control.Monad.Fix as Fix

import qualified Data.List as List
import qualified Data.Maybe as Maybe
import qualified Data.Set as Set
import qualified Data.Text as Text
import qualified Data.Text.IO as Text.IO
import qualified Data.Text.Lazy as Text.Lazy
import qualified Data.Text.Lazy.IO as Text.Lazy.IO

import qualified Numeric
import qualified System.CPUTime as CPUTime
import qualified System.Console.GetOpt as GetOpt
import qualified System.Directory as Directory
import qualified System.Environment as Environment
import qualified System.Exit as Exit
import           System.FilePath ((</>))
import qualified System.IO as IO
import qualified System.Process as Process

import qualified Text.Read as Read

import qualified Util.Cpu as Cpu
import qualified Util.Exceptions as Exceptions
import qualified Util.Files as Files
import qualified Util.Lists as Lists
import qualified Util.Processes as Processes
import qualified Util.Regex as Regex
import qualified Util.Test.Testing as Testing

import           Global


data Test = Test {
    -- | Name of the test function.
    Test -> Text
testSymName :: Text
    -- | Run the test.
    , Test -> IO ()
testRun :: IO ()
    -- | Test module filename.
    , Test -> [Char]
testFilename :: FilePath
    -- | Line of the test function declaration.
    , Test -> Int
testLine :: Int
    -- | Module-level metadata, declared as @meta@ in the test module toplevel.
    , Test -> Maybe ModuleMeta
testModuleMeta_ :: Maybe Testing.ModuleMeta
    }

testModuleMeta :: Test -> Testing.ModuleMeta
testModuleMeta :: Test -> ModuleMeta
testModuleMeta = forall a. a -> Maybe a -> a
Maybe.fromMaybe ModuleMeta
Testing.moduleMeta forall b c a. (b -> c) -> (a -> b) -> a -> c
. Test -> Maybe ModuleMeta
testModuleMeta_

testName :: Test -> Text
testName :: Test -> Text
testName Test
test = Text -> [Text] -> Text
Text.intercalate Text
"," [Text]
tags forall a. Semigroup a => a -> a -> a
<> Text
"-" forall a. Semigroup a => a -> a -> a
<> Test -> Text
testSymName Test
test
    where
    tags :: [Text]
tags = if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
tags_ then [Text
"normal"] else [Text]
tags_
    tags_ :: [Text]
tags_ = forall a. Ord a => [a] -> [a]
Lists.uniqueSort forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (Text -> Text
Text.toLower forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> Text
showt) forall a b. (a -> b) -> a -> b
$
        ModuleMeta -> [Tag]
Testing.tags (Test -> ModuleMeta
testModuleMeta Test
test)

-- Prefix for lines with test metadata.
metaPrefix :: Text
metaPrefix :: Text
metaPrefix = Text
"===>"

data Flag =
    CheckOutput
    | ClearDirs
    | Help
    | Interactive
    | Jobs !Jobs
    | List
    | Output !FilePath
    | Subprocess
    deriving (Flag -> Flag -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Flag -> Flag -> Bool
$c/= :: Flag -> Flag -> Bool
== :: Flag -> Flag -> Bool
$c== :: Flag -> Flag -> Bool
Eq, Int -> Flag -> ShowS
[Flag] -> ShowS
Flag -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [Flag] -> ShowS
$cshowList :: [Flag] -> ShowS
show :: Flag -> [Char]
$cshow :: Flag -> [Char]
showsPrec :: Int -> Flag -> ShowS
$cshowsPrec :: Int -> Flag -> ShowS
Show)

data Jobs = Auto | NJobs !Int deriving (Jobs -> Jobs -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Jobs -> Jobs -> Bool
$c/= :: Jobs -> Jobs -> Bool
== :: Jobs -> Jobs -> Bool
$c== :: Jobs -> Jobs -> Bool
Eq, Int -> Jobs -> ShowS
[Jobs] -> ShowS
Jobs -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [Jobs] -> ShowS
$cshowList :: [Jobs] -> ShowS
show :: Jobs -> [Char]
$cshow :: Jobs -> [Char]
showsPrec :: Int -> Jobs -> ShowS
$cshowsPrec :: Int -> Jobs -> ShowS
Show)

options :: [GetOpt.OptDescr Flag]
options :: [OptDescr Flag]
options =
    [ forall a. [Char] -> [[Char]] -> ArgDescr a -> [Char] -> OptDescr a
GetOpt.Option [] [[Char]
"check-output"] (forall a. a -> ArgDescr a
GetOpt.NoArg Flag
CheckOutput)
        [Char]
"Check output for failures after running. Only valid with --output."
    , forall a. [Char] -> [[Char]] -> ArgDescr a -> [Char] -> OptDescr a
GetOpt.Option [] [[Char]
"clear-dirs"] (forall a. a -> ArgDescr a
GetOpt.NoArg Flag
ClearDirs)
        [Char]
"Remove everything in the test tmp dir and --output."
    , forall a. [Char] -> [[Char]] -> ArgDescr a -> [Char] -> OptDescr a
GetOpt.Option [Char
'h'] [[Char]
"help"] (forall a. a -> ArgDescr a
GetOpt.NoArg Flag
Help) [Char]
"show usage"
    , forall a. [Char] -> [[Char]] -> ArgDescr a -> [Char] -> OptDescr a
GetOpt.Option [] [[Char]
"interactive"] (forall a. a -> ArgDescr a
GetOpt.NoArg Flag
Interactive)
        [Char]
"Interactive tests can ask questions, otherwise assume they all pass.\
        \ This disables --jobs parallelism, and output goes to stdout."
    , forall a. [Char] -> [[Char]] -> ArgDescr a -> [Char] -> OptDescr a
GetOpt.Option [] [[Char]
"jobs"] (forall a. ([Char] -> a) -> [Char] -> ArgDescr a
GetOpt.ReqArg (Jobs -> Flag
Jobs forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Jobs
parseJobs) [Char]
"1")
        [Char]
"Number of parallel jobs, or 'auto' for physical CPU count."
    , forall a. [Char] -> [[Char]] -> ArgDescr a -> [Char] -> OptDescr a
GetOpt.Option [] [[Char]
"list"] (forall a. a -> ArgDescr a
GetOpt.NoArg Flag
List) [Char]
"display but don't run"
    , forall a. [Char] -> [[Char]] -> ArgDescr a -> [Char] -> OptDescr a
GetOpt.Option [] [[Char]
"output"] (forall a. ([Char] -> a) -> [Char] -> ArgDescr a
GetOpt.ReqArg [Char] -> Flag
Output [Char]
"path")
        [Char]
"Path to a directory to put output logs, if not given output goes to\
        \ stdout."
    , forall a. [Char] -> [[Char]] -> ArgDescr a -> [Char] -> OptDescr a
GetOpt.Option [] [[Char]
"subprocess"] (forall a. a -> ArgDescr a
GetOpt.NoArg Flag
Subprocess)
        [Char]
"Read test names on stdin.  This is meant to be run as a subprocess\
        \ by --jobs."
    ]
    where
    parseJobs :: [Char] -> Jobs
parseJobs [Char]
s
        | [Char]
s forall a. Eq a => a -> a -> Bool
== [Char]
"auto" = Jobs
Auto
        | Just Int
n <- forall a. Read a => [Char] -> Maybe a
Read.readMaybe [Char]
s = Int -> Jobs
NJobs Int
n
        | Bool
otherwise = forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ [Char]
"jobs should be auto or a number, was: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show [Char]
s

-- | Called by the generated main function.
run :: [Test] -> IO ()
run :: [Test] -> IO ()
run [Test]
allTests = do
    Handle -> BufferMode -> IO ()
IO.hSetBuffering Handle
IO.stdout BufferMode
IO.LineBuffering
    [[Char]]
args <- IO [[Char]]
Environment.getArgs
    ([Flag]
flags, [[Char]]
args) <- case forall a.
ArgOrder a -> [OptDescr a] -> [[Char]] -> ([a], [[Char]], [[Char]])
GetOpt.getOpt forall a. ArgOrder a
GetOpt.Permute [OptDescr Flag]
options [[Char]]
args of
        ([Flag]
opts, [[Char]]
n, []) -> forall (m :: * -> *) a. Monad m => a -> m a
return ([Flag]
opts, [[Char]]
n)
        ([Flag]
_, [[Char]]
_, [[Char]]
errors) -> forall a. [[Char]] -> IO a
quitWithUsage [[Char]]
errors
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Flag
Help forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Flag]
flags) forall a b. (a -> b) -> a -> b
$ forall a. [[Char]] -> IO a
quitWithUsage []
    Bool
ok <- [Test] -> [Flag] -> [[Char]] -> IO Bool
runTests [Test]
allTests [Flag]
flags [[Char]]
args
    if Bool
ok then forall a. IO a
Exit.exitSuccess else forall a. IO a
Exit.exitFailure

quitWithUsage :: [String] -> IO a
quitWithUsage :: forall a. [[Char]] -> IO a
quitWithUsage [[Char]]
errors = do
    [Char]
progName <- IO [Char]
Environment.getProgName
    [Char] -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ [Char]
"usage: " forall a. Semigroup a => a -> a -> a
<> [Char]
progName forall a. Semigroup a => a -> a -> a
<> [Char]
" [ flags ] regex regex ..."
    [Char] -> IO ()
putStr forall a b. (a -> b) -> a -> b
$ forall a. [Char] -> [OptDescr a] -> [Char]
GetOpt.usageInfo
        [Char]
"Run tests that match any regex, or all of them in no regex." [OptDescr Flag]
options
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [[Char]]
errors) forall a b. (a -> b) -> a -> b
$
        [Char] -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ [Char]
"\nerrors:\n" forall a. Semigroup a => a -> a -> a
<> [[Char]] -> [Char]
unlines [[Char]]
errors
    if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [[Char]]
errors then forall a. IO a
Exit.exitSuccess else forall a. IO a
Exit.exitFailure

runTests :: [Test] -> [Flag] -> [String] -> IO Bool
runTests :: [Test] -> [Flag] -> [[Char]] -> IO Bool
runTests [Test]
allTests [Flag]
flags [[Char]]
regexes = do
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe [Char]
mbOutputDir forall a. Eq a => a -> a -> Bool
== forall a. Maybe a
Nothing Bool -> Bool -> Bool
&& Flag
CheckOutput forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Flag]
flags) forall a b. (a -> b) -> a -> b
$
        forall a. [[Char]] -> IO a
quitWithUsage [[Char]
"--check-output requires --output"]
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Flag
ClearDirs forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Flag]
flags) forall a b. (a -> b) -> a -> b
$ do
        [Char] -> IO ()
clearDirectory [Char]
Testing.tmp_base_dir
        forall (m :: * -> *) a.
Applicative m =>
Maybe a -> (a -> m ()) -> m ()
whenJust Maybe [Char]
mbOutputDir [Char] -> IO ()
clearDirectory
    if  | Flag
List forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Flag]
flags -> do
            forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Text -> IO ()
Text.IO.putStrLn forall a b. (a -> b) -> a -> b
$ forall a. Ord a => [a] -> [a]
List.sort forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map Test -> Text
testName [Test]
matches
            forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
        | Flag
Subprocess forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Flag]
flags -> [Test] -> IO ()
subprocess [Test]
allTests forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
        | Flag
Interactive forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Flag]
flags -> do
            (Config -> Config) -> IO ()
Testing.modify_test_config forall a b. (a -> b) -> a -> b
$ \Config
config ->
                Config
config { config_human_agreeable :: Bool
Testing.config_human_agreeable = Bool
False }
            forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Test -> IO ()
runInSubprocess [Test]
matches
            forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
        | Just [Char]
outputDir <- Maybe [Char]
mbOutputDir -> do
            Int
jobs <- Jobs -> IO Int
getJobs forall a b. (a -> b) -> a -> b
$
                forall a. a -> Maybe a -> a
fromMaybe (Int -> Jobs
NJobs Int
1) forall a b. (a -> b) -> a -> b
$ forall a. [a] -> Maybe a
Lists.last [Jobs
n | Jobs Jobs
n <- [Flag]
flags]
            -- Don't warn if it's CheckOutput, might just be checking.
            forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Test]
matches Bool -> Bool -> Bool
&& Flag
CheckOutput forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Flag]
flags) forall a b. (a -> b) -> a -> b
$
                [Char] -> IO ()
putStrLn [Char]
"warning: no tests matched"
            [Char] -> Int -> [Test] -> Bool -> IO Bool
runOutput [Char]
outputDir Int
jobs [Test]
matches (Flag
CheckOutput forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Flag]
flags)
        | Bool
otherwise -> do
            forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Test]
matches) forall a b. (a -> b) -> a -> b
$
                [Char] -> IO ()
putStrLn [Char]
"warning: no tests matched"
            forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Test -> IO ()
runTest [Test]
matches
            forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
    where
    mbOutputDir :: Maybe [Char]
mbOutputDir = forall a. [a] -> Maybe a
Lists.last [[Char]
d | Output [Char]
d <- [Flag]
flags]
    matches :: [Test]
matches = if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [[Char]]
regexes then [Test]
allTests else [[Char]] -> [Test] -> [Test]
matchingTests [[Char]]
regexes [Test]
allTests

getJobs :: Jobs -> IO Int
getJobs :: Jobs -> IO Int
getJobs (NJobs Int
n) = forall (m :: * -> *) a. Monad m => a -> m a
return Int
n
getJobs Jobs
Auto = IO Int
Cpu.physicalCores

runOutput :: FilePath -> Int -> [Test] -> Bool -> IO Bool
runOutput :: [Char] -> Int -> [Test] -> Bool -> IO Bool
runOutput [Char]
outputDir Int
jobs [Test]
tests Bool
checkOutput = do
    Bool -> [Char] -> IO ()
Directory.createDirectoryIfMissing Bool
True [Char]
outputDir
    let outputs :: [[Char]]
outputs = [[Char]
outputDir [Char] -> ShowS
</> [Char]
"out" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show Int
n forall a. Semigroup a => a -> a -> a
<> [Char]
".stdout" | Int
n <- [Int
1..Int
jobs]]
    [[Char]]
failures <- [[Char]] -> [Test] -> IO [[Char]]
runParallel [[Char]]
outputs [Test]
tests
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ([Char] -> IO ()
putStrLn forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char]
"*** "<>)) [[Char]]
failures
    if Bool
checkOutput
        then Bool -> Bool -> Bool
(&&) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [[Char]] -> IO Bool
checkOutputs [[Char]]
outputs forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [[Char]]
failures)
        else forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Bool
null [[Char]]
failures
    -- TODO run hpc?

-- | Isolate the test by running it in a subprocess.  I'm not sure if this is
-- necessary, but I believe at the time GUI-using tests would crash each other
-- without it.  Presumably they left some GUI state around that process exit
-- will clean up.
runInSubprocess :: Test -> IO ()
runInSubprocess :: Test -> IO ()
runInSubprocess Test
test = do
    [Char]
argv0 <- IO [Char]
Environment.getExecutablePath
    [Char] -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ [Char]
"subprocess: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show [Char]
argv0 forall a. [a] -> [a] -> [a]
++ [Char]
" " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show [Test -> Text
testName Test
test]
    ExitCode
val <- [Char] -> [[Char]] -> IO ExitCode
Process.rawSystem [Char]
argv0 [Text -> [Char]
untxt (Test -> Text
testName Test
test)]
    case ExitCode
val of
        Exit.ExitFailure Int
code -> forall a. Text -> IO a -> IO a
Testing.with_test_name (Test -> Text
testName Test
test) forall a b. (a -> b) -> a -> b
$
            forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ HasCallStack => Text -> IO ()
Testing.failure forall a b. (a -> b) -> a -> b
$
                Text
"test returned " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt Int
code forall a. Semigroup a => a -> a -> a
<> Text
": " forall a. Semigroup a => a -> a -> a
<> Test -> Text
testName Test
test
        ExitCode
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- * parallel jobs

-- | Run tests in parallel, redirecting stdout and stderr to each output.
runParallel :: [FilePath] -> [Test] -> IO [String]
runParallel :: [[Char]] -> [Test] -> IO [[Char]]
runParallel [[Char]]
_ [] = forall (m :: * -> *) a. Monad m => a -> m a
return []
runParallel [[Char]]
outputs [Test]
tests = do
    let byModule :: [([Char], [Test])]
byModule = forall key a. Eq key => (a -> key) -> [a] -> [(key, [a])]
Lists.keyedGroupAdjacent Test -> [Char]
testFilename [Test]
tests
    Queue (Text, [Test])
queue <- forall a. [a] -> IO (Queue a)
newQueue [([Char] -> Text
txt [Char]
name, [Test]
tests) | ([Char]
name, [Test]
tests) <- [([Char], [Test])]
byModule]
    [Maybe [Char]]
failures <- forall (t :: * -> *) a b.
Traversable t =>
t a -> (a -> IO b) -> IO (t b)
Async.forConcurrently (forall a b. [a] -> [b] -> [a]
shortenBy [[Char]]
outputs [([Char], [Test])]
byModule) forall a b. (a -> b) -> a -> b
$
        \[Char]
output -> [Char] -> Queue (Text, [Test]) -> IO (Maybe [Char])
jobThread [Char]
output Queue (Text, [Test])
queue
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. [Maybe a] -> [a]
Maybe.catMaybes [Maybe [Char]]
failures

shortenBy :: [a] -> [b] -> [a]
shortenBy :: forall a b. [a] -> [b] -> [a]
shortenBy [a]
as [b]
bs = forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst (forall a b. [a] -> [b] -> [(a, b)]
zip [a]
as [b]
bs)

-- | Pull tests off the queue and feed them to a single subprocess.
jobThread :: FilePath -> Queue (Text, [Test]) -> IO (Maybe String)
jobThread :: [Char] -> Queue (Text, [Test]) -> IO (Maybe [Char])
jobThread [Char]
output Queue (Text, [Test])
queue = forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
Exception.bracket IO Handle
open Handle -> IO ()
IO.hClose forall a b. (a -> b) -> a -> b
$ \Handle
hdl -> do
    Chan TalkIn
to <- forall a. IO (Chan a)
Chan.newChan
    [([Char], [Char])]
env <- IO [([Char], [Char])]
Environment.getEnvironment
    [Char]
argv0 <- IO [Char]
Environment.getExecutablePath
    -- Give each subprocess its own .tix, or they will stomp on each other
    -- and crash.
    forall a.
[Char]
-> [[Char]]
-> Maybe [([Char], [Char])]
-> Chan TalkIn
-> (Chan TalkOut -> IO a)
-> IO a
Processes.conversation [Char]
argv0 [[Char]
"--subprocess"]
            (forall a. a -> Maybe a
Just (([Char]
"HPCTIXFILE", [Char]
output forall a. Semigroup a => a -> a -> a
<> [Char]
".tix") forall a. a -> [a] -> [a]
: [([Char], [Char])]
env)) Chan TalkIn
to forall a b. (a -> b) -> a -> b
$ \Chan TalkOut
from -> do
        Maybe Exit
earlyExit <- forall a. (a -> a) -> a
Fix.fix forall a b. (a -> b) -> a -> b
$ \IO (Maybe Exit)
loop -> forall a. Queue a -> IO (Maybe a)
takeQueue Queue (Text, [Test])
queue forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Maybe (Text, [Test])
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
            Just (Text
name, [Test]
tests) -> do
                [Char] -> IO ()
put forall a b. (a -> b) -> a -> b
$ Text -> [Char]
untxt Text
name
                forall a. Chan a -> a -> IO ()
Chan.writeChan Chan TalkIn
to forall a b. (a -> b) -> a -> b
$ Text -> TalkIn
Processes.Text forall a b. (a -> b) -> a -> b
$
                    [Text] -> Text
Text.unwords (forall a b. (a -> b) -> [a] -> [b]
map Test -> Text
testName [Test]
tests) forall a. Semigroup a => a -> a -> a
<> Text
"\n"
                Maybe Exit
earlyExit <- forall a. (a -> a) -> a
Fix.fix forall a b. (a -> b) -> a -> b
$ \IO (Maybe Exit)
loop -> forall a. Chan a -> IO a
Chan.readChan Chan TalkOut
from forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                    Processes.Stdout Text
line
                        | Text
line forall a. Eq a => a -> a -> Bool
== Text
testsCompleteLine -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
                        | Bool
otherwise -> Handle -> Text -> IO ()
Text.IO.hPutStrLn Handle
hdl Text
line forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO (Maybe Exit)
loop
                    Processes.Stderr Text
line ->
                        Handle -> Text -> IO ()
Text.IO.hPutStrLn Handle
hdl Text
line forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO (Maybe Exit)
loop
                    Processes.Exit Exit
n -> do
                        [Char] -> IO ()
put forall a b. (a -> b) -> a -> b
$ [Char]
"completed early: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show Exit
n
                        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just Exit
n
                forall b a. b -> (a -> b) -> Maybe a -> b
maybe IO (Maybe Exit)
loop (forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a
Just) Maybe Exit
earlyExit
        TalkOut
final <- case Maybe Exit
earlyExit of
            Maybe Exit
Nothing -> do
                forall a. Chan a -> a -> IO ()
Chan.writeChan Chan TalkIn
to TalkIn
Processes.EOF
                forall a. Chan a -> IO a
Chan.readChan Chan TalkOut
from
            Just Exit
n -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Exit -> TalkOut
Processes.Exit Exit
n
        let failure :: Maybe [Char]
failure = case TalkOut
final of
                Processes.Exit (Processes.ExitCode Int
n)
                    | Int
n forall a. Eq a => a -> a -> Bool
== Int
0 -> forall a. Maybe a
Nothing
                    | Bool
otherwise -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ [Char]
"subprocess crashed: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show Int
n
                Processes.Exit Exit
Processes.BinaryNotFound ->
                    forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ [Char]
"binary not found: " forall a. Semigroup a => a -> a -> a
<> [Char]
argv0
                TalkOut
_ -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ [Char]
"expected Exit, but got " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show TalkOut
final
        forall (m :: * -> *) a.
Applicative m =>
Maybe a -> (a -> m ()) -> m ()
whenJust Maybe [Char]
failure [Char] -> IO ()
put
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ([Char]
prefix<>) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe [Char]
failure
    where
    -- This uses AppendMode because I want to aggregate results from multiple
    -- runs, in tools/run_test.
    open :: IO Handle
open = [Char] -> IOMode -> IO Handle
IO.openFile [Char]
output IOMode
IO.AppendMode
    prefix :: [Char]
prefix = [Char]
output forall a. Semigroup a => a -> a -> a
<> [Char]
": "
    put :: [Char] -> IO ()
put = [Char] -> IO ()
putStrLn forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char]
prefix<>)

subprocess :: [Test] -> IO ()
subprocess :: [Test] -> IO ()
subprocess [Test]
allTests = forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall a. IO a -> IO (Maybe a)
Exceptions.ignoreEOF forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Applicative f => f a -> f b
forever forall a b. (a -> b) -> a -> b
$ do
    Set Text
testNames <- forall a. Ord a => [a] -> Set a
Set.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text]
Text.words forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO Text
Text.IO.getLine
    -- For some reason, I get an extra "" from getLine when the parent process
    -- closes the pipe.  From the documentation I think it should throw EOF.
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall a. Set a -> Bool
Set.null Set Text
testNames) forall a b. (a -> b) -> a -> b
$ do
        let tests :: [Test]
tests = forall a. (a -> Bool) -> [a] -> [a]
filter ((forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Text
testNames) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Test -> Text
testName) [Test]
allTests
        forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Test -> IO ()
runTest [Test]
tests
            forall a b. IO a -> IO b -> IO a
`Exception.finally` Handle -> Text -> IO ()
Text.IO.hPutStrLn Handle
IO.stdout Text
testsCompleteLine
            -- I previously wrote this on stderr, but it turns out it then
            -- gets nondeterministically interleaved with stdout.

-- | Signal to the caller that the current batch of tests are done.
testsCompleteLine :: Text
testsCompleteLine :: Text
testsCompleteLine = Text
"•complete•"

-- * run tests

-- | Match all tests whose names match any regex, or if a test is an exact
-- match, just that test.
matchingTests :: [String] -> [Test] -> [Test]
matchingTests :: [[Char]] -> [Test] -> [Test]
matchingTests [[Char]]
regexes [Test]
tests = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap [Char] -> [Test]
match [[Char]]
regexes
    where
    match :: [Char] -> [Test]
match [Char]
reg = case forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
List.find ((forall a. Eq a => a -> a -> Bool
== [Char] -> Text
txt [Char]
reg) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Test -> Text
testName) [Test]
tests of
        Just Test
test -> [Test
test]
        Maybe Test
Nothing -> forall a. (a -> Bool) -> [a] -> [a]
filter (Regex -> Text -> Bool
Regex.matches (HasCallStack => [Char] -> Regex
Regex.compileUnsafe [Char]
reg) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Test -> Text
testName)
            [Test]
tests

runTest :: Test -> IO ()
runTest :: Test -> IO ()
runTest Test
test = forall a. Text -> IO a -> IO a
Testing.with_test_name Text
name forall a b. (a -> b) -> a -> b
$ forall a. IO a -> IO a
isolate forall a b. (a -> b) -> a -> b
$ do
    Text -> IO ()
Text.IO.putStrLn forall a b. (a -> b) -> a -> b
$ [Text] -> Text
Text.unwords [Text
metaPrefix, Text
"run-test", Test -> Text
testName Test
test]
    Integer
start <- IO Integer
CPUTime.getCPUTime
    ModuleMeta -> IO () -> IO ()
Testing.initialize (Test -> ModuleMeta
testModuleMeta Test
test) forall a b. (a -> b) -> a -> b
$
        forall a. Text -> IO a -> IO ()
catch (Test -> Text
testSymName Test
test) (Test -> IO ()
testRun Test
test)
    Integer
end <- IO Integer
CPUTime.getCPUTime
    -- CPUTime is in picoseconds.
    let secs :: Double
secs = forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer
end forall a. Num a => a -> a -> a
- Integer
start) forall a. Fractional a => a -> a -> a
/ Double
10forall a b. (Num a, Integral b) => a -> b -> a
^Integer
12
    -- Grep for timing to make a histogram.
    Text -> IO ()
Text.IO.putStrLn forall a b. (a -> b) -> a -> b
$ [Text] -> Text
Text.unwords [Text
metaPrefix, Text
"timing", Test -> Text
testName Test
test,
        [Char] -> Text
txt forall a b. (a -> b) -> a -> b
$ forall a. RealFloat a => Maybe Int -> a -> ShowS
Numeric.showFFloat (forall a. a -> Maybe a
Just Int
3) Double
secs [Char]
""]
    forall (m :: * -> *) a. Monad m => a -> m a
return ()
    where name :: Text
name = forall a. [a] -> a
last ((Char -> Bool) -> Text -> [Text]
Text.split (forall a. Eq a => a -> a -> Bool
==Char
'.') (Test -> Text
testName Test
test))

-- | Try to save and restore any process level state in case the test messes
-- with it.  Currently this just restores CWD, but probably there is more than
-- that.  For actual isolation probably a subprocess is necessary.
isolate :: IO a -> IO a
isolate :: forall a. IO a -> IO a
isolate = forall a. [Char] -> IO a -> IO a
Directory.withCurrentDirectory [Char]
"."

catch :: Text -> IO a -> IO ()
catch :: forall a. Text -> IO a -> IO ()
catch Text
name IO a
action = do
    Either SomeException a
result <- forall e a. Exception e => IO a -> IO (Either e a)
Exception.try IO a
action
    case Either SomeException a
result of
        Left (SomeException
exc :: Exception.SomeException) -> do
            forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ HasCallStack => Text -> IO ()
Testing.failure forall a b. (a -> b) -> a -> b
$ Text
name forall a. Semigroup a => a -> a -> a
<> Text
" threw exception: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt SomeException
exc
            -- Die on async exception, otherwise it will try to continue
            -- after ^C or out of memory.
            case forall e. Exception e => SomeException -> Maybe e
Exception.fromException SomeException
exc of
                Just (AsyncException
exc :: Exception.AsyncException) -> forall e a. Exception e => e -> IO a
Exception.throwIO AsyncException
exc
                Maybe AsyncException
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
        Right a
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- * queue

-- | This is a simple channel which is written to once, and read from until
-- empty.
newtype Queue a = Queue (MVar.MVar [a])

newQueue :: [a] -> IO (Queue a)
newQueue :: forall a. [a] -> IO (Queue a)
newQueue = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. MVar [a] -> Queue a
Queue forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> IO (MVar a)
MVar.newMVar

takeQueue :: Queue a -> IO (Maybe a)
takeQueue :: forall a. Queue a -> IO (Maybe a)
takeQueue (Queue MVar [a]
mvar) = forall a b. MVar a -> (a -> IO (a, b)) -> IO b
MVar.modifyMVar MVar [a]
mvar forall a b. (a -> b) -> a -> b
$ \[a]
as -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ case [a]
as of
    [] -> ([], forall a. Maybe a
Nothing)
    a
a : [a]
as -> ([a]
as, forall a. a -> Maybe a
Just a
a)

-- * check output

-- | Empty the directory, but don't remove it entirely, in case it's /tmp or
-- something.
clearDirectory :: FilePath -> IO ()
clearDirectory :: [Char] -> IO ()
clearDirectory [Char]
dir =
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ [Char] -> IO ()
rm forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a -> a
fromMaybe [] forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall a. IO a -> IO (Maybe a)
Exceptions.ignoreEnoent ([Char] -> IO [[Char]]
Files.list [Char]
dir)
    where
    -- Let's not go all the way to Directory.removePathForcibly.
    rm :: [Char] -> IO ()
rm [Char]
fn = [Char] -> IO Bool
Directory.doesDirectoryExist [Char]
fn forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Bool
isDir -> if Bool
isDir
        then [Char] -> IO ()
Directory.removeDirectoryRecursive [Char]
fn
        else [Char] -> IO ()
Directory.removeFile [Char]
fn

checkOutputs :: [FilePath] -> IO Bool
checkOutputs :: [[Char]] -> IO Bool
checkOutputs [[Char]]
outputs = do
    ([Text]
failureContext, Int
failures, Int
checks, Int
tests) <-
        Text -> ([Text], Int, Int, Int)
extractStats forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) b a.
(Monad m, Monoid b) =>
(a -> m b) -> [a] -> m b
concatMapM [Char] -> IO Text
readFileEmpty [[Char]]
outputs
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
failureContext) forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
putStrLn [Char]
"\n*** FAILURES:"
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Text -> IO ()
Text.IO.putStrLn [Text]
failureContext
    Text -> IO ()
Text.IO.putStrLn forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> Text
showt Int
failures forall a. Semigroup a => a -> a -> a
<> Text
" failed / "
        forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt Int
checks forall a. Semigroup a => a -> a -> a
<> Text
" checks / " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt Int
tests forall a. Semigroup a => a -> a -> a
<> Text
" tests"
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Int
failures forall a. Eq a => a -> a -> Bool
== Int
0

readFileEmpty :: FilePath -> IO Text.Lazy.Text
readFileEmpty :: [Char] -> IO Text
readFileEmpty = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. a -> Maybe a -> a
fromMaybe Text
"") forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. IO a -> IO (Maybe a)
Exceptions.ignoreEnoent
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> IO Text
Text.Lazy.IO.readFile

extractStats :: Text.Lazy.Text -> ([Text], Int, Int, Int)
    -- ^ (failureContext, failures, checks, tests)
extractStats :: Text -> ([Text], Int, Int, Int)
extractStats = forall {t :: * -> *}.
Foldable t =>
t [Text] -> ([Text], Int, Int, Int)
collect forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Int -> [a] -> [a]
drop Int
1 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [[a]]
Lists.splitBefore Text -> Bool
isTest forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text]
Text.Lazy.lines
    where
    collect :: t [Text] -> ([Text], Int, Int, Int)
collect t [Text]
tests = ([Text]
failures, forall (t :: * -> *) a. Foldable t => t a -> Int
length [Text]
failures, forall (t :: * -> *) a. Foldable t => t a -> Int
length [Maybe Text]
extracted, forall (t :: * -> *) a. Foldable t => t a -> Int
length t [Text]
tests)
        where
        failures :: [Text]
failures = forall a. [Maybe a] -> [a]
Maybe.catMaybes [Maybe Text]
extracted
        extracted :: [Maybe Text]
extracted = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ([Text] -> [Maybe Text]
extractFailures forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Int -> [a] -> [a]
drop Int
1) t [Text]
tests
    isTest :: Text -> Bool
isTest = ((Text -> Text
Text.Lazy.fromStrict (Text
metaPrefix forall a. Semigroup a => a -> a -> a
<> Text
" run-test"))
        `Text.Lazy.isPrefixOf`)

-- | Collect lines before and after each failure for context.
--
-- I collect before because that's where debugging info about that test is
-- likely to show up, and I collect after because the failure output may
-- have multiple lines.
--
-- It can be confusing that I can get the failure lines of the previous test as
-- context for the current one.  To fix that I'd have to explicitly mark all
-- lines of the failure, or put some ending marker afterwards.  It's not hard
-- but maybe not worth it.
extractFailures :: [Text.Lazy.Text] -> [Maybe Text]
    -- ^ Just context for a failure, Nothing for a success.
extractFailures :: [Text] -> [Maybe Text]
extractFailures = forall a b. (a -> b) -> [a] -> [b]
map ([Text], Text, [Text]) -> Maybe Text
convert forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> [([Text], Text, [Text])]
toChunks
    where
    convert :: ([Text], Text, [Text]) -> Maybe Text
convert ([Text]
pre, Text
test, [Text]
post)
        | Text -> Bool
isFailure Text
test = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Text -> Text
Text.Lazy.toStrict forall a b. (a -> b) -> a -> b
$ [Text] -> Text
Text.Lazy.unlines forall a b. (a -> b) -> a -> b
$
            [Text]
pre forall a. [a] -> [a] -> [a]
++ [Text
test] forall a. [a] -> [a] -> [a]
++ [Text]
post
        | Bool
otherwise = forall a. Maybe a
Nothing
    toChunks :: [Text] -> [([Text], Text, [Text])]
toChunks [] = []
    toChunks [Text]
lines
        | Text
test forall a. Eq a => a -> a -> Bool
== Text
"" = []
        | Bool
otherwise = ([Text]
pre, Text
test, [Text]
post) forall a. a -> [a] -> [a]
: [Text] -> [([Text], Text, [Text])]
toChunks [Text]
rest2
        where
        ([Text]
pre, [Text]
rest1) = forall a. (a -> Bool) -> [a] -> ([a], [a])
break Text -> Bool
isTest [Text]
lines
        (Text
test, [Text]
rest2) = case [Text]
rest1 of
            Text
x : [Text]
xs -> (Text
x, [Text]
xs)
            [] -> (Text
"", [])
        post :: [Text]
post = forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Bool
isTest) [Text]
rest2

    isTest :: Text -> Bool
isTest Text
s = Text -> Bool
isFailure Text
s Bool -> Bool -> Bool
|| Text -> Bool
isSuccess Text
s
    isFailure :: Text -> Bool
isFailure = (Text
"__-> " `Text.Lazy.isPrefixOf`)
    isSuccess :: Text -> Bool
isSuccess = (Text
"++-> " `Text.Lazy.isPrefixOf`)