module Data.Prednote.TestTree
(
Name
, TestFunc
, TestTree (..)
, Payload (..)
, test
, eachSubjectMustBeTrue
, nSubjectsMustBeTrue
, group
, Verbosity(..)
, GroupVerbosity (..)
, Pt.Level
, PassCount
, FailCount
, runTests
, showTestTree
, TestOpts (..)
, ShortCircuit
, Pass
, evalTree
) where
import Data.Either (rights)
import Data.Maybe (isJust)
import Data.List (unfoldr)
import Data.Monoid ((<>))
import qualified Data.Text as X
import Data.Text (Text)
import qualified Data.List.Split as Sp
import qualified System.Console.Rainbow as R
import System.Console.Rainbow ((+.+))
import qualified Data.Prednote.Pdct as Pt
type Pass = Bool
type Name = Text
data TestTree a = TestTree Name (Payload a)
data Payload a
= Group [TestTree a]
| Test (TestFunc a)
type TestFunc a
= Pt.IndentAmt
-> Verbosity
-> Verbosity
-> [a]
-> Pt.Level
-> (Pass, [R.Chunk])
group :: Name -> [TestTree a] -> TestTree a
group n = TestTree n . Group
test :: Name -> TestFunc a -> TestTree a
test n = TestTree n . Test
data Verbosity
= Silent
| PassFail
| FalseSubjects
| TrueSubjects
| Discards
deriving (Eq, Ord, Show)
showSubject
:: (a -> X.Text)
-> Verbosity
-> Pt.IndentAmt
-> Pt.Level
-> Pt.Pdct a
-> (a, Maybe Bool)
-> [R.Chunk]
showSubject swr v i l p (s, b) =
let (showSubj, showDisc) = isSubjectAndDiscardsShown v b
renamer txt = X.concat [swr s, " - ", txt]
renamed = Pt.rename renamer p
in if showSubj
then snd $ Pt.evaluate i showDisc s l renamed
else []
isSubjectAndDiscardsShown :: Verbosity -> Maybe Bool -> (Bool, Bool)
isSubjectAndDiscardsShown v b = case v of
Silent -> (False, False)
PassFail -> (False, False)
FalseSubjects -> (not . isTrue $ b, False)
TrueSubjects -> (isJust b, False)
Discards -> (True, True)
showTestTitle :: Pt.IndentAmt -> Pt.Level -> Name -> Pass -> [R.Chunk]
showTestTitle i l n p = [idt, open, passFail, close, blank, txt, nl]
where
idt = R.plain (X.replicate (i * l) " ")
nl = R.plain "\n"
passFail =
if p
then R.plain "PASS" +.+ R.f_green
else R.plain "FAIL" +.+ R.f_red
open = R.plain "["
close = R.plain "]"
blank = R.plain (X.singleton ' ')
txt = R.plain n
isTrue :: Maybe Bool -> Bool
isTrue = maybe False id
eachSubjectMustBeTrue
:: Name
-> (a -> Text)
-> Pt.Pdct a
-> TestTree a
eachSubjectMustBeTrue n swr p = TestTree n (Test tf)
where
tf i pv fv as lvl = (pass, cks)
where
rslts = zip as (map (Pt.eval p) as)
pass = all (isTrue . snd) rslts
v = if pass then pv else fv
cks = tit ++ subjectChunks
tit = if v == Silent then [] else showTestTitle i lvl n pass
subjectChunks =
concatMap (showSubject swr v i (lvl + 1) p) rslts
nSubjectsMustBeTrue
:: Name
-> (a -> X.Text)
-> Int
-> Pt.Pdct a
-> TestTree a
nSubjectsMustBeTrue n swr count p = TestTree n (Test tf)
where
tf idnt pv fv as l = (pass, cks)
where
pd (_, res) = isTrue res
resultList = take count
. Sp.split ( Sp.keepDelimsR
(Sp.dropFinalBlank . Sp.whenElt $ pd))
$ zip as (map (Pt.eval p) as)
pass = length resultList >= count
v = if pass then pv else fv
cks = tit ++ subjectChunks
tit = if v == Silent then [] else showTestTitle idnt l n pass
subjectChunks =
concatMap (showSubject swr v idnt (l + 1) p)
. concat $ resultList
indent :: Pt.IndentAmt -> Pt.Level -> Text -> R.Chunk
indent amt lvl t = R.plain txt
where
txt = X.concat [spaces, t, "\n"]
spaces = X.replicate (amt * lvl) " "
skip :: Text -> Pt.IndentAmt -> Pt.Level -> Text -> [R.Chunk]
skip lbl amt lvl t =
[ R.plain (X.replicate (amt * lvl) " ")
, R.plain "["
, R.plain ("skip " <> lbl) +.+ R.f_yellow
, R.plain "] "
, R.plain t
, R.plain "\n"
]
showTestTree
:: Pt.IndentAmt
-> Pt.Level
-> TestTree a
-> [R.Chunk]
showTestTree amt l (TestTree n p) = indent amt l n : children
where
children = case p of
Group ts -> concatMap (showTestTree amt l) ts
Test _ -> []
data TestOpts a = TestOpts
{ tIndentAmt :: Int
, tPassVerbosity :: Verbosity
, tFailVerbosity :: Verbosity
, tGroupPred :: Name -> Bool
, tTestPred :: Name -> Bool
, tShowSkippedTests :: Bool
, tGroupVerbosity :: GroupVerbosity
, tSubjects :: [a]
, tStopOnFail :: Bool
}
type ShortCircuit = Bool
evalTree
:: TestOpts a
-> Pt.Level
-> TestTree a
-> (ShortCircuit, [Either [R.Chunk] (Pass, [R.Chunk])])
evalTree ee l (TestTree n p) = case p of
Group ts -> evalGroup ee n l ts
Test f -> evalTest ee n l f
evalGroup
:: TestOpts a
-> Name
-> Pt.Level
-> [TestTree a]
-> (ShortCircuit, [Either [R.Chunk] (Pass, [R.Chunk])])
evalGroup ee n l ts = if tGroupPred ee n
then let ls = unfoldr (unfoldList ee l) (False, ts)
stop = any not . map fst $ ls
rslts = concat . map snd $ ls
groupNm = if tGroupVerbosity ee /= NoGroups
then indent (tIndentAmt ee) l n
else R.plain ""
in (stop, Left [groupNm] : rslts)
else let groupNm = if tGroupVerbosity ee == AllGroups
then skip "group" (tIndentAmt ee) l n
else [R.plain ""]
in (False, [Left groupNm])
evalTest
:: TestOpts a
-> Name
-> Pt.Level
-> TestFunc a
-> (ShortCircuit, [Either [R.Chunk] (Pass, [R.Chunk])])
evalTest ee n l tf = if tTestPred ee n
then (not p, [Right (p, cs)])
else (False, skipped)
where
(p, cs) = tf (tIndentAmt ee) (tPassVerbosity ee)
(tFailVerbosity ee) (tSubjects ee) l
skipped = if tShowSkippedTests ee
then [Left $ skip "test" (tIndentAmt ee) l n]
else []
type PassCount = Int
type FailCount = Int
data GroupVerbosity
= NoGroups
| ActiveGroups
| AllGroups
deriving (Eq, Ord, Show)
runTests
:: TestOpts a
-> Pt.Level
-> [TestTree a]
-> ([R.Chunk], PassCount, FailCount)
runTests ee l ts =
let ls = unfoldr (unfoldList ee l) (False, ts)
testRs = rights . concatMap snd $ ls
passed = length . filter id . map fst $ testRs
failed = length . filter (not . id) . map fst $ testRs
cks = concat . map (either id snd) . concatMap snd $ ls
in (cks, passed, failed)
unfoldList
:: TestOpts a
-> Pt.Level
-> (ShortCircuit, [TestTree a])
-> Maybe ( (ShortCircuit, [Either [R.Chunk] (Pass, [R.Chunk])])
, (ShortCircuit, [TestTree a]))
unfoldList ee l (seenFalse, is) =
if seenFalse && tStopOnFail ee
then Nothing
else case is of
[] -> Nothing
t:xs ->
let (short, results) = evalTree ee l t
in Just ((short, results), (short, xs))