{-# 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 -> HasFailures
nbFail (PropertyResult String
_ HasFailures
_ (PropertyFailed String
_)) = HasFailures
1
nbFail (PropertyResult String
_ HasFailures
_ PropertyResult
PropertySuccess) = HasFailures
0
nbFail (GroupResult String
_ HasFailures
t HasFailures
_ [TestResult]
_) = HasFailures
t
nbTests :: TestResult -> CountOf TestResult
nbTests :: TestResult -> HasFailures
nbTests (PropertyResult String
_ HasFailures
t PropertyResult
_) = HasFailures
t
nbTests (GroupResult String
_ HasFailures
_ HasFailures
t [TestResult]
_) = HasFailures
t
data TestState = TestState
{ TestState -> Config
config :: !Config
, TestState -> Seed
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 -> Seed -> TestState
newState Config
cfg Seed
initSeed = TestState :: Config
-> Seed
-> CountOf Char
-> Word
-> Word
-> DList String
-> TestState
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 :: Seed
getSeed = Seed
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 (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
defaultMain :: Test -> IO ()
defaultMain :: Test -> IO ()
defaultMain Test
allTestRoot = do
IO ()
Terminal.initialize
Either String Config
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
Config
cfg <- case Either String Config
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 (f :: * -> *) a. Applicative f => a -> f a
pure Config
c
Seed
seed <- IO Seed -> (Seed -> IO Seed) -> Maybe Seed -> IO Seed
forall b a. b -> (a -> b) -> Maybe a -> b
maybe IO Seed
forall (m :: * -> *). MonadRandom m => m Seed
getRandomWord64 Seed -> IO Seed
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Seed -> IO Seed) -> Maybe Seed -> IO Seed
forall a b. (a -> b) -> a -> b
$ Config -> Maybe Seed
udfSeed Config
cfg
let testState :: TestState
testState = Config -> Seed -> TestState
newState Config
cfg Seed
seed
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Config -> Bool
helpRequested Config
cfg) ((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 () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
forall a. IO a
exitSuccess)
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Config -> Bool
listTests Config
cfg) (IO ()
printTestName IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
forall a. IO a
exitSuccess)
String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"\nSeed: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Seed -> String
forall a. Show a => a -> String
show Seed
seed String -> String -> String
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" IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
forall a. IO a
exitSuccess
Just Test
t -> do
(TestResult
_, TestState
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
TestState -> IO ()
forall b. TestState -> IO b
summary TestState
cfg'
where
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
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 (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
newtype CheckMain a = CheckMain { CheckMain a -> StateT TestState IO a
runCheckMain :: StateT TestState IO a }
deriving (a -> CheckMain b -> CheckMain a
(a -> b) -> CheckMain a -> CheckMain b
(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
<$ :: a -> CheckMain b -> CheckMain a
$c<$ :: forall a b. a -> CheckMain b -> CheckMain a
fmap :: (a -> b) -> CheckMain a -> CheckMain b
$cfmap :: forall a b. (a -> b) -> CheckMain a -> CheckMain b
Functor, Functor CheckMain
a -> CheckMain a
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
CheckMain a -> CheckMain b -> CheckMain b
CheckMain a -> CheckMain b -> CheckMain a
CheckMain (a -> b) -> CheckMain a -> CheckMain b
(a -> b -> c) -> CheckMain a -> CheckMain b -> CheckMain c
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
<* :: CheckMain a -> CheckMain b -> CheckMain a
$c<* :: forall a b. CheckMain a -> CheckMain b -> CheckMain a
*> :: CheckMain a -> CheckMain b -> CheckMain b
$c*> :: forall a b. CheckMain a -> CheckMain b -> CheckMain b
liftA2 :: (a -> b -> c) -> CheckMain a -> CheckMain b -> CheckMain c
$cliftA2 :: forall a b c.
(a -> b -> c) -> CheckMain a -> CheckMain b -> CheckMain c
<*> :: CheckMain (a -> b) -> CheckMain a -> CheckMain b
$c<*> :: forall a b. CheckMain (a -> b) -> CheckMain a -> CheckMain b
pure :: a -> CheckMain a
$cpure :: forall a. a -> CheckMain a
$cp1Applicative :: Functor CheckMain
Applicative, Applicative CheckMain
a -> CheckMain a
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
CheckMain a -> (a -> CheckMain b) -> CheckMain b
CheckMain a -> CheckMain b -> CheckMain b
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 :: a -> CheckMain a
$creturn :: forall a. a -> CheckMain a
>> :: CheckMain a -> CheckMain b -> CheckMain b
$c>> :: forall a b. CheckMain a -> CheckMain b -> CheckMain b
>>= :: CheckMain a -> (a -> CheckMain b) -> CheckMain b
$c>>= :: forall a b. CheckMain a -> (a -> CheckMain b) -> CheckMain b
$cp1Monad :: Applicative CheckMain
Monad, Monad CheckMain
Monad CheckMain
-> (forall a. IO a -> CheckMain a) -> MonadIO CheckMain
IO a -> CheckMain a
forall a. IO a -> CheckMain a
forall (m :: * -> *).
Monad m -> (forall a. IO a -> m a) -> MonadIO m
liftIO :: IO a -> CheckMain a
$cliftIO :: forall a. IO a -> CheckMain a
$cp1MonadIO :: Monad CheckMain
MonadIO)
instance MonadState CheckMain where
type State CheckMain = TestState
withState :: (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 k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (TestState -> (a, TestState)) -> 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
Bool
on <- DisplayOption -> DisplayOption -> Bool
forall a. Ord a => a -> a -> Bool
(<=) DisplayOption
opt (DisplayOption -> Bool)
-> (TestState -> DisplayOption) -> TestState -> Bool
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 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 TestState
forall (m :: * -> *). MonadState m => m (State m)
get
if Bool
on then CheckMain ()
chk else () -> CheckMain ()
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 = (State CheckMain -> ((), State CheckMain)) -> CheckMain ()
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
TestState
s { testPassed :: Word
testPassed = TestState -> Word
testPassed State CheckMain
TestState
s Word -> Word -> Word
forall a. Additive a => a -> a -> a
+ Word
1 })
failed :: CheckMain ()
failed :: CheckMain ()
failed = (State CheckMain -> ((), State CheckMain)) -> CheckMain ()
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
TestState
s { testFailed :: Word
testFailed = TestState -> Word
testFailed State CheckMain
TestState
s Word -> Word -> Word
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 ()
_) = 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
TestResult
r <- String -> Property -> CheckMain TestResult
testProperty String
name (prop -> Property
forall p. IsProperty p => p -> Property
property prop
prop)
case TestResult
r of
(PropertyResult String
_ HasFailures
nb PropertyResult
PropertySuccess) -> CheckMain () -> CheckMain ()
whenVerbose (CheckMain () -> CheckMain ()) -> CheckMain () -> CheckMain ()
forall a b. (a -> b) -> a -> b
$ String -> HasFailures -> CheckMain ()
displayPropertySucceed String
name HasFailures
nb
(PropertyResult String
_ HasFailures
nb (PropertyFailed String
w)) -> CheckMain () -> CheckMain ()
whenErrorOnly (CheckMain () -> CheckMain ()) -> CheckMain () -> CheckMain ()
forall a b. (a -> b) -> a -> b
$ String -> HasFailures -> String -> CheckMain ()
displayPropertyFailed String
name HasFailures
nb String
w
GroupResult {} -> String -> CheckMain ()
forall a. HasCallStack => String -> a
error String
"internal error: should not happen"
TestResult -> CheckMain TestResult
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 (TestState -> CountOf Char)
-> CheckMain TestState -> CheckMain (CountOf Char)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CheckMain TestState
forall (m :: * -> *). MonadState m => m (State m)
get
IO () -> CheckMain ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> CheckMain ()) -> IO () -> CheckMain ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ CountOf (Element String) -> Element String -> String
forall c. Sequential c => CountOf (Element c) -> Element c -> c
replicate CountOf Char
CountOf (Element String)
i Char
Element String
' ' String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
name
displayPropertySucceed :: String -> CountOf TestResult -> CheckMain ()
displayPropertySucceed :: String -> HasFailures -> CheckMain ()
displayPropertySucceed String
name (CountOf Int
nb) = do
CountOf Char
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 TestState
forall (m :: * -> *). MonadState m => m (State m)
get
IO () -> CheckMain ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> CheckMain ()) -> IO () -> CheckMain ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall a. Monoid a => [a] -> a
mconcat
[ CountOf (Element String) -> Element String -> String
forall c. Sequential c => CountOf (Element c) -> Element c -> c
replicate CountOf Char
CountOf (Element String)
i Char
Element String
' '
, String
successString, String
name
, String
" ("
, Int -> String
forall a. Show a => a -> String
show Int
nb
, if Int
nb Int -> Int -> Bool
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 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 (Seed -> ColorComponent
forall (n :: Nat).
(KnownNat n, NatWithinBound Seed n) =>
Seed -> Zn64 n
zn64 Seed
2) Bool
True
red :: String
red = ColorComponent -> Bool -> String
ANSI.sgrForeground (Seed -> ColorComponent
forall (n :: Nat).
(KnownNat n, NatWithinBound Seed n) =>
Seed -> Zn64 n
zn64 Seed
1) Bool
True
displayPropertyFailed :: String -> CountOf TestResult -> String -> CheckMain ()
displayPropertyFailed :: String -> HasFailures -> String -> CheckMain ()
displayPropertyFailed String
name (CountOf Int
nb) String
w = do
Seed
seed <- TestState -> Seed
getSeed (TestState -> Seed) -> CheckMain TestState -> CheckMain Seed
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CheckMain TestState
forall (m :: * -> *). MonadState m => m (State m)
get
CountOf Char
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 TestState
forall (m :: * -> *). MonadState m => m (State m)
get
IO () -> CheckMain ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> CheckMain ()) -> IO () -> CheckMain ()
forall a b. (a -> b) -> a -> b
$ do
String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall a. Monoid a => [a] -> a
mconcat
[ CountOf (Element String) -> Element String -> String
forall c. Sequential c => CountOf (Element c) -> Element c -> c
replicate CountOf Char
CountOf (Element String)
i Char
Element String
' '
, String
failureString, String
name
, String
" failed after "
, Int -> String
forall a. Show a => a -> String
show Int
nb
, if Int
nb Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 then String
" test" else String
" tests:"
]
String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ CountOf (Element String) -> Element String -> String
forall c. Sequential c => CountOf (Element c) -> Element c -> c
replicate CountOf Char
CountOf (Element String)
i Char
Element String
' ' String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" use param: --seed " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Seed -> String
forall a. Show a => a -> String
show Seed
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 (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 (m :: * -> *) a. Monad m => a -> m a
return ()
(State CheckMain -> ((), State CheckMain)) -> CheckMain ()
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
TestState
s { testPath :: DList String
testPath = DList String -> Element (DList String) -> DList String
push (TestState -> DList String
testPath State CheckMain
TestState
s) String
Element (DList String)
name, indent :: CountOf Char
indent = TestState -> CountOf Char
indent State CheckMain
TestState
s CountOf Char -> CountOf Char -> CountOf Char
forall a. Additive a => a -> a -> a
+ CountOf Char
2 })
[TestResult]
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)
mapM Test -> CheckMain TestResult
test [Test]
list
(State CheckMain -> ((), State CheckMain)) -> CheckMain ()
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
TestState
s { testPath :: DList String
testPath = DList String -> DList String
pop (TestState -> DList String
testPath State CheckMain
TestState
s), indent :: CountOf Char
indent = TestState -> CountOf Char
indent State CheckMain
TestState
s CountOf Char -> CountOf Char -> CountOf Char
forall a. CountOf a -> CountOf a -> CountOf a
`sizeSub` CountOf Char
2 })
let totFail :: Element [HasFailures]
totFail = [HasFailures] -> Element [HasFailures]
sum ([HasFailures] -> Element [HasFailures])
-> [HasFailures] -> Element [HasFailures]
forall a b. (a -> b) -> a -> b
$ (TestResult -> HasFailures) -> [TestResult] -> [HasFailures]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TestResult -> HasFailures
nbFail [TestResult]
results
tot :: Element [HasFailures]
tot = [HasFailures] -> Element [HasFailures]
sum ([HasFailures] -> Element [HasFailures])
-> [HasFailures] -> Element [HasFailures]
forall a b. (a -> b) -> a -> b
$ (TestResult -> HasFailures) -> [TestResult] -> [HasFailures]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TestResult -> HasFailures
nbTests [TestResult]
results
CheckMain () -> CheckMain ()
whenGroupOnly (CheckMain () -> CheckMain ()) -> CheckMain () -> CheckMain ()
forall a b. (a -> b) -> a -> b
$ case ([Test] -> Bool
groupHasSubGroup [Test]
list, HasFailures
Element [HasFailures]
totFail) of
(Bool
True, HasFailures
_) -> () -> CheckMain ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
(Bool
False, HasFailures
n) | HasFailures
n HasFailures -> HasFailures -> Bool
forall a. Ord a => a -> a -> Bool
> HasFailures
0 -> String -> HasFailures -> String -> CheckMain ()
displayPropertyFailed String
name HasFailures
n String
""
| Bool
otherwise -> String -> HasFailures -> CheckMain ()
displayPropertySucceed String
name HasFailures
Element [HasFailures]
tot
TestResult -> CheckMain TestResult
forall (m :: * -> *) a. Monad m => a -> m a
return (TestResult -> CheckMain TestResult)
-> TestResult -> CheckMain TestResult
forall a b. (a -> b) -> a -> b
$ String -> HasFailures -> HasFailures -> [TestResult] -> TestResult
GroupResult String
name HasFailures
Element [HasFailures]
totFail HasFailures
Element [HasFailures]
tot [TestResult]
results
where
sum :: [HasFailures] -> Element [HasFailures]
sum = (Element [HasFailures]
-> Element [HasFailures] -> Element [HasFailures])
-> Element [HasFailures] -> [HasFailures] -> Element [HasFailures]
forall collection a.
Foldable collection =>
(a -> Element collection -> a) -> a -> collection -> a
foldl' Element [HasFailures]
-> Element [HasFailures] -> Element [HasFailures]
forall a. Additive a => a -> a -> a
(+) Element [HasFailures]
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 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
seed <- TestState -> Seed
getSeed (TestState -> Seed) -> CheckMain TestState -> CheckMain Seed
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CheckMain TestState
forall (m :: * -> *). MonadState m => m (State m)
get
DList String
path <- TestState -> DList String
testPath (TestState -> DList String)
-> CheckMain TestState -> CheckMain (DList String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CheckMain TestState
forall (m :: * -> *). MonadState m => m (State m)
get
GenParams
params <- Config -> GenParams
getGenParams (Config -> GenParams)
-> (TestState -> Config) -> TestState -> GenParams
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 -> GenParams)
-> CheckMain TestState -> CheckMain GenParams
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CheckMain TestState
forall (m :: * -> *). MonadState m => m (State m)
get
let rngIt :: Seed -> GenRng
rngIt = Seed -> [String] -> Seed -> GenRng
genRng Seed
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
planState = PlanState :: (Seed -> GenRng)
-> HasFailures -> GenParams -> [TestResult] -> PlanState
PlanState { planRng :: Seed -> GenRng
planRng = Seed -> GenRng
rngIt
, planValidations :: HasFailures
planValidations = HasFailures
0
, planParams :: GenParams
planParams = GenParams
params
, planFailures :: [TestResult]
planFailures = []
}
PlanState
st <- IO PlanState -> CheckMain PlanState
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (((), PlanState) -> PlanState
forall a b. (a, b) -> b
snd (((), PlanState) -> PlanState)
-> IO ((), PlanState) -> IO PlanState
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StateT PlanState IO () -> PlanState -> IO ((), PlanState)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT (Check () -> StateT PlanState IO ()
forall a. Check a -> StateT PlanState IO a
runCheck Check ()
actions) PlanState
planState)
let fails :: [TestResult]
fails = PlanState -> [TestResult]
planFailures PlanState
st
if [TestResult] -> Bool
forall c. Collection c => c -> Bool
null [TestResult]
fails
then TestResult -> CheckMain TestResult
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> HasFailures -> HasFailures -> [TestResult] -> TestResult
GroupResult String
name HasFailures
0 (PlanState -> HasFailures
planValidations PlanState
st) [])
else do
String -> CheckMain ()
displayCurrent String
name
[TestResult] -> (TestResult -> CheckMain ()) -> CheckMain ()
forall (col :: * -> *) (m :: * -> *) a b.
(Mappable col, Applicative m, Monad m) =>
col a -> (a -> m b) -> m ()
forM_ [TestResult]
fails ((TestResult -> CheckMain ()) -> CheckMain ())
-> (TestResult -> CheckMain ()) -> CheckMain ()
forall a b. (a -> b) -> a -> b
$ \TestResult
fail -> case TestResult
fail of
PropertyResult String
name' HasFailures
nb PropertyResult
r ->
case PropertyResult
r of
PropertyResult
PropertySuccess -> CheckMain () -> CheckMain ()
whenVerbose (CheckMain () -> CheckMain ()) -> CheckMain () -> CheckMain ()
forall a b. (a -> b) -> a -> b
$ String -> HasFailures -> 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') HasFailures
nb
PropertyFailed String
w -> CheckMain () -> CheckMain ()
whenErrorOnly (CheckMain () -> CheckMain ()) -> CheckMain () -> CheckMain ()
forall a b. (a -> b) -> a -> b
$ String -> HasFailures -> 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') HasFailures
nb String
w
TestResult
_ -> String -> CheckMain ()
forall a. HasCallStack => String -> a
error String
"should not happen"
TestResult -> CheckMain TestResult
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> HasFailures -> HasFailures -> [TestResult] -> TestResult
GroupResult String
name ([TestResult] -> CountOf (Element [TestResult])
forall c. Collection c => c -> CountOf (Element c)
length [TestResult]
fails) (PlanState -> HasFailures
planValidations PlanState
st) [TestResult]
fails)
testProperty :: String -> Property -> CheckMain TestResult
testProperty :: String -> Property -> CheckMain TestResult
testProperty String
name Property
prop = do
Seed
seed <- TestState -> Seed
getSeed (TestState -> Seed) -> CheckMain TestState -> CheckMain Seed
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CheckMain TestState
forall (m :: * -> *). MonadState m => m (State m)
get
DList String
path <- TestState -> DList String
testPath (TestState -> DList String)
-> CheckMain TestState -> CheckMain (DList String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CheckMain TestState
forall (m :: * -> *). MonadState m => m (State m)
get
let rngIt :: Seed -> GenRng
rngIt = Seed -> [String] -> Seed -> GenRng
genRng Seed
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)
GenParams
params <- Config -> GenParams
getGenParams (Config -> GenParams)
-> (TestState -> Config) -> TestState -> GenParams
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 -> GenParams)
-> CheckMain TestState -> CheckMain GenParams
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CheckMain TestState
forall (m :: * -> *). MonadState m => m (State m)
get
Seed
maxTests <- Config -> Seed
numTests (Config -> Seed) -> (TestState -> Config) -> TestState -> Seed
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 -> Seed) -> CheckMain TestState -> CheckMain Seed
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CheckMain TestState
forall (m :: * -> *). MonadState m => m (State m)
get
(PropertyResult
res,HasFailures
nb) <- IO (PropertyResult, HasFailures)
-> CheckMain (PropertyResult, HasFailures)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (PropertyResult, HasFailures)
-> CheckMain (PropertyResult, HasFailures))
-> IO (PropertyResult, HasFailures)
-> CheckMain (PropertyResult, HasFailures)
forall a b. (a -> b) -> a -> b
$ HasFailures
-> GenParams
-> (Seed -> GenRng)
-> Property
-> IO (PropertyResult, HasFailures)
iterateProperty (Int -> HasFailures
forall ty. Int -> CountOf ty
CountOf (Int -> HasFailures) -> Int -> HasFailures
forall a b. (a -> b) -> a -> b
$ Int64 -> Int
forall a b. IntegralDownsize a b => a -> b
integralDownsize (Seed -> Int64
forall source destination.
Cast source destination =>
source -> destination
cast Seed
maxTests :: Int64)) GenParams
params Seed -> GenRng
rngIt Property
prop
case PropertyResult
res of
PropertyFailed {} -> CheckMain ()
failed
PropertyResult
PropertySuccess -> CheckMain ()
passed
TestResult -> CheckMain TestResult
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> HasFailures -> PropertyResult -> TestResult
PropertyResult String
name HasFailures
nb PropertyResult
res)