module Data.Prednote.Test
(
Name
, Verbosity(..)
, TrueVerbosity
, FalseVerbosity
, ShowTest(..)
, TestVerbosity(..)
, Pass
, Test(..)
, TestResult(..)
, eachSubjectMustBeTrue
, nSubjectsMustBeTrue
, evalTest
, showResult
) where
import Data.Maybe (fromMaybe)
import Data.Monoid ((<>), mempty)
import qualified Data.Text as X
import Data.Text (Text)
import qualified System.Console.Rainbow as R
import qualified Data.Prednote.Pdct as Pt
data Verbosity
= HideAll
| ShowDefaults
| ShowAll
deriving (Eq, Show)
type TrueVerbosity = Verbosity
type FalseVerbosity = Verbosity
data ShowTest
= HideTest
| ShowFirstLine TrueVerbosity FalseVerbosity
deriving (Eq, Show)
data TestVerbosity = TestVerbosity
{ onPass :: ShowTest
, onFail :: ShowTest
} deriving (Eq, Show)
type Pass = Bool
type Name = Text
data Test a = Test
{ testName :: Name
, testPass :: [Pt.Result] -> Pass
, testFunc :: a -> Pt.Result
, testVerbosity :: TestVerbosity
}
data TestResult a = TestResult
{ resultName :: Name
, resultPass :: Pass
, resultSubjects :: [(a, Pt.Result)]
, resultDefaultVerbosity :: TestVerbosity
}
plain :: X.Text -> R.Chunk
plain = R.Chunk mempty
showTestTitle :: Name -> Pass -> [R.Chunk]
showTestTitle n p = [open, passFail, close, blank, txt, nl]
where
nl = plain "\n"
passFail =
if p
then "PASS" <> R.f_green
else "FAIL" <> R.f_red
open = plain "["
close = plain "]"
blank = plain (X.singleton ' ')
txt = plain n
evalTest :: Test a -> [a] -> TestResult a
evalTest (Test n fPass fSubj vy) ls = TestResult n p ss vy
where
p = fPass results
results = map fSubj ls
ss = zip ls results
showResult
:: Pt.IndentAmt
-> (a -> Text)
-> Maybe TestVerbosity
-> TestResult a
-> [R.Chunk]
showResult amt swr mayVb (TestResult n p ss dfltVb) =
let vb = fromMaybe dfltVb mayVb
tv = if p then onPass vb else onFail vb
firstLine = showTestTitle n p
in case tv of
HideTest -> []
ShowFirstLine trueV falseV ->
firstLine
++ concatMap (showSubject p amt swr (trueV, falseV)) ss
showSubject
:: Pass
-> Pt.IndentAmt
-> (a -> Text)
-> (TrueVerbosity, FalseVerbosity)
-> (a, Pt.Result)
-> [R.Chunk]
showSubject p amt swr (tv, fv) (a, r) =
let txt = swr a
vb = if p then tv else fv
in case vb of
HideAll -> []
ShowDefaults -> Pt.showTopResult txt amt 1 False r
ShowAll -> Pt.showTopResult txt amt 1 True r
eachSubjectMustBeTrue :: Pt.Pdct a -> Name -> Test a
eachSubjectMustBeTrue pd nm = Test nm pass f vy
where
vy = TestVerbosity
{ onPass = ShowFirstLine HideAll HideAll
, onFail = ShowFirstLine HideAll ShowDefaults }
pass = all Pt.rBool
f = flip Pt.evaluate pd
nSubjectsMustBeTrue
:: Pt.Pdct a
-> Name
-> Int
-> Test a
nSubjectsMustBeTrue pd nm i = Test nm pass f vy
where
pass = atLeast i . filter Pt.rBool
f = flip Pt.evaluate pd
vy = TestVerbosity
{ onPass = ShowFirstLine HideAll HideAll
, onFail = ShowFirstLine HideAll HideAll }
atLeast :: Int -> [a] -> Bool
atLeast i as
| i < 0 = error "atLeast: negative length parameter"
| otherwise = go 0 as
where
go _ [] = i == 0
go soFar (_:xs) =
let nFound = soFar + 1
in if nFound == i then True else go nFound xs