-- |
-- Module      : Foundation.Check.Main
-- License     : BSD-style
-- Maintainer  : Foundation maintainers
--
-- An application to check that integrate with the .cabal test-suite
--
{-# LANGUAGE ExistentialQuantification  #-}
{-# LANGUAGE Rank2Types                 #-}
{-# LANGUAGE GADTs                      #-}
{-# LANGUAGE OverloadedStrings          #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE ScopedTypeVariables        #-}
module Foundation.Check.Main
    ( defaultMain
    ) where

import           Basement.Imports
import           Basement.IntegralConv
import           Basement.Cast (cast)
import           Basement.Bounded
import           Basement.Types.OffsetSize
import qualified Basement.Terminal.ANSI as ANSI
import qualified Basement.Terminal as Terminal
import           Foundation.Collection
import           Foundation.Numerical
import           Foundation.IO.Terminal
import           Foundation.Check (iterateProperty)
import           Foundation.Check.Gen
import           Foundation.Check.Property
import           Foundation.Check.Config
import           Foundation.Check.Types
import           Foundation.List.DList
import           Foundation.Random
import           Foundation.Monad
import           Foundation.Monad.State
import           Data.Maybe (catMaybes)

nbFail :: TestResult -> HasFailures
nbFail :: TestResult -> CountOf TestResult
nbFail (PropertyResult String
_ CountOf TestResult
_ (PropertyFailed String
_)) = CountOf TestResult
1
nbFail (PropertyResult String
_ CountOf TestResult
_ PropertyResult
PropertySuccess)    = CountOf TestResult
0
nbFail (GroupResult    String
_ CountOf TestResult
t CountOf TestResult
_ [TestResult]
_)                = CountOf TestResult
t

nbTests :: TestResult -> CountOf TestResult
nbTests :: TestResult -> CountOf TestResult
nbTests (PropertyResult String
_ CountOf TestResult
t PropertyResult
_) = CountOf TestResult
t
nbTests (GroupResult String
_ CountOf TestResult
_ CountOf TestResult
t [TestResult]
_)  = CountOf TestResult
t

data TestState = TestState
    { TestState -> Config
config      :: !Config
    , TestState -> Word64
getSeed     :: !Seed
    , TestState -> CountOf Char
indent      :: !(CountOf Char)
    , TestState -> Word
testPassed  :: !Word
    , TestState -> Word
testFailed  :: !Word
    , TestState -> DList String
testPath    :: !(DList String)
    }

newState :: Config -> Seed -> TestState
newState :: Config -> Word64 -> TestState
newState Config
cfg Word64
initSeed = TestState
    { testPath :: DList String
testPath     = DList String
forall a. Monoid a => a
mempty
    , testPassed :: Word
testPassed   = Word
0
    , testFailed :: Word
testFailed   = Word
0
    , indent :: CountOf Char
indent       = CountOf Char
0
    , getSeed :: Word64
getSeed      = Word64
initSeed
    , config :: Config
config       = Config
cfg
    }

filterTestMatching :: Config -> Test -> Maybe Test
filterTestMatching :: Config -> Test -> Maybe Test
filterTestMatching Config
cfg Test
testRoot
    | [String] -> Bool
forall c. Collection c => c -> Bool
null (Config -> [String]
testNameMatch Config
cfg) = Test -> Maybe Test
forall a. a -> Maybe a
Just Test
testRoot
    | Bool
otherwise                = [String] -> Test -> Maybe Test
testFilter [] Test
testRoot
  where
    match :: [String] -> String -> Bool
match [String]
acc String
s = [Bool] -> Bool
forall col. (Collection col, Element col ~ Bool) => col -> Bool
or ((String -> String -> Bool) -> String -> String -> Bool
forall a b c. (a -> b -> c) -> b -> a -> c
flip String -> String -> Bool
forall c. (Sequential c, Eq (Element c)) => c -> c -> Bool
isInfixOf String
currentTestName (String -> Bool) -> [String] -> [Bool]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Config -> [String]
testNameMatch Config
cfg)
      where currentTestName :: String
currentTestName = [String] -> String
fqTestName (String
sString -> [String] -> [String]
forall a. a -> [a] -> [a]
:[String]
acc)

    testFilter :: [String] -> Test -> Maybe Test
testFilter [String]
acc Test
x =
        case Test
x of
            Group String
s [Test]
l    ->
                let filtered :: [Test]
filtered = [Maybe Test] -> [Test]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe Test] -> [Test]) -> [Maybe Test] -> [Test]
forall a b. (a -> b) -> a -> b
$ (Test -> Maybe Test) -> [Test] -> [Maybe Test]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([String] -> Test -> Maybe Test
testFilter (String
sString -> [String] -> [String]
forall a. a -> [a] -> [a]
:[String]
acc)) [Test]
l
                 in if [Test] -> Bool
forall c. Collection c => c -> Bool
null [Test]
filtered then Maybe Test
forall a. Maybe a
Nothing else Test -> Maybe Test
forall a. a -> Maybe a
Just (String -> [Test] -> Test
Group String
s [Test]
filtered)
            CheckPlan String
s Check ()
_
                | [String] -> String -> Bool
match [String]
acc String
s -> Test -> Maybe Test
forall a. a -> Maybe a
Just Test
x
                | Bool
otherwise   -> Maybe Test
forall a. Maybe a
Nothing
            Unit String
s IO ()
_
                | [String] -> String -> Bool
match [String]
acc String
s -> Test -> Maybe Test
forall a. a -> Maybe a
Just Test
x
                | Bool
otherwise   -> Maybe Test
forall a. Maybe a
Nothing
            Property String
s prop
_
                | [String] -> String -> Bool
match [String]
acc String
s -> Test -> Maybe Test
forall a. a -> Maybe a
Just Test
x
                | Bool
otherwise   -> Maybe Test
forall a. Maybe a
Nothing

-- | Run tests
defaultMain :: Test -> IO ()
defaultMain :: Test -> IO ()
defaultMain Test
allTestRoot = do
    IO ()
Terminal.initialize

    -- parse arguments
    ecfg <- ([String] -> Config -> Either String Config)
-> Config -> [String] -> Either String Config
forall a b c. (a -> b -> c) -> b -> a -> c
flip [String] -> Config -> Either String Config
parseArgs Config
defaultConfig ([String] -> Either String Config)
-> IO [String] -> IO (Either String Config)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO [String]
getArgs
    cfg  <- case ecfg of
            Left String
e  -> do
                String -> IO ()
putStrLn String
e
                (String -> IO ()) -> [String] -> IO ()
forall (col :: * -> *) (m :: * -> *) a b.
(Mappable col, Applicative m, Monad m) =>
(a -> m b) -> col a -> m ()
mapM_ String -> IO ()
putStrLn [String]
configHelp
                IO Config
forall a. IO a
exitFailure
            Right Config
c -> Config -> IO Config
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Config
c

    -- use the user defined seed or generate a new seed
    seed <- maybe getRandomWord64 pure $ udfSeed cfg

    let testState = Config -> Word64 -> TestState
newState Config
cfg Word64
seed

    when (helpRequested cfg) (mapM_ putStrLn configHelp >> exitSuccess)
    when (listTests cfg) (printTestName >> exitSuccess)

    putStrLn $ "\nSeed: " <> show seed <> "\n"

    case filterTestMatching cfg allTestRoot of
        Maybe Test
Nothing -> String -> IO ()
putStrLn String
"no tests to run" IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
forall a. IO a
exitSuccess
        Just Test
t  -> do
            (_, cfg') <- StateT TestState IO TestResult
-> TestState -> IO (TestResult, TestState)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT (CheckMain TestResult -> StateT TestState IO TestResult
forall a. CheckMain a -> StateT TestState IO a
runCheckMain (CheckMain TestResult -> StateT TestState IO TestResult)
-> CheckMain TestResult -> StateT TestState IO TestResult
forall a b. (a -> b) -> a -> b
$ Test -> CheckMain TestResult
test Test
t) TestState
testState
            summary cfg'

  where
    -- display a summary of the result and use the right exit code
    summary :: TestState -> IO b
summary TestState
cfg
        | Word
kos Word -> Word -> Bool
forall a. Ord a => a -> a -> Bool
> Word
0 = do
            String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
red String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"Failed " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Word -> String
forall a. Show a => a -> String
show Word
kos String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" out of " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Word -> String
forall a. Show a => a -> String
show Word
tot String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
reset
            IO b
forall a. IO a
exitFailure
        | Bool
otherwise = do
            String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
green String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"Succeed " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Word -> String
forall a. Show a => a -> String
show Word
oks String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" test(s)" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
reset
            IO b
forall a. IO a
exitSuccess
      where
        oks :: Word
oks = TestState -> Word
testPassed TestState
cfg
        kos :: Word
kos = TestState -> Word
testFailed TestState
cfg
        tot :: Word
tot = Word
oks Word -> Word -> Word
forall a. Additive a => a -> a -> a
+ Word
kos

    -- print all the tests recursively
    printTestName :: IO ()
printTestName = ([String] -> IO ()) -> [[String]] -> IO ()
forall (col :: * -> *) (m :: * -> *) a b.
(Mappable col, Applicative m, Monad m) =>
(a -> m b) -> col a -> m ()
mapM_ (\[String]
tst -> String -> IO ()
putStrLn ([String] -> String
fqTestName [String]
tst)) ([[String]] -> IO ()) -> [[String]] -> IO ()
forall a b. (a -> b) -> a -> b
$ [(Test, [String])] -> [Test] -> [String] -> Test -> [[String]]
testCases [] [] [] Test
allTestRoot
      where
        testCases :: [(Test, [String])] -> [Test] -> [String] -> Test -> [[String]]
testCases [(Test, [String])]
acc [Test]
xs [String]
pre Test
x =
            case Test
x of
                Group String
s [Test]
l     -> [(Test, [String])] -> [String] -> [Test] -> [[String]]
tToList ((Test -> (Test, [String])) -> [Test] -> [(Test, [String])]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Test
z -> (Test
z, [String]
pre)) [Test]
xs [(Test, [String])] -> [(Test, [String])] -> [(Test, [String])]
forall a. Semigroup a => a -> a -> a
<> [(Test, [String])]
acc) (String
sString -> [String] -> [String]
forall a. a -> [a] -> [a]
:[String]
pre) [Test]
l
                CheckPlan String
s Check ()
_ -> (String
s String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
pre) [String] -> [[String]] -> [[String]]
forall a. a -> [a] -> [a]
: [(Test, [String])] -> [String] -> [Test] -> [[String]]
tToList [(Test, [String])]
acc [String]
pre [Test]
xs
                Unit String
s IO ()
_      -> (String
s String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
pre) [String] -> [[String]] -> [[String]]
forall a. a -> [a] -> [a]
: [(Test, [String])] -> [String] -> [Test] -> [[String]]
tToList [(Test, [String])]
acc [String]
pre [Test]
xs
                Property String
s prop
_  -> (String
s String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
pre) [String] -> [[String]] -> [[String]]
forall a. a -> [a] -> [a]
: [(Test, [String])] -> [String] -> [Test] -> [[String]]
tToList [(Test, [String])]
acc [String]
pre [Test]
xs

        tToList :: [(Test, [String])] -> [String] -> [Test] -> [[String]]
tToList []           [String]
_   []              = []
        tToList ((Test
a,[String]
pre):[(Test, [String])]
as) [String]
_   []              = [(Test, [String])] -> [Test] -> [String] -> Test -> [[String]]
testCases [(Test, [String])]
as [] [String]
pre Test
a
        tToList [(Test, [String])]
acc          [String]
pre (Test
x:[Test]
xs)          = [(Test, [String])] -> [Test] -> [String] -> Test -> [[String]]
testCases [(Test, [String])]
acc [Test]
xs [String]
pre Test
x

-- | internal check monad for facilitating the tests traversal
newtype CheckMain a = CheckMain { forall a. CheckMain a -> StateT TestState IO a
runCheckMain :: StateT TestState IO a }
  deriving ((forall a b. (a -> b) -> CheckMain a -> CheckMain b)
-> (forall a b. a -> CheckMain b -> CheckMain a)
-> Functor CheckMain
forall a b. a -> CheckMain b -> CheckMain a
forall a b. (a -> b) -> CheckMain a -> CheckMain b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> CheckMain a -> CheckMain b
fmap :: forall a b. (a -> b) -> CheckMain a -> CheckMain b
$c<$ :: forall a b. a -> CheckMain b -> CheckMain a
<$ :: forall a b. a -> CheckMain b -> CheckMain a
Functor, Functor CheckMain
Functor CheckMain =>
(forall a. a -> CheckMain a)
-> (forall a b. CheckMain (a -> b) -> CheckMain a -> CheckMain b)
-> (forall a b c.
    (a -> b -> c) -> CheckMain a -> CheckMain b -> CheckMain c)
-> (forall a b. CheckMain a -> CheckMain b -> CheckMain b)
-> (forall a b. CheckMain a -> CheckMain b -> CheckMain a)
-> Applicative CheckMain
forall a. a -> CheckMain a
forall a b. CheckMain a -> CheckMain b -> CheckMain a
forall a b. CheckMain a -> CheckMain b -> CheckMain b
forall a b. CheckMain (a -> b) -> CheckMain a -> CheckMain b
forall a b c.
(a -> b -> c) -> CheckMain a -> CheckMain b -> CheckMain c
forall (f :: * -> *).
Functor f =>
(forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
$cpure :: forall a. a -> CheckMain a
pure :: forall a. a -> CheckMain a
$c<*> :: forall a b. CheckMain (a -> b) -> CheckMain a -> CheckMain b
<*> :: forall a b. CheckMain (a -> b) -> CheckMain a -> CheckMain b
$cliftA2 :: forall a b c.
(a -> b -> c) -> CheckMain a -> CheckMain b -> CheckMain c
liftA2 :: forall a b c.
(a -> b -> c) -> CheckMain a -> CheckMain b -> CheckMain c
$c*> :: forall a b. CheckMain a -> CheckMain b -> CheckMain b
*> :: forall a b. CheckMain a -> CheckMain b -> CheckMain b
$c<* :: forall a b. CheckMain a -> CheckMain b -> CheckMain a
<* :: forall a b. CheckMain a -> CheckMain b -> CheckMain a
Applicative, Applicative CheckMain
Applicative CheckMain =>
(forall a b. CheckMain a -> (a -> CheckMain b) -> CheckMain b)
-> (forall a b. CheckMain a -> CheckMain b -> CheckMain b)
-> (forall a. a -> CheckMain a)
-> Monad CheckMain
forall a. a -> CheckMain a
forall a b. CheckMain a -> CheckMain b -> CheckMain b
forall a b. CheckMain a -> (a -> CheckMain b) -> CheckMain b
forall (m :: * -> *).
Applicative m =>
(forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
$c>>= :: forall a b. CheckMain a -> (a -> CheckMain b) -> CheckMain b
>>= :: forall a b. CheckMain a -> (a -> CheckMain b) -> CheckMain b
$c>> :: forall a b. CheckMain a -> CheckMain b -> CheckMain b
>> :: forall a b. CheckMain a -> CheckMain b -> CheckMain b
$creturn :: forall a. a -> CheckMain a
return :: forall a. a -> CheckMain a
Monad, Monad CheckMain
Monad CheckMain =>
(forall a. IO a -> CheckMain a) -> MonadIO CheckMain
forall a. IO a -> CheckMain a
forall (m :: * -> *).
Monad m =>
(forall a. IO a -> m a) -> MonadIO m
$cliftIO :: forall a. IO a -> CheckMain a
liftIO :: forall a. IO a -> CheckMain a
MonadIO)

instance MonadState CheckMain where
    type State CheckMain = TestState
    withState :: forall a. (State CheckMain -> (a, State CheckMain)) -> CheckMain a
withState = StateT TestState IO a -> CheckMain a
forall a. StateT TestState IO a -> CheckMain a
CheckMain (StateT TestState IO a -> CheckMain a)
-> ((TestState -> (a, TestState)) -> StateT TestState IO a)
-> (TestState -> (a, TestState))
-> CheckMain a
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (State (StateT TestState IO) -> (a, State (StateT TestState IO)))
-> StateT TestState IO a
(TestState -> (a, TestState)) -> StateT TestState IO a
forall a.
(State (StateT TestState IO) -> (a, State (StateT TestState IO)))
-> StateT TestState IO a
forall (m :: * -> *) a.
MonadState m =>
(State m -> (a, State m)) -> m a
withState

onDisplayOption :: DisplayOption -> CheckMain () -> CheckMain ()
onDisplayOption :: DisplayOption -> CheckMain () -> CheckMain ()
onDisplayOption DisplayOption
opt CheckMain ()
chk = do
    on <- DisplayOption -> DisplayOption -> Bool
forall a. Ord a => a -> a -> Bool
(<=) DisplayOption
opt (DisplayOption -> Bool)
-> (TestState -> DisplayOption) -> TestState -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Config -> DisplayOption
displayOptions (Config -> DisplayOption)
-> (TestState -> Config) -> TestState -> DisplayOption
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. TestState -> Config
config (TestState -> Bool) -> CheckMain TestState -> CheckMain Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CheckMain (State CheckMain)
CheckMain TestState
forall (m :: * -> *). MonadState m => m (State m)
get
    if on then chk else return ()

whenErrorOnly :: CheckMain () -> CheckMain ()
whenErrorOnly :: CheckMain () -> CheckMain ()
whenErrorOnly = DisplayOption -> CheckMain () -> CheckMain ()
onDisplayOption DisplayOption
DisplayTerminalErrorOnly

whenGroupOnly :: CheckMain () -> CheckMain ()
whenGroupOnly :: CheckMain () -> CheckMain ()
whenGroupOnly = DisplayOption -> CheckMain () -> CheckMain ()
onDisplayOption DisplayOption
DisplayGroupOnly

whenVerbose :: CheckMain () -> CheckMain ()
whenVerbose :: CheckMain () -> CheckMain ()
whenVerbose = DisplayOption -> CheckMain () -> CheckMain ()
onDisplayOption DisplayOption
DisplayTerminalVerbose

passed :: CheckMain ()
passed :: CheckMain ()
passed = (State CheckMain -> ((), State CheckMain)) -> CheckMain ()
forall a. (State CheckMain -> (a, State CheckMain)) -> CheckMain a
forall (m :: * -> *) a.
MonadState m =>
(State m -> (a, State m)) -> m a
withState ((State CheckMain -> ((), State CheckMain)) -> CheckMain ())
-> (State CheckMain -> ((), State CheckMain)) -> CheckMain ()
forall a b. (a -> b) -> a -> b
$ \State CheckMain
s -> ((), State CheckMain
s { testPassed = testPassed s + 1 })

failed :: CheckMain ()
failed :: CheckMain ()
failed = (State CheckMain -> ((), State CheckMain)) -> CheckMain ()
forall a. (State CheckMain -> (a, State CheckMain)) -> CheckMain a
forall (m :: * -> *) a.
MonadState m =>
(State m -> (a, State m)) -> m a
withState ((State CheckMain -> ((), State CheckMain)) -> CheckMain ())
-> (State CheckMain -> ((), State CheckMain)) -> CheckMain ()
forall a b. (a -> b) -> a -> b
$ \State CheckMain
s -> ((), State CheckMain
s { testFailed = testFailed s + 1 })

test :: Test -> CheckMain TestResult
test :: Test -> CheckMain TestResult
test (Group String
s [Test]
l) = String -> [Test] -> CheckMain TestResult
pushGroup String
s [Test]
l
test (Unit String
_ IO ()
_) = CheckMain TestResult
forall a. HasCallStack => a
undefined
test (CheckPlan String
name Check ()
plan) = do
    String -> Check () -> CheckMain TestResult
testCheckPlan String
name Check ()
plan
test (Property String
name prop
prop) = do
    r <- String -> Property -> CheckMain TestResult
testProperty String
name (prop -> Property
forall p. IsProperty p => p -> Property
property prop
prop)
    case r of
        (PropertyResult String
_ CountOf TestResult
nb PropertyResult
PropertySuccess)    -> CheckMain () -> CheckMain ()
whenVerbose (CheckMain () -> CheckMain ()) -> CheckMain () -> CheckMain ()
forall a b. (a -> b) -> a -> b
$ String -> CountOf TestResult -> CheckMain ()
displayPropertySucceed String
name CountOf TestResult
nb
        (PropertyResult String
_ CountOf TestResult
nb (PropertyFailed String
w)) -> CheckMain () -> CheckMain ()
whenErrorOnly (CheckMain () -> CheckMain ()) -> CheckMain () -> CheckMain ()
forall a b. (a -> b) -> a -> b
$ String -> CountOf TestResult -> String -> CheckMain ()
displayPropertyFailed String
name CountOf TestResult
nb String
w
        GroupResult {} -> String -> CheckMain ()
forall a. HasCallStack => String -> a
error String
"internal error: should not happen"
    return r

displayCurrent :: String -> CheckMain ()
displayCurrent :: String -> CheckMain ()
displayCurrent String
name = do
    i <- TestState -> CountOf Char
indent (TestState -> CountOf Char)
-> CheckMain TestState -> CheckMain (CountOf Char)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CheckMain (State CheckMain)
CheckMain TestState
forall (m :: * -> *). MonadState m => m (State m)
get
    liftIO $ putStrLn $ replicate i ' ' <> name

displayPropertySucceed :: String -> CountOf TestResult -> CheckMain ()
displayPropertySucceed :: String -> CountOf TestResult -> CheckMain ()
displayPropertySucceed String
name (CountOf Int
nb) = do
    i <- TestState -> CountOf Char
indent (TestState -> CountOf Char)
-> CheckMain TestState -> CheckMain (CountOf Char)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CheckMain (State CheckMain)
CheckMain TestState
forall (m :: * -> *). MonadState m => m (State m)
get
    liftIO $ putStrLn $ mconcat
        [ replicate i ' '
        , successString, name
        , " ("
        , show nb
        , if nb == 1 then " test)" else " tests)"
        ]

unicodeEnabled :: Bool
unicodeEnabled :: Bool
unicodeEnabled = Bool
True

successString :: String
successString :: String
successString
    | Bool
unicodeEnabled = String
green String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" ✓ " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
reset
    | Bool
otherwise      = String
green String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"[SUCCESS] " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
reset
{-# NOINLINE successString #-}

failureString :: String
failureString :: String
failureString
    | Bool
unicodeEnabled = String
red String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" ✗ " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
reset
    | Bool
otherwise      = String
red String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"[ ERROR ] " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
reset
{-# NOINLINE failureString #-}

reset, green, red :: ANSI.Escape
reset :: String
reset = String
ANSI.sgrReset
green :: String
green = ColorComponent -> Bool -> String
ANSI.sgrForeground (Word64 -> ColorComponent
forall (n :: Nat).
(KnownNat n, NatWithinBound Word64 n) =>
Word64 -> Zn64 n
zn64 Word64
2) Bool
True
red :: String
red = ColorComponent -> Bool -> String
ANSI.sgrForeground (Word64 -> ColorComponent
forall (n :: Nat).
(KnownNat n, NatWithinBound Word64 n) =>
Word64 -> Zn64 n
zn64 Word64
1) Bool
True

displayPropertyFailed :: String -> CountOf TestResult -> String -> CheckMain ()
displayPropertyFailed :: String -> CountOf TestResult -> String -> CheckMain ()
displayPropertyFailed String
name (CountOf Int
nb) String
w = do
    seed <- TestState -> Word64
getSeed (TestState -> Word64) -> CheckMain TestState -> CheckMain Word64
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CheckMain (State CheckMain)
CheckMain TestState
forall (m :: * -> *). MonadState m => m (State m)
get
    i <- indent <$> get
    liftIO $ do
        putStrLn $ mconcat
          [ replicate i ' '
          , failureString, name
          , " failed after "
          , show nb
          , if nb == 1 then " test" else " tests:"
          ]
        putStrLn $ replicate i ' ' <> "   use param: --seed " <> show seed
        putStrLn w

pushGroup :: String -> [Test] -> CheckMain TestResult
pushGroup :: String -> [Test] -> CheckMain TestResult
pushGroup String
name [Test]
list = do
    CheckMain () -> CheckMain ()
whenGroupOnly (CheckMain () -> CheckMain ()) -> CheckMain () -> CheckMain ()
forall a b. (a -> b) -> a -> b
$ if [Test] -> Bool
groupHasSubGroup [Test]
list then String -> CheckMain ()
displayCurrent String
name else () -> CheckMain ()
forall a. a -> CheckMain a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    (State CheckMain -> ((), State CheckMain)) -> CheckMain ()
forall a. (State CheckMain -> (a, State CheckMain)) -> CheckMain a
forall (m :: * -> *) a.
MonadState m =>
(State m -> (a, State m)) -> m a
withState ((State CheckMain -> ((), State CheckMain)) -> CheckMain ())
-> (State CheckMain -> ((), State CheckMain)) -> CheckMain ()
forall a b. (a -> b) -> a -> b
$ \State CheckMain
s -> ((), State CheckMain
s { testPath = push (testPath s) name, indent = indent s + 2 })
    results <- (Test -> CheckMain TestResult) -> [Test] -> CheckMain [TestResult]
forall (collection :: * -> *) (m :: * -> *) a b.
(Mappable collection, Applicative m, Monad m) =>
(a -> m b) -> collection a -> m (collection b)
forall (m :: * -> *) a b.
(Applicative m, Monad m) =>
(a -> m b) -> [a] -> m [b]
mapM Test -> CheckMain TestResult
test [Test]
list
    withState $ \State CheckMain
s -> ((), State CheckMain
s { testPath = pop (testPath s), indent = indent s `sizeSub` 2 })
    let totFail = [CountOf TestResult] -> Element [CountOf TestResult]
sum ([CountOf TestResult] -> Element [CountOf TestResult])
-> [CountOf TestResult] -> Element [CountOf TestResult]
forall a b. (a -> b) -> a -> b
$ (TestResult -> CountOf TestResult)
-> [TestResult] -> [CountOf TestResult]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TestResult -> CountOf TestResult
nbFail [TestResult]
results
        tot = [CountOf TestResult] -> Element [CountOf TestResult]
sum ([CountOf TestResult] -> Element [CountOf TestResult])
-> [CountOf TestResult] -> Element [CountOf TestResult]
forall a b. (a -> b) -> a -> b
$ (TestResult -> CountOf TestResult)
-> [TestResult] -> [CountOf TestResult]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TestResult -> CountOf TestResult
nbTests [TestResult]
results
    whenGroupOnly $ case (groupHasSubGroup list, totFail) of
        (Bool
True, CountOf TestResult
_)              -> () -> CheckMain ()
forall a. a -> CheckMain a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        (Bool
False, CountOf TestResult
n) | CountOf TestResult
n CountOf TestResult -> CountOf TestResult -> Bool
forall a. Ord a => a -> a -> Bool
> CountOf TestResult
0     -> String -> CountOf TestResult -> String -> CheckMain ()
displayPropertyFailed String
name CountOf TestResult
n String
""
                   | Bool
otherwise -> String -> CountOf TestResult -> CheckMain ()
displayPropertySucceed String
name CountOf TestResult
Element [CountOf TestResult]
tot
    return $ GroupResult name totFail tot results
  where
    sum :: [CountOf TestResult] -> Element [CountOf TestResult]
sum = (Element [CountOf TestResult]
 -> Element [CountOf TestResult] -> Element [CountOf TestResult])
-> Element [CountOf TestResult]
-> [CountOf TestResult]
-> Element [CountOf TestResult]
forall collection a.
Foldable collection =>
(a -> Element collection -> a) -> a -> collection -> a
forall a.
(a -> Element [CountOf TestResult] -> a)
-> a -> [CountOf TestResult] -> a
foldl' Element [CountOf TestResult]
-> Element [CountOf TestResult] -> Element [CountOf TestResult]
forall a. Additive a => a -> a -> a
(+) Element [CountOf TestResult]
0
    push :: DList String -> Element (DList String) -> DList String
push = DList String -> Element (DList String) -> DList String
forall c. Sequential c => c -> Element c -> c
snoc
    pop :: DList String -> DList String
pop = DList String
-> ((DList String, Element (DList String)) -> DList String)
-> Maybe (DList String, Element (DList String))
-> DList String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe DList String
forall a. Monoid a => a
mempty (DList String, Element (DList String)) -> DList String
forall a b. (a, b) -> a
fst (Maybe (DList String, Element (DList String)) -> DList String)
-> (DList String -> Maybe (DList String, Element (DList String)))
-> DList String
-> DList String
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. DList String -> Maybe (DList String, Element (DList String))
forall c. Sequential c => c -> Maybe (c, Element c)
unsnoc

testCheckPlan :: String -> Check () -> CheckMain TestResult
testCheckPlan :: String -> Check () -> CheckMain TestResult
testCheckPlan String
name Check ()
actions = do
    seed <- TestState -> Word64
getSeed (TestState -> Word64) -> CheckMain TestState -> CheckMain Word64
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CheckMain (State CheckMain)
CheckMain TestState
forall (m :: * -> *). MonadState m => m (State m)
get
    path <- testPath <$> get
    params <- getGenParams . config <$> get
    let rngIt = Word64 -> [String] -> Word64 -> GenRng
genRng Word64
seed (String
name String -> [String] -> [String]
forall a. a -> [a] -> [a]
: DList String -> [Item (DList String)]
forall l. IsList l => l -> [Item l]
toList DList String
path)

    let planState = PlanState { planRng :: Word64 -> GenRng
planRng         = Word64 -> GenRng
rngIt
                              , planValidations :: CountOf TestResult
planValidations = CountOf TestResult
0
                              , planParams :: GenParams
planParams      = GenParams
params
                              , planFailures :: [TestResult]
planFailures    = []
                              }
    st <- liftIO (snd <$> runStateT (runCheck actions) planState)
    let fails = PlanState -> [TestResult]
planFailures PlanState
st
    if null fails
        then return (GroupResult name 0 (planValidations st) [])
        else do
            displayCurrent name
            forM_ fails $ \TestResult
fail -> case TestResult
fail of
                PropertyResult String
name' CountOf TestResult
nb PropertyResult
r ->
                    case PropertyResult
r of
                        PropertyResult
PropertySuccess  -> CheckMain () -> CheckMain ()
whenVerbose (CheckMain () -> CheckMain ()) -> CheckMain () -> CheckMain ()
forall a b. (a -> b) -> a -> b
$ String -> CountOf TestResult -> CheckMain ()
displayPropertySucceed (String
name String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
": " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
name') CountOf TestResult
nb
                        PropertyFailed String
w -> CheckMain () -> CheckMain ()
whenErrorOnly (CheckMain () -> CheckMain ()) -> CheckMain () -> CheckMain ()
forall a b. (a -> b) -> a -> b
$ String -> CountOf TestResult -> String -> CheckMain ()
displayPropertyFailed (String
name String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
": " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
name') CountOf TestResult
nb String
w
                TestResult
_ -> String -> CheckMain ()
forall a. HasCallStack => String -> a
error String
"should not happen"
            return (GroupResult name (length fails) (planValidations st) fails)

testProperty :: String -> Property -> CheckMain TestResult
testProperty :: String -> Property -> CheckMain TestResult
testProperty String
name Property
prop = do
    seed <- TestState -> Word64
getSeed (TestState -> Word64) -> CheckMain TestState -> CheckMain Word64
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CheckMain (State CheckMain)
CheckMain TestState
forall (m :: * -> *). MonadState m => m (State m)
get
    path <- testPath <$> get
    let rngIt = Word64 -> [String] -> Word64 -> GenRng
genRng Word64
seed (String
name String -> [String] -> [String]
forall a. a -> [a] -> [a]
: DList String -> [Item (DList String)]
forall l. IsList l => l -> [Item l]
toList DList String
path)

    params <- getGenParams . config <$> get
    maxTests <- numTests . config <$> get

    (res,nb) <- liftIO $ iterateProperty (CountOf $ integralDownsize (cast maxTests :: Int64)) params rngIt prop
    case res of
        PropertyFailed {} -> CheckMain ()
failed
        PropertyResult
PropertySuccess   -> CheckMain ()
passed
    return (PropertyResult name nb res)