module Data.Prednote.Test
(
Name
, Verbosity(..)
, TrueVerbosity
, FalseVerbosity
, TestVisibility(..)
, TestVerbosity(..)
, Pass
, Test(..)
, TestResult(..)
, eachSubjectMustBeTrue
, nSubjectsMustBeTrue
, evalTest
, showTestResult
) where
import Control.Arrow (first)
import Data.Functor.Contravariant
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.Predbox as Pt
data Verbosity
= HideAll
| ShowDefaults
| ShowAll
deriving (Eq, Show)
type TrueVerbosity = Verbosity
type FalseVerbosity = Verbosity
data TestVisibility
= HideTest
| ShowFirstLine TrueVerbosity FalseVerbosity
deriving (Eq, Show)
data TestVerbosity = TestVerbosity
{ onPass :: TestVisibility
, onFail :: TestVisibility
} 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
}
instance Contravariant Test where
contramap f t = t { testFunc = testFunc t . f }
data TestResult a = TestResult
{ resultName :: Name
, resultPass :: Pass
, resultSubjects :: [(a, Pt.Result)]
, resultDefaultVerbosity :: TestVerbosity
}
instance Functor TestResult where
fmap f t = t { resultSubjects = map (first f) . resultSubjects $ t }
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
showTestResult
:: Pt.IndentAmt
-> (a -> Text)
-> Maybe TestVerbosity
-> TestResult a
-> [R.Chunk]
showTestResult 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.Predbox 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 = Pt.evaluate pd
nSubjectsMustBeTrue
:: Pt.Predbox a
-> Name
-> Int
-> Test a
nSubjectsMustBeTrue pd nm i = Test nm pass f vy
where
pass = atLeast i . filter Pt.rBool
f = 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