module Ideas.Utils.TestSuite
(
TestSuite
, suite, useProperty, usePropertyWith
, assertTrue, assertNull, assertEquals, assertIO
, assertMessage, assertMessageIO
, onlyWarnings, rateOnError
, runTestSuite, runTestSuiteResult
, Result, subResults, findSubResult
, justOneSuite, allMessages, topMessages
, nrOfTests, nrOfErrors, nrOfWarnings
, timeInterval, makeSummary, printSummary
, Message, message, warning, messageLines
, Status, HasStatus(..)
, isError, isWarning, isOk
, Rating, HasRating(..)
) where
import Control.Exception
import Control.Monad
import Data.Foldable (toList)
import Data.IORef
import Data.List
import Data.Maybe
import Data.Semigroup as Sem
import Data.Time
import Ideas.Utils.Prelude (getDiffTime)
import System.IO
import Test.QuickCheck hiding (Result)
import qualified Data.Sequence as S
newtype TestSuite = TS (S.Seq Test)
data Test = Case String (IO Message)
| Suite String TestSuite
instance Sem.Semigroup TestSuite where
TS xs <> TS ys = TS (xs S.>< ys)
instance Monoid TestSuite where
mempty = TS mempty
mappend = (<>)
tests :: TestSuite -> [Test]
tests (TS xs) = toList xs
makeTestSuite :: Test -> TestSuite
makeTestSuite = TS . S.singleton
suite :: String -> [TestSuite] -> TestSuite
suite s = makeTestSuite . Suite s . mconcat
useProperty :: Testable prop => String -> prop -> TestSuite
useProperty = flip usePropertyWith stdArgs
usePropertyWith :: Testable prop => String -> Args -> prop -> TestSuite
usePropertyWith s args =
makeTestSuite . Case s . fmap make . quickCheckWithResult args {chatty=False}
where
make qc =
case qc of
Success {} ->
mempty
Failure {reason = msg} ->
message msg
NoExpectedFailure {} ->
message "no expected failure"
GaveUp {numTests = i} ->
warning ("passed only " ++ show i ++ " tests")
InsufficientCoverage {numTests = i} ->
warning ("only performed " ++ show i ++ " tests")
assertTrue :: String -> Bool -> TestSuite
assertTrue s = assertIO s . return
assertNull :: Show a => String -> [a] -> TestSuite
assertNull s xs = assertMessages s (null xs) (map show xs)
assertEquals :: (Eq a, Show a) => String -> a -> a -> TestSuite
assertEquals s x y = assertMessage s (x==y) $
"not equal " ++ show x ++ " and " ++ show y
assertMessage :: String -> Bool -> String -> TestSuite
assertMessage s b = assertMessages s b . return
assertMessages :: String -> Bool -> [String] -> TestSuite
assertMessages s b xs = makeTestSuite . Case s $ return $
if b then mempty else mconcat (map message xs)
assertIO :: String -> IO Bool -> TestSuite
assertIO s = makeTestSuite . Case s . fmap f
where
f b = if b then mempty else message "assertion failed"
assertMessageIO :: String -> IO Message -> TestSuite
assertMessageIO s = makeTestSuite . Case s
onlyWarnings :: TestSuite -> TestSuite
onlyWarnings = changeMessages $ \m ->
m { messageStatus = messageStatus m `min` Warning
, messageRating = mempty
}
rateOnError :: Int -> TestSuite -> TestSuite
rateOnError n = changeMessages $ \m ->
if isError m then m { messageRating = Rating n } else m
changeMessages :: (Message -> Message) -> TestSuite -> TestSuite
changeMessages f = changeTS
where
changeTS (TS xs) = TS (fmap changeTest xs)
changeTest (Case s io) = Case s (f <$> io)
changeTest (Suite s t) = Suite s (changeTS t)
runTestSuite :: Bool -> TestSuite -> IO ()
runTestSuite chattyIO = void . runTestSuiteResult chattyIO
runTestSuiteResult :: Bool -> TestSuite -> IO Result
runTestSuiteResult chattyIO ts = do
hSetBuffering stdout NoBuffering
ref <- newIORef 0
result <- runner ref chattyIO ts
newline ref
return result
runner :: IORef Int -> Bool -> TestSuite -> IO Result
runner ref chattyIO = runTS
where
runTS :: TestSuite -> IO Result
runTS ts = do
(res, dt) <- getDiffTime (foldM addTest mempty (tests ts))
returnStrict res { diffTime = dt }
runTest :: Test -> IO Result
runTest t =
case t of
Suite s xs -> runSuite s xs
Case s io -> runTestCase s io
runSuite ::String -> TestSuite -> IO Result
runSuite s ts = do
when chattyIO $ do
newline ref
putStrLn s
reset ref
result <- runTS ts
returnStrict (suiteResult s result)
runTestCase :: String -> IO Message -> IO Result
runTestCase s io = do
msg <- io `catch` handler
case messageStatus msg of
_ | not chattyIO -> return ()
Ok -> dot ref
_ -> do
newlineIndent ref
print msg
reset ref
returnStrict (caseResult (s, msg))
where
handler :: SomeException -> IO Message
handler = return . message . show
addTest :: Result -> Test -> IO Result
addTest res t = (res <>) <$> runTest t
type WriteIO a = IORef Int -> IO a
newline :: WriteIO ()
newline ref = do
i <- readIORef ref
when (i>0) (putChar '\n')
reset ref
newlineIndent :: WriteIO ()
newlineIndent ref = do
newline ref
putStr " "
writeIORef ref 3
dot :: WriteIO ()
dot ref = do
i <- readIORef ref
unless (i>0 && i<60) (newlineIndent ref)
putChar '.'
modifyIORef ref (+1)
reset :: WriteIO ()
reset = (`writeIORef` 0)
data Result = Result
{ suites :: S.Seq (String, Result)
, cases :: S.Seq (String, Message)
, diffTime :: !NominalDiffTime
, nrOfTests :: !Int
, nrOfWarnings :: !Int
, nrOfErrors :: !Int
, resultRating :: !Rating
}
instance Show Result where
show result =
"(tests: " ++ show (nrOfTests result) ++
", errors: " ++ show (nrOfErrors result) ++
", warnings: " ++ show (nrOfWarnings result) ++
", " ++ show (diffTime result) ++ ")"
instance Sem.Semigroup Result where
x <> y = Result
{ suites = suites x S.>< suites y
, cases = cases x S.>< cases y
, diffTime = diffTime x + diffTime y
, nrOfTests = nrOfTests x + nrOfTests y
, nrOfWarnings = nrOfWarnings x + nrOfWarnings y
, nrOfErrors = nrOfErrors x + nrOfErrors y
, resultRating = resultRating x <> resultRating y
}
instance Monoid Result where
mempty = Result mempty mempty 0 0 0 0 mempty
mappend = (<>)
instance HasStatus Result where
getStatus r | nrOfErrors r > 0 = Error
| nrOfWarnings r > 0 = Warning
| otherwise = Ok
instance HasRating Result where
rating = rating . resultRating
rate n a = a {resultRating = Rating n}
suiteResult :: String -> Result -> Result
suiteResult s res = mempty
{ suites = S.singleton (s, res)
, nrOfTests = nrOfTests res
, nrOfWarnings = nrOfWarnings res
, nrOfErrors = nrOfErrors res
, resultRating = resultRating res
}
caseResult :: (String, Message) -> Result
caseResult x@(_, msg) =
case getStatus msg of
Ok -> new
Warning -> new { nrOfWarnings = 1 }
Error -> new { nrOfErrors = 1 }
where
new = mempty
{ cases = S.singleton x
, nrOfTests = 1
, resultRating = messageRating msg
}
subResults :: Result -> [(String, Result)]
subResults = toList . suites
topMessages :: Result -> [(String, Message)]
topMessages = toList . cases
allMessages :: Result -> [(String, Message)]
allMessages res =
topMessages res ++ concatMap (allMessages . snd) (subResults res)
findSubResult :: String -> Result -> Maybe Result
findSubResult name = listToMaybe . recs
where
recs = concatMap rec . subResults
rec (n, t)
| n == name = [t]
| otherwise = recs t
justOneSuite :: Result -> Maybe (String, Result)
justOneSuite res =
case subResults res of
[x] | S.null (cases res) -> Just x
_ -> Nothing
timeInterval :: Result -> Double
timeInterval = fromRational . toRational . diffTime
printSummary :: Result -> IO ()
printSummary = putStrLn . makeSummary
makeSummary :: Result -> String
makeSummary result = unlines $
[ line
, "Tests : " ++ show (nrOfTests result)
, "Errors : " ++ show (nrOfErrors result)
, "Warnings : " ++ show (nrOfWarnings result)
, ""
, "Time : " ++ show (diffTime result)
, ""
, "Suites: "
] ++ map f (subResults result)
++ [line]
where
line = replicate 75 '-'
f (name, r) = " " ++ name ++ " " ++ show r
data Message = M
{ messageStatus :: !Status
, messageRating :: !Rating
, messageLines :: [String]
}
deriving Eq
instance Show Message where
show a = st ++ sep ++ msg
where
msg = intercalate ", " (messageLines a)
sep = if null st || null msg then "" else ": "
st | isError a = "error"
| isWarning a = "warning"
| null (messageLines a) = "ok"
| otherwise = ""
instance Sem.Semigroup Message where
M s r xs <> M t q ys = M (s <> t) (r <> q) (xs <> ys)
instance Monoid Message where
mempty = M mempty mempty mempty
mappend = (<>)
instance HasStatus Message where
getStatus = messageStatus
instance HasRating Message where
rating = rating . messageRating
rate n a = a {messageRating = Rating n}
message :: String -> Message
message = M Error (Rating 0) . return
warning :: String -> Message
warning = M Warning mempty . return
data Status = Ok | Warning | Error
deriving (Eq, Ord)
instance Sem.Semigroup Status where
(<>) = max
instance Monoid Status where
mempty = Ok
mappend = (<>)
class HasStatus a where
getStatus :: a -> Status
isOk, isWarning, isError :: HasStatus a => a -> Bool
isOk = (== Ok) . getStatus
isWarning = (== Warning) . getStatus
isError = (== Error) . getStatus
data Rating = Rating !Int | MaxRating
deriving (Eq, Ord)
instance Sem.Semigroup Rating where
(<>) = min
instance Monoid Rating where
mempty = MaxRating
mappend = (<>)
class HasRating a where
rating :: a -> Maybe Int
rate :: Int -> a -> a
instance HasRating Rating where
rating (Rating n) = Just n
rating MaxRating = Nothing
rate = const . Rating
returnStrict :: Monad m => a -> m a
returnStrict a = a `seq` return a