module Ideas.Common.Utils.TestSuite
(
TestSuite, MonadIO(..)
, suite, addProperty, addPropertyWith, warn
, assertTrue, assertNull, assertEquals, assertIO
, runTestSuite, runTestSuiteResult
, TestSuiteResult, subResults, findSubResult
, messages, topMessages, numberOfTests
, makeSummary, printSummary
, Message, newMessage
, isError, warning, messageLabel
) where
import Control.Exception
import Control.Monad.State
import Data.List
import Data.Maybe
import Data.Monoid
import Data.Time
import Prelude hiding (catch)
import System.IO
import Test.QuickCheck
import qualified Data.Foldable as F
import qualified Data.Sequence as S
newtype TestSuiteM a = TSM { unTSM :: StateT Content IO a }
data Content = C
{ column :: !Int
, result :: !TestSuiteResult
}
type TestSuite = TestSuiteM ()
instance Monad TestSuiteM where
return = TSM . return
m >>= f = TSM (unTSM m >>= unTSM . f)
fail s = do assertTrue s False
return (error "TestSuite.fail: do not bind result")
instance MonadIO TestSuiteM where
liftIO = TSM . liftIO
instance Monoid a => Monoid (TestSuiteM a) where
mempty = return mempty
mappend = (>>)
suite :: String -> TestSuite -> TestSuite
suite s m = TSM $ do
newline
liftIO $ putStrLn s
reset
t <- updateDiffTime (withEmptyTree (unTSM m))
addResult (suiteResult s t)
addProperty :: Testable prop => String -> prop -> TestSuite
addProperty = flip addPropertyWith stdArgs
addPropertyWith :: Testable prop => String -> Args -> prop -> TestSuite
addPropertyWith s args p = TSM $ do
newlineIndent
r <- liftIO $ quickCheckWithResult args p
reset
let f = addResult . messageResult . setLabel s
maybe (addResult okResult) f (toTestResult r)
assertTrue :: String -> Bool -> TestSuite
assertTrue msg = assertIO msg . return
assertNull :: Show a => String -> [a] -> TestSuite
assertNull s xs = addAssertion (f xs) (return (null xs))
where f = setLabel s . newMessage . intercalate "\n" . map show
assertEquals :: (Eq a, Show a) => String -> a -> a -> TestSuite
assertEquals s x y = addAssertion (setLabel s msg) (return (x==y))
where msg = newMessage ("Not equal: " ++ show x ++ " and " ++ show y)
assertIO :: String -> IO Bool -> TestSuite
assertIO s = addAssertion (setLabel s $ newMessage "Assertion failed")
warn :: String -> TestSuite
warn = (`addAssertion` return False) . warning . newMessage
addAssertion :: Message -> IO Bool -> TestSuite
addAssertion msg io = TSM $ do
b <- liftIO (io `catch` handler)
if b then do
dot
addResult okResult
else do
newlineIndent
liftIO (print msg)
reset
addResult (messageResult msg)
where
handler :: SomeException -> IO Bool
handler _ = return False
withEmptyTree :: StateT Content IO () -> StateT Content IO TestSuiteResult
withEmptyTree m = do
t0 <- gets result
modify $ \c -> c {result = mempty}
m
tr <- gets result
modify $ \c -> c {result = t0}
return tr
newline :: StateT Content IO ()
newline = do
i <- gets column
when (i>0) (liftIO $ putChar '\n')
reset
newlineIndent :: StateT Content IO ()
newlineIndent = do
newline
liftIO $ putStr " "
modify $ \c -> c {column = 3}
dot :: StateT Content IO ()
dot = do
i <- gets column
unless (i>0 && i<60) newlineIndent
liftIO $ putChar '.'
modify $ \c -> c {column = column c+1}
addResult :: TestSuiteResult -> StateT Content IO ()
addResult r = modify $ \c -> c {result = result c `mappend` r}
reset :: StateT Content IO ()
reset = modify $ \c -> c {column = 0}
runTestSuite :: TestSuite -> IO ()
runTestSuite = void . runTestSuiteResult
runTestSuiteResult :: TestSuite -> IO TestSuiteResult
runTestSuiteResult s = do
hSetBuffering stdout NoBuffering
updateDiffTime $ liftM result $
execStateT (unTSM s >> newline) (C 0 mempty)
data TestSuiteResult = TSR
{ messageSeq :: S.Seq Message
, suiteSeq :: S.Seq (String, TestSuiteResult)
, numberOfTests :: !Int
, diffTime :: !NominalDiffTime
}
instance Monoid TestSuiteResult where
mempty = TSR mempty mempty 0 0
mappend x y = TSR
{ messageSeq = messageSeq x `mappend` messageSeq y
, suiteSeq = suiteSeq x `mappend` suiteSeq y
, numberOfTests = numberOfTests x + numberOfTests y
, diffTime = diffTime x + diffTime y
}
okResult :: TestSuiteResult
okResult = mempty {numberOfTests = 1}
messageResult :: Message -> TestSuiteResult
messageResult m = okResult {messageSeq = S.singleton m}
suiteResult :: String -> TestSuiteResult -> TestSuiteResult
suiteResult s a = mempty
{ suiteSeq = S.singleton (s, a)
, numberOfTests = numberOfTests a
}
instance Show TestSuiteResult where
show res =
let (xs, ys) = partition isError (messages res)
in "(tests: " ++ show (numberOfTests res) ++
", errors: " ++ show (length xs) ++
", warnings: " ++ show (length ys) ++
", " ++ show (diffTime res) ++ ")"
subResults :: TestSuiteResult -> [(String, TestSuiteResult)]
subResults = F.toList . suiteSeq
topMessages :: TestSuiteResult -> [Message]
topMessages = F.toList . messageSeq
messages :: TestSuiteResult -> [Message]
messages res =
topMessages res ++ concatMap (messages . snd) (subResults res)
data Message = Message
{ message :: String
, isError :: Bool
, messageLabel :: Maybe String
}
instance Show Message where
show a = (if null pre then "" else pre ++ ": ") ++ message a
where
parens s = "(" ++ s ++ ")"
pre = unwords $
[ "Warning" | not (isError a) ] ++
maybe [] (return . parens) (messageLabel a)
newMessage :: String -> Message
newMessage s = Message s True Nothing
warning :: Message -> Message
warning m = m {isError = False}
setLabel :: String -> Message -> Message
setLabel s m = m {messageLabel = Just s}
findSubResult :: String -> TestSuiteResult -> Maybe TestSuiteResult
findSubResult name = listToMaybe . recs
where
recs = concatMap rec . subResults
rec (n, t)
| n == name = [t]
| otherwise = recs t
printSummary :: TestSuiteResult -> IO ()
printSummary = putStrLn . makeSummary
makeSummary :: TestSuiteResult -> String
makeSummary res = unlines $
[ line
, "Tests : " ++ show (numberOfTests res)
, "Failures : " ++ show (length xs)
, "Warnings : " ++ show (length ys)
, "\nTime : " ++ show (diffTime res)
, "\nSuites: "
] ++ map f (subResults res)
++ [line]
where
line = replicate 75 '-'
(xs, ys) = partition isError (messages res)
f (name, r) = " " ++ name ++ " " ++ show r
toTestResult :: Result -> Maybe Message
toTestResult res =
let make = Just . newMessage
in case res of
Success {} -> Nothing
Failure {reason = msg} -> make msg
NoExpectedFailure {} -> make "no expected failure"
GaveUp {numTests = i} -> fmap warning $ make $
"passed only " ++ show i ++ " tests"
updateDiffTime :: MonadIO m => m TestSuiteResult -> m TestSuiteResult
updateDiffTime m = do
(res, d) <- getDiffTime m
return res {diffTime = d}
getDiffTime :: MonadIO m => m a -> m (a, NominalDiffTime)
getDiffTime action = do
t0 <- liftIO getCurrentTime
a <- action
t1 <- liftIO getCurrentTime
return (a, diffUTCTime t1 t0)