module Testlib.Run (main, mainI) where

import Control.Concurrent
import Control.Exception as E
import Control.Monad
import Control.Monad.Codensity
import Control.Monad.IO.Class
import Data.Foldable
import Data.Function
import Data.Functor
import Data.List
import Data.Time.Clock
import RunAllTests
import System.Directory
import System.Environment
import System.Exit
import System.FilePath
import Testlib.Assertions
import Testlib.Env
import Testlib.Options
import Testlib.Printing
import Testlib.Types
import Testlib.XML
import Text.Printf
import UnliftIO.Async
import Prelude

runTest :: GlobalEnv -> App a -> IO (Either String a)
runTest :: forall a. GlobalEnv -> App a -> IO (Either String a)
runTest GlobalEnv
ge App a
action = Codensity IO (Either String a) -> IO (Either String a)
forall (f :: * -> *) a. Applicative f => Codensity f a -> f a
lowerCodensity (Codensity IO (Either String a) -> IO (Either String a))
-> Codensity IO (Either String a) -> IO (Either String a)
forall a b. (a -> b) -> a -> b
$ do
  Env
env <- GlobalEnv -> Codensity IO Env
mkEnv GlobalEnv
ge
  IO (Either String a) -> Codensity IO (Either String a)
forall a. IO a -> Codensity IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either String a) -> Codensity IO (Either String a))
-> IO (Either String a) -> Codensity IO (Either String a)
forall a b. (a -> b) -> a -> b
$
    (a -> Either String a
forall a b. b -> Either a b
Right (a -> Either String a) -> IO a -> IO (Either String a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Env -> App a -> IO a
forall a. Env -> App a -> IO a
runAppWithEnv Env
env App a
action)
      IO (Either String a)
-> [Handler (Either String a)] -> IO (Either String a)
forall a. IO a -> [Handler a] -> IO a
`E.catches` [ (SomeAsyncException -> IO (Either String a))
-> Handler (Either String a)
forall a e. Exception e => (e -> IO a) -> Handler a
E.Handler ((SomeAsyncException -> IO (Either String a))
 -> Handler (Either String a))
-> (SomeAsyncException -> IO (Either String a))
-> Handler (Either String a)
forall a b. (a -> b) -> a -> b
$ \(SomeAsyncException
e :: SomeAsyncException) -> do
                      -- AsyncExceptions need rethrowing
                      -- to prevent the last handler from handling async exceptions.
                      -- This ensures things like UserInterrupt are properly handled.
                      SomeAsyncException -> IO (Either String a)
forall a e. Exception e => e -> a
E.throw SomeAsyncException
e,
                    (AssertionFailure -> IO (Either String a))
-> Handler (Either String a)
forall a e. Exception e => (e -> IO a) -> Handler a
E.Handler -- AssertionFailure
                      ((String -> Either String a) -> IO String -> IO (Either String a)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> Either String a
forall a b. a -> Either a b
Left (IO String -> IO (Either String a))
-> (AssertionFailure -> IO String)
-> AssertionFailure
-> IO (Either String a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AssertionFailure -> IO String
printFailureDetails),
                    (AppFailure -> IO (Either String a)) -> Handler (Either String a)
forall a e. Exception e => (e -> IO a) -> Handler a
E.Handler -- AppFailure
                      ((String -> Either String a) -> IO String -> IO (Either String a)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> Either String a
forall a b. a -> Either a b
Left (IO String -> IO (Either String a))
-> (AppFailure -> IO String) -> AppFailure -> IO (Either String a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AppFailure -> IO String
printAppFailureDetails),
                    (SomeException -> IO (Either String a))
-> Handler (Either String a)
forall a e. Exception e => (e -> IO a) -> Handler a
E.Handler
                      ((String -> Either String a) -> IO String -> IO (Either String a)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> Either String a
forall a b. a -> Either a b
Left (IO String -> IO (Either String a))
-> (SomeException -> IO String)
-> SomeException
-> IO (Either String a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SomeException -> IO String
printExceptionDetails)
                  ]

pluralise :: Int -> String -> String
pluralise :: Int -> String -> String
pluralise Int
1 String
x = String
x
pluralise Int
_ String
x = String
x String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"s"

printReport :: TestSuiteReport -> IO ()
printReport :: TestSuiteReport -> IO ()
printReport TestSuiteReport
report = do
  let numTests :: Int
numTests = [TestCaseReport] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length TestSuiteReport
report.cases
      failures :: [TestCaseReport]
failures = (TestCaseReport -> Bool) -> [TestCaseReport] -> [TestCaseReport]
forall a. (a -> Bool) -> [a] -> [a]
filter (\TestCaseReport
testCase -> TestCaseReport
testCase.result TestResult -> TestResult -> Bool
forall a. Eq a => a -> a -> Bool
/= TestResult
TestSuccess) TestSuiteReport
report.cases
      numFailures :: Int
numFailures = [TestCaseReport] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [TestCaseReport]
failures
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
numFailures Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"----------"
  String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> String
forall a. Show a => a -> String
show Int
numTests String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String -> String
pluralise Int
numTests String
"test" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" run."
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
numFailures Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    String -> IO ()
putStrLn String
""
    String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> String -> String
colored String
red (Int -> String
forall a. Show a => a -> String
show Int
numFailures String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" failed " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String -> String
pluralise Int
numFailures String
"test" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
": ")
    [TestCaseReport] -> (TestCaseReport -> IO ()) -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [TestCaseReport]
failures ((TestCaseReport -> IO ()) -> IO ())
-> (TestCaseReport -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \TestCaseReport
testCase ->
      String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
" - " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> TestCaseReport
testCase.name

testFilter :: TestOptions -> String -> Bool
testFilter :: TestOptions -> String -> Bool
testFilter TestOptions
opts String
n = String -> Bool
included String
n Bool -> Bool -> Bool
&& Bool -> Bool
not (String -> Bool
excluded String
n)
  where
    included :: String -> Bool
included String
name =
      ([String] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null TestOptions
opts.includeTests) Bool -> Bool -> Bool
|| (String -> Bool) -> [String] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\String
x -> String
x String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isInfixOf` String
name) TestOptions
opts.includeTests
    excluded :: String -> Bool
excluded String
name = (String -> Bool) -> [String] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\String
x -> String
x String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isInfixOf` String
name) TestOptions
opts.excludeTests

withTime :: IO a -> IO (a, NominalDiffTime)
withTime :: forall a. IO a -> IO (a, NominalDiffTime)
withTime IO a
action = do
  UTCTime
tm0 <- IO UTCTime
getCurrentTime
  a
a <- IO a
action
  UTCTime
tm1 <- IO UTCTime
getCurrentTime
  (a, NominalDiffTime) -> IO (a, NominalDiffTime)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a
a, UTCTime -> UTCTime -> NominalDiffTime
diffUTCTime UTCTime
tm1 UTCTime
tm0)

printTime :: NominalDiffTime -> String
printTime :: NominalDiffTime -> String
printTime =
  String -> Float -> String
forall r. PrintfType r => String -> r
printf String
"%.02f s"
    (Float -> String)
-> (NominalDiffTime -> Float) -> NominalDiffTime -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
100.0)
    (Float -> Float)
-> (NominalDiffTime -> Float) -> NominalDiffTime -> Float
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Integer -> Float
forall a b. (Integral a, Num b) => a -> b
fromIntegral :: Integer -> Float)
    (Integer -> Float)
-> (NominalDiffTime -> Integer) -> NominalDiffTime -> Float
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pico -> Integer
forall b. Integral b => Pico -> b
forall a b. (RealFrac a, Integral b) => a -> b
truncate
    (Pico -> Integer)
-> (NominalDiffTime -> Pico) -> NominalDiffTime -> Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Pico -> Pico -> Pico
forall a. Num a => a -> a -> a
* Pico
100)
    (Pico -> Pico)
-> (NominalDiffTime -> Pico) -> NominalDiffTime -> Pico
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NominalDiffTime -> Pico
nominalDiffTimeToSeconds

main :: IO ()
main :: IO ()
main = do
  TestOptions
opts <- IO TestOptions
getOptions
  let f :: String -> Bool
f = TestOptions -> String -> Bool
testFilter TestOptions
opts
      cfg :: String
cfg = TestOptions
opts.configFile

  [Test]
allTests <- IO [Test]
mkAllTests
  let tests :: [(String, String, String, App ())]
tests =
        ((String, String, String, App ()) -> Bool)
-> [(String, String, String, App ())]
-> [(String, String, String, App ())]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(String
qname, String
_, String
_, App ()
_) -> String -> Bool
f String
qname)
          ([(String, String, String, App ())]
 -> [(String, String, String, App ())])
-> ([(String, String, String, App ())]
    -> [(String, String, String, App ())])
-> [(String, String, String, App ())]
-> [(String, String, String, App ())]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((String, String, String, App ()) -> String)
-> [(String, String, String, App ())]
-> [(String, String, String, App ())]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn (\(String
qname, String
_, String
_, App ()
_) -> String
qname)
          ([(String, String, String, App ())]
 -> [(String, String, String, App ())])
-> [(String, String, String, App ())]
-> [(String, String, String, App ())]
forall a b. (a -> b) -> a -> b
$ [Test]
allTests [Test]
-> (Test -> (String, String, String, App ()))
-> [(String, String, String, App ())]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \(String
module_, String
name, String
summary, String
full, App ()
action) ->
            let module0 :: String
module0 = case String
module_ of
                  (Char
'T' : Char
'e' : Char
's' : Char
't' : Char
'.' : String
m) -> String
m
                  String
_ -> String
module_
                qualifiedName :: String
qualifiedName = String
module0 String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"." String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
name
             in (String
qualifiedName, String
summary, String
full, App ()
action)

  if TestOptions
opts.listTests then [(String, String, String, App ())] -> IO ()
forall x. [(String, String, String, x)] -> IO ()
doListTests [(String, String, String, App ())]
tests else [(String, String, String, App ())]
-> Maybe String -> String -> IO ()
forall x y.
[(String, x, y, App ())] -> Maybe String -> String -> IO ()
runTests [(String, String, String, App ())]
tests TestOptions
opts.xmlReport String
cfg

runTests :: [(String, x, y, App ())] -> Maybe FilePath -> FilePath -> IO ()
runTests :: forall x y.
[(String, x, y, App ())] -> Maybe String -> String -> IO ()
runTests [(String, x, y, App ())]
tests Maybe String
mXMLOutput String
cfg = do
  Chan (Maybe String)
output <- IO (Chan (Maybe String))
forall a. IO (Chan a)
newChan
  let displayOutput :: IO ()
displayOutput =
        Chan (Maybe String) -> IO (Maybe String)
forall a. Chan a -> IO a
readChan Chan (Maybe String)
output IO (Maybe String) -> (Maybe String -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
          Just String
x -> String -> IO ()
putStr String
x IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> IO ()
displayOutput
          Maybe String
Nothing -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  let writeOutput :: String -> IO ()
writeOutput = Chan (Maybe String) -> Maybe String -> IO ()
forall a. Chan a -> a -> IO ()
writeChan Chan (Maybe String)
output (Maybe String -> IO ())
-> (String -> Maybe String) -> String -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Maybe String
forall k1. k1 -> Maybe k1
Just

  Codensity IO GlobalEnv -> forall b. (GlobalEnv -> IO b) -> IO b
forall k (m :: k -> *) a.
Codensity m a -> forall (b :: k). (a -> m b) -> m b
runCodensity (String -> Codensity IO GlobalEnv
mkGlobalEnv String
cfg) ((GlobalEnv -> IO ()) -> IO ()) -> (GlobalEnv -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \GlobalEnv
genv ->
    IO () -> (Async () -> IO ()) -> IO ()
forall (m :: * -> *) a b.
MonadUnliftIO m =>
m a -> (Async a -> m b) -> m b
withAsync IO ()
displayOutput ((Async () -> IO ()) -> IO ()) -> (Async () -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Async ()
displayThread -> do
      -- Currently 4 seems to be stable, more seems to create more timeouts.
      TestSuiteReport
report <- ([TestSuiteReport] -> TestSuiteReport)
-> IO [TestSuiteReport] -> IO TestSuiteReport
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [TestSuiteReport] -> TestSuiteReport
forall a. Monoid a => [a] -> a
mconcat (IO [TestSuiteReport] -> IO TestSuiteReport)
-> IO [TestSuiteReport] -> IO TestSuiteReport
forall a b. (a -> b) -> a -> b
$ Int
-> [(String, x, y, App ())]
-> ((String, x, y, App ()) -> IO TestSuiteReport)
-> IO [TestSuiteReport]
forall (m :: * -> *) (t :: * -> *) a b.
(MonadUnliftIO m, Traversable t) =>
Int -> t a -> (a -> m b) -> m (t b)
pooledForConcurrentlyN Int
4 [(String, x, y, App ())]
tests (((String, x, y, App ()) -> IO TestSuiteReport)
 -> IO [TestSuiteReport])
-> ((String, x, y, App ()) -> IO TestSuiteReport)
-> IO [TestSuiteReport]
forall a b. (a -> b) -> a -> b
$ \(String
qname, x
_, y
_, App ()
action) -> do
        (Either String ()
mErr, NominalDiffTime
tm) <- IO (Either String ()) -> IO (Either String (), NominalDiffTime)
forall a. IO a -> IO (a, NominalDiffTime)
withTime (GlobalEnv -> App () -> IO (Either String ())
forall a. GlobalEnv -> App a -> IO (Either String a)
runTest GlobalEnv
genv App ()
action)
        case Either String ()
mErr of
          Left String
err -> do
            String -> IO ()
writeOutput (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
              String
"----- "
                String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
qname
                String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String -> String -> String
colored String
red String
" FAIL"
                String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" ("
                String -> String -> String
forall a. Semigroup a => a -> a -> a
<> NominalDiffTime -> String
printTime NominalDiffTime
tm
                String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
") -----\n"
                String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
err
                String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"\n"
            TestSuiteReport -> IO TestSuiteReport
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([TestCaseReport] -> TestSuiteReport
TestSuiteReport [String -> TestResult -> NominalDiffTime -> TestCaseReport
TestCaseReport String
qname (String -> TestResult
TestFailure String
err) NominalDiffTime
tm])
          Right ()
_ -> do
            String -> IO ()
writeOutput (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
qname String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String -> String -> String
colored String
green String
" OK" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" (" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> NominalDiffTime -> String
printTime NominalDiffTime
tm String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
")" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"\n"
            TestSuiteReport -> IO TestSuiteReport
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([TestCaseReport] -> TestSuiteReport
TestSuiteReport [String -> TestResult -> NominalDiffTime -> TestCaseReport
TestCaseReport String
qname TestResult
TestSuccess NominalDiffTime
tm])
      Chan (Maybe String) -> Maybe String -> IO ()
forall a. Chan a -> a -> IO ()
writeChan Chan (Maybe String)
output Maybe String
forall k1. Maybe k1
Nothing
      Async () -> IO ()
forall (m :: * -> *) a. MonadIO m => Async a -> m a
wait Async ()
displayThread
      TestSuiteReport -> IO ()
printReport TestSuiteReport
report
      (String -> IO ()) -> Maybe String -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (TestSuiteReport -> String -> IO ()
saveXMLReport TestSuiteReport
report) Maybe String
mXMLOutput
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ((TestCaseReport -> Bool) -> [TestCaseReport] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\TestCaseReport
testCase -> TestCaseReport
testCase.result TestResult -> TestResult -> Bool
forall a. Eq a => a -> a -> Bool
/= TestResult
TestSuccess) TestSuiteReport
report.cases) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        IO ()
forall a. IO a
exitFailure

doListTests :: [(String, String, String, x)] -> IO ()
doListTests :: forall x. [(String, String, String, x)] -> IO ()
doListTests [(String, String, String, x)]
tests = [(String, String, String, x)]
-> ((String, String, String, x) -> IO ()) -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [(String, String, String, x)]
tests (((String, String, String, x) -> IO ()) -> IO ())
-> ((String, String, String, x) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(String
qname, String
_desc, String
_full, x
_) -> do
  String -> IO ()
putStrLn String
qname

-- like `main` but meant to run from a repl
mainI :: [String] -> IO ()
mainI :: [String] -> IO ()
mainI [String]
args = do
  let projectRoot :: String
projectRoot = String
"../"
  [String] -> IO () -> IO ()
forall a. [String] -> IO a -> IO a
withArgs [String]
args (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
    String -> IO () -> IO ()
forall a. String -> IO a -> IO a
withCurrentDirectory String
projectRoot (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
      IO ()
main