{-# 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 = 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
| forall c. Collection c => c -> Bool
null (Config -> [String]
testNameMatch Config
cfg) = 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 = forall col. (Collection col, Element col ~ Bool) => col -> Bool
or (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall c. (Sequential c, Eq (Element c)) => c -> c -> Bool
isInfixOf String
currentTestName 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
sforall 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 = forall a. [Maybe a] -> [a]
catMaybes 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
sforall a. a -> [a] -> [a]
:[String]
acc)) [Test]
l
in if forall c. Collection c => c -> Bool
null [Test]
filtered then forall a. Maybe a
Nothing else 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 -> forall a. a -> Maybe a
Just Test
x
| Bool
otherwise -> forall a. Maybe a
Nothing
Unit String
s IO ()
_
| [String] -> String -> Bool
match [String]
acc String
s -> forall a. a -> Maybe a
Just Test
x
| Bool
otherwise -> forall a. Maybe a
Nothing
Property String
s prop
_
| [String] -> String -> Bool
match [String]
acc String
s -> forall a. a -> Maybe a
Just Test
x
| Bool
otherwise -> forall a. Maybe a
Nothing
defaultMain :: Test -> IO ()
defaultMain :: Test -> IO ()
defaultMain Test
allTestRoot = do
IO ()
Terminal.initialize
Either String Config
ecfg <- forall a b c. (a -> b -> c) -> b -> a -> c
flip [String] -> Config -> Either String Config
parseArgs Config
defaultConfig forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO [String]
getArgs
Config
cfg <- case Either String Config
ecfg of
Left String
e -> do
String -> IO ()
putStrLn String
e
forall (col :: * -> *) (m :: * -> *) a b.
(Mappable col, Applicative m, Monad m) =>
(a -> m b) -> col a -> m ()
mapM_ String -> IO ()
putStrLn [String]
configHelp
forall a. IO a
exitFailure
Right Config
c -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Config
c
Word64
seed <- forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall (m :: * -> *). MonadRandom m => m Word64
getRandomWord64 forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Config -> Maybe Word64
udfSeed Config
cfg
let testState :: TestState
testState = Config -> Word64 -> TestState
newState Config
cfg Word64
seed
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Config -> Bool
helpRequested Config
cfg) (forall (col :: * -> *) (m :: * -> *) a b.
(Mappable col, Applicative m, Monad m) =>
(a -> m b) -> col a -> m ()
mapM_ String -> IO ()
putStrLn [String]
configHelp forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall a. IO a
exitSuccess)
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Config -> Bool
listTests Config
cfg) (IO ()
printTestName forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall a. IO a
exitSuccess)
String -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ String
"\nSeed: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Word64
seed forall a. Semigroup a => a -> a -> a
<> String
"\n"
case Config -> Test -> Maybe Test
filterTestMatching Config
cfg Test
allTestRoot of
Maybe Test
Nothing -> String -> IO ()
putStrLn String
"no tests to run" forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall a. IO a
exitSuccess
Just Test
t -> do
(TestResult
_, TestState
cfg') <- forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT (forall a. CheckMain a -> StateT TestState IO a
runCheckMain forall a b. (a -> b) -> a -> b
$ Test -> CheckMain TestResult
test Test
t) TestState
testState
forall {b}. TestState -> IO b
summary TestState
cfg'
where
summary :: TestState -> IO b
summary TestState
cfg
| Word
kos forall a. Ord a => a -> a -> Bool
> Word
0 = do
String -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ String
red forall a. Semigroup a => a -> a -> a
<> String
"Failed " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Word
kos forall a. Semigroup a => a -> a -> a
<> String
" out of " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Word
tot forall a. Semigroup a => a -> a -> a
<> String
reset
forall a. IO a
exitFailure
| Bool
otherwise = do
String -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ String
green forall a. Semigroup a => a -> a -> a
<> String
"Succeed " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Word
oks forall a. Semigroup a => a -> a -> a
<> String
" test(s)" forall a. Semigroup a => a -> a -> a
<> String
reset
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 forall a. Additive a => a -> a -> a
+ Word
kos
printTestName :: IO ()
printTestName = 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)) 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 (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Test
z -> (Test
z, [String]
pre)) [Test]
xs forall a. Semigroup a => a -> a -> a
<> [(Test, [String])]
acc) (String
sforall a. a -> [a] -> [a]
:[String]
pre) [Test]
l
CheckPlan String
s Check ()
_ -> (String
s forall a. a -> [a] -> [a]
: [String]
pre) forall a. a -> [a] -> [a]
: [(Test, [String])] -> [String] -> [Test] -> [[String]]
tToList [(Test, [String])]
acc [String]
pre [Test]
xs
Unit String
s IO ()
_ -> (String
s forall a. a -> [a] -> [a]
: [String]
pre) forall a. a -> [a] -> [a]
: [(Test, [String])] -> [String] -> [Test] -> [[String]]
tToList [(Test, [String])]
acc [String]
pre [Test]
xs
Property String
s prop
_ -> (String
s forall a. a -> [a] -> [a]
: [String]
pre) 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
newtype CheckMain a = CheckMain { forall a. CheckMain a -> StateT TestState IO a
runCheckMain :: StateT TestState IO a }
deriving (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
<$ :: forall a b. a -> CheckMain b -> CheckMain a
$c<$ :: forall a b. a -> CheckMain b -> CheckMain a
fmap :: forall a b. (a -> b) -> CheckMain a -> CheckMain b
$cfmap :: forall a b. (a -> b) -> CheckMain a -> CheckMain b
Functor, Functor 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
<* :: forall a b. CheckMain a -> CheckMain b -> CheckMain a
$c<* :: forall a b. CheckMain a -> CheckMain b -> CheckMain a
*> :: forall a b. CheckMain a -> CheckMain b -> CheckMain b
$c*> :: forall a b. CheckMain a -> CheckMain b -> CheckMain b
liftA2 :: forall a b c.
(a -> b -> c) -> CheckMain a -> CheckMain b -> CheckMain c
$cliftA2 :: forall a b c.
(a -> b -> c) -> CheckMain a -> CheckMain b -> CheckMain c
<*> :: forall a b. CheckMain (a -> b) -> CheckMain a -> CheckMain b
$c<*> :: forall a b. CheckMain (a -> b) -> CheckMain a -> CheckMain b
pure :: forall a. a -> CheckMain a
$cpure :: forall a. a -> CheckMain a
Applicative, Applicative 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
return :: forall a. a -> CheckMain a
$creturn :: forall a. a -> CheckMain a
>> :: forall a b. CheckMain a -> CheckMain b -> CheckMain b
$c>> :: forall a b. CheckMain a -> CheckMain b -> CheckMain b
>>= :: forall a b. CheckMain a -> (a -> CheckMain b) -> CheckMain b
$c>>= :: forall a b. CheckMain a -> (a -> CheckMain b) -> CheckMain b
Monad, Monad CheckMain
forall a. IO a -> CheckMain a
forall (m :: * -> *).
Monad m -> (forall a. IO a -> m a) -> MonadIO m
liftIO :: forall a. IO a -> CheckMain a
$cliftIO :: 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 = forall a. StateT TestState IO a -> CheckMain a
CheckMain forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. 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
Bool
on <- forall a. Ord a => a -> a -> Bool
(<=) DisplayOption
opt 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 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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). MonadState m => m (State m)
get
if Bool
on then CheckMain ()
chk else forall (m :: * -> *) a. Monad m => a -> m a
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 = forall (m :: * -> *) a.
MonadState m =>
(State m -> (a, State m)) -> m a
withState forall a b. (a -> b) -> a -> b
$ \State CheckMain
s -> ((), State CheckMain
s { testPassed :: Word
testPassed = TestState -> Word
testPassed State CheckMain
s forall a. Additive a => a -> a -> a
+ Word
1 })
failed :: CheckMain ()
failed :: CheckMain ()
failed = forall (m :: * -> *) a.
MonadState m =>
(State m -> (a, State m)) -> m a
withState forall a b. (a -> b) -> a -> b
$ \State CheckMain
s -> ((), State CheckMain
s { testFailed :: Word
testFailed = TestState -> Word
testFailed State CheckMain
s forall a. Additive a => a -> a -> a
+ Word
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 ()
_) = 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
TestResult
r <- String -> Property -> CheckMain TestResult
testProperty String
name (forall p. IsProperty p => p -> Property
property prop
prop)
case TestResult
r of
(PropertyResult String
_ CountOf TestResult
nb PropertyResult
PropertySuccess) -> CheckMain () -> CheckMain ()
whenVerbose 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 forall a b. (a -> b) -> a -> b
$ String -> CountOf TestResult -> String -> CheckMain ()
displayPropertyFailed String
name CountOf TestResult
nb String
w
GroupResult {} -> forall a. HasCallStack => String -> a
error String
"internal error: should not happen"
forall (m :: * -> *) a. Monad m => a -> m a
return TestResult
r
displayCurrent :: String -> CheckMain ()
displayCurrent :: String -> CheckMain ()
displayCurrent String
name = do
CountOf Char
i <- TestState -> CountOf Char
indent forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). MonadState m => m (State m)
get
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ forall c. Sequential c => CountOf (Element c) -> Element c -> c
replicate CountOf Char
i Char
' ' forall a. Semigroup a => a -> a -> a
<> String
name
displayPropertySucceed :: String -> CountOf TestResult -> CheckMain ()
displayPropertySucceed :: String -> CountOf TestResult -> CheckMain ()
displayPropertySucceed String
name (CountOf Int
nb) = do
CountOf Char
i <- TestState -> CountOf Char
indent forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). MonadState m => m (State m)
get
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ forall a. Monoid a => [a] -> a
mconcat
[ forall c. Sequential c => CountOf (Element c) -> Element c -> c
replicate CountOf Char
i Char
' '
, String
successString, String
name
, String
" ("
, forall a. Show a => a -> String
show Int
nb
, if Int
nb forall a. Eq a => a -> a -> Bool
== Int
1 then String
" test)" else String
" tests)"
]
unicodeEnabled :: Bool
unicodeEnabled :: Bool
unicodeEnabled = Bool
True
successString :: String
successString :: String
successString
| Bool
unicodeEnabled = String
green forall a. Semigroup a => a -> a -> a
<> String
" ✓ " forall a. Semigroup a => a -> a -> a
<> String
reset
| Bool
otherwise = String
green forall a. Semigroup a => a -> a -> a
<> String
"[SUCCESS] " forall a. Semigroup a => a -> a -> a
<> String
reset
{-# NOINLINE successString #-}
failureString :: String
failureString :: String
failureString
| Bool
unicodeEnabled = String
red forall a. Semigroup a => a -> a -> a
<> String
" ✗ " forall a. Semigroup a => a -> a -> a
<> String
reset
| Bool
otherwise = String
red forall a. Semigroup a => a -> a -> a
<> String
"[ ERROR ] " 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 (forall (n :: Nat).
(KnownNat n, NatWithinBound Word64 n) =>
Word64 -> Zn64 n
zn64 Word64
2) Bool
True
red :: String
red = ColorComponent -> Bool -> String
ANSI.sgrForeground (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
Word64
seed <- TestState -> Word64
getSeed forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). MonadState m => m (State m)
get
CountOf Char
i <- TestState -> CountOf Char
indent forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). MonadState m => m (State m)
get
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
String -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ forall a. Monoid a => [a] -> a
mconcat
[ forall c. Sequential c => CountOf (Element c) -> Element c -> c
replicate CountOf Char
i Char
' '
, String
failureString, String
name
, String
" failed after "
, forall a. Show a => a -> String
show Int
nb
, if Int
nb forall a. Eq a => a -> a -> Bool
== Int
1 then String
" test" else String
" tests:"
]
String -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ forall c. Sequential c => CountOf (Element c) -> Element c -> c
replicate CountOf Char
i Char
' ' forall a. Semigroup a => a -> a -> a
<> String
" use param: --seed " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Word64
seed
String -> IO ()
putStrLn String
w
pushGroup :: String -> [Test] -> CheckMain TestResult
pushGroup :: String -> [Test] -> CheckMain TestResult
pushGroup String
name [Test]
list = do
CheckMain () -> CheckMain ()
whenGroupOnly forall a b. (a -> b) -> a -> b
$ if [Test] -> Bool
groupHasSubGroup [Test]
list then String -> CheckMain ()
displayCurrent String
name else forall (m :: * -> *) a. Monad m => a -> m a
return ()
forall (m :: * -> *) a.
MonadState m =>
(State m -> (a, State m)) -> m a
withState forall a b. (a -> b) -> a -> b
$ \State CheckMain
s -> ((), State CheckMain
s { testPath :: DList String
testPath = DList String -> Element (DList String) -> DList String
push (TestState -> DList String
testPath State CheckMain
s) String
name, indent :: CountOf Char
indent = TestState -> CountOf Char
indent State CheckMain
s forall a. Additive a => a -> a -> a
+ CountOf Char
2 })
[TestResult]
results <- forall (collection :: * -> *) (m :: * -> *) a b.
(Mappable collection, Applicative m, Monad m) =>
(a -> m b) -> collection a -> m (collection b)
mapM Test -> CheckMain TestResult
test [Test]
list
forall (m :: * -> *) a.
MonadState m =>
(State m -> (a, State m)) -> m a
withState forall a b. (a -> b) -> a -> b
$ \State CheckMain
s -> ((), State CheckMain
s { testPath :: DList String
testPath = DList String -> DList String
pop (TestState -> DList String
testPath State CheckMain
s), indent :: CountOf Char
indent = TestState -> CountOf Char
indent State CheckMain
s forall a. CountOf a -> CountOf a -> CountOf a
`sizeSub` CountOf Char
2 })
let totFail :: Element [CountOf TestResult]
totFail = [CountOf TestResult] -> Element [CountOf TestResult]
sum 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 :: Element [CountOf TestResult]
tot = [CountOf TestResult] -> Element [CountOf TestResult]
sum 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
CheckMain () -> CheckMain ()
whenGroupOnly forall a b. (a -> b) -> a -> b
$ case ([Test] -> Bool
groupHasSubGroup [Test]
list, Element [CountOf TestResult]
totFail) of
(Bool
True, CountOf TestResult
_) -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
(Bool
False, CountOf TestResult
n) | CountOf TestResult
n 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 Element [CountOf TestResult]
tot
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ String
-> CountOf TestResult
-> CountOf TestResult
-> [TestResult]
-> TestResult
GroupResult String
name Element [CountOf TestResult]
totFail Element [CountOf TestResult]
tot [TestResult]
results
where
sum :: [CountOf TestResult] -> Element [CountOf TestResult]
sum = forall collection a.
Foldable collection =>
(a -> Element collection -> a) -> a -> collection -> a
foldl' forall a. Additive a => a -> a -> a
(+) Element [CountOf TestResult]
0
push :: DList String -> Element (DList String) -> DList String
push = forall c. Sequential c => c -> Element c -> c
snoc
pop :: DList String -> DList String
pop = forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. Monoid a => a
mempty forall a b. (a, b) -> a
fst forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. 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
Word64
seed <- TestState -> Word64
getSeed forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). MonadState m => m (State m)
get
DList String
path <- TestState -> DList String
testPath forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). MonadState m => m (State m)
get
GenParams
params <- Config -> GenParams
getGenParams 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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). MonadState m => m (State m)
get
let rngIt :: Word64 -> GenRng
rngIt = Word64 -> [String] -> Word64 -> GenRng
genRng Word64
seed (String
name forall a. a -> [a] -> [a]
: forall l. IsList l => l -> [Item l]
toList DList String
path)
let planState :: PlanState
planState = PlanState { planRng :: Word64 -> GenRng
planRng = Word64 -> GenRng
rngIt
, planValidations :: CountOf TestResult
planValidations = CountOf TestResult
0
, planParams :: GenParams
planParams = GenParams
params
, planFailures :: [TestResult]
planFailures = []
}
PlanState
st <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT (forall a. Check a -> StateT PlanState IO a
runCheck Check ()
actions) PlanState
planState)
let fails :: [TestResult]
fails = PlanState -> [TestResult]
planFailures PlanState
st
if forall c. Collection c => c -> Bool
null [TestResult]
fails
then forall (m :: * -> *) a. Monad m => a -> m a
return (String
-> CountOf TestResult
-> CountOf TestResult
-> [TestResult]
-> TestResult
GroupResult String
name CountOf TestResult
0 (PlanState -> CountOf TestResult
planValidations PlanState
st) [])
else do
String -> CheckMain ()
displayCurrent String
name
forall (col :: * -> *) (m :: * -> *) a b.
(Mappable col, Applicative m, Monad m) =>
col a -> (a -> m b) -> m ()
forM_ [TestResult]
fails forall a b. (a -> b) -> a -> b
$ \TestResult
fail -> case TestResult
fail of
PropertyResult String
name' CountOf TestResult
nb PropertyResult
r ->
case PropertyResult
r of
PropertyResult
PropertySuccess -> CheckMain () -> CheckMain ()
whenVerbose forall a b. (a -> b) -> a -> b
$ String -> CountOf TestResult -> CheckMain ()
displayPropertySucceed (String
name forall a. Semigroup a => a -> a -> a
<> String
": " forall a. Semigroup a => a -> a -> a
<> String
name') CountOf TestResult
nb
PropertyFailed String
w -> CheckMain () -> CheckMain ()
whenErrorOnly forall a b. (a -> b) -> a -> b
$ String -> CountOf TestResult -> String -> CheckMain ()
displayPropertyFailed (String
name forall a. Semigroup a => a -> a -> a
<> String
": " forall a. Semigroup a => a -> a -> a
<> String
name') CountOf TestResult
nb String
w
TestResult
_ -> forall a. HasCallStack => String -> a
error String
"should not happen"
forall (m :: * -> *) a. Monad m => a -> m a
return (String
-> CountOf TestResult
-> CountOf TestResult
-> [TestResult]
-> TestResult
GroupResult String
name (forall c. Collection c => c -> CountOf (Element c)
length [TestResult]
fails) (PlanState -> CountOf TestResult
planValidations PlanState
st) [TestResult]
fails)
testProperty :: String -> Property -> CheckMain TestResult
testProperty :: String -> Property -> CheckMain TestResult
testProperty String
name Property
prop = do
Word64
seed <- TestState -> Word64
getSeed forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). MonadState m => m (State m)
get
DList String
path <- TestState -> DList String
testPath forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). MonadState m => m (State m)
get
let rngIt :: Word64 -> GenRng
rngIt = Word64 -> [String] -> Word64 -> GenRng
genRng Word64
seed (String
name forall a. a -> [a] -> [a]
: forall l. IsList l => l -> [Item l]
toList DList String
path)
GenParams
params <- Config -> GenParams
getGenParams 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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). MonadState m => m (State m)
get
Word64
maxTests <- Config -> Word64
numTests 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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). MonadState m => m (State m)
get
(PropertyResult
res,CountOf TestResult
nb) <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ CountOf TestResult
-> GenParams
-> (Word64 -> GenRng)
-> Property
-> IO (PropertyResult, CountOf TestResult)
iterateProperty (forall ty. Int -> CountOf ty
CountOf forall a b. (a -> b) -> a -> b
$ forall a b. IntegralDownsize a b => a -> b
integralDownsize (forall source destination.
Cast source destination =>
source -> destination
cast Word64
maxTests :: Int64)) GenParams
params Word64 -> GenRng
rngIt Property
prop
case PropertyResult
res of
PropertyFailed {} -> CheckMain ()
failed
PropertyResult
PropertySuccess -> CheckMain ()
passed
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> CountOf TestResult -> PropertyResult -> TestResult
PropertyResult String
name CountOf TestResult
nb PropertyResult
res)