{-# LANGUAGE
FlexibleInstances
, LambdaCase
#-}
module Test.Microspec (
microspec
, microspecWith
, describe
, it
, pending
, prop
, Microspec
, MTestable
, MArgs(..)
, defaultMArgs
, shouldBe
, module Test.QuickCheck
, module Test.QuickCheck.Modifiers
, module Test.QuickCheck.Monadic
) where
import Control.Monad
import Data.Char (isSpace)
import Data.Maybe (mapMaybe)
import Data.Time (getCurrentTime, diffUTCTime)
import System.Exit (exitWith, ExitCode(ExitFailure))
import Test.QuickCheck as QC
import Test.QuickCheck
import Test.QuickCheck.Modifiers
import Test.QuickCheck.Monadic
data Microspec a = Microspec [TestTree Property] a
data TestTree x
= TestBranch String [TestTree x]
| TestLeaf String (Either Pending x)
data Pending = Pending
pending :: Pending
pending = Pending
microspec :: Microspec () -> IO ()
microspec = microspecWith defaultMArgs
microspecWith :: MArgs -> Microspec () -> IO ()
microspecWith args spec = do
putStrLn ""
startTime <- getCurrentTime
results <- forM (buildTestTrees spec) $ \test -> do
runTestWith args 0 test
let numSucc, numPend, numFail :: Int
numSucc = (sum::[Int]->Int) $ map numSuccesses results
numPend = (sum::[Int]->Int) $ map numPending results
numFail = (sum::[Int]->Int) $ map numFailures results
endTime <- getCurrentTime
when ((numPend + numFail) /= 0) $
putStrLn "\n ----- Failures and pending:\n"
forM_ (filterPendingAndFails results) $ \x -> do
printAllTestResults 0 x
putStrLn ""
putStrLn $ "\n -----\nRuntime: " ++ show (diffUTCTime endTime startTime)
let colorF :: String -> String
colorF = case (numSucc, numPend, numFail) of
(_, 0, 0) -> inGreen
(_, _, 0) -> inYellow
_ -> inRed
putStrLn $ colorF $
"Successes: " ++ show numSucc
++ ", Pending: " ++ show numPend
++ ", Failures: " ++ show numFail
when (numFail /= 0) $ exitWith $ ExitFailure 1
runTestWith :: MArgs -> Int -> TestTree Property -> IO (TestTree QC.Result)
runTestWith args depth = \case
TestLeaf testLabel (Right aProp) -> do
let timeoutMaybe = case _mArgs_timeoutSecs args of
Nothing -> id
Just numSecs -> within $ fromEnum $ numSecs * (10^(6::Int))
result <- quickCheckWithResult (_mArgs_qcArgs args) $ timeoutMaybe aProp
let r = TestLeaf testLabel (Right result)
printSingleTestResult depth r
pure r
TestLeaf testLabel (Left Pending) -> do
let r = TestLeaf testLabel (Left Pending)
printSingleTestResult depth r
pure r
TestBranch testLabel forest -> do
printSingleTestResult depth $ TestBranch testLabel []
results <- forM forest $ runTestWith args (depth + 1)
pure $ TestBranch testLabel results
printAllTestResults :: Int -> TestTree QC.Result -> IO ()
printAllTestResults depth = \case
b@(TestBranch _ forest) -> do
printSingleTestResult depth b
mapM_ (printAllTestResults (depth + 1)) forest
l@(TestLeaf{}) -> printSingleTestResult depth l
printSingleTestResult :: Int -> TestTree QC.Result -> IO ()
printSingleTestResult depth resultTree = do
putStr $ indentationFor depth
case resultTree of
TestLeaf testLabel (Right result) -> do
putStrLn $ showResult (labelStr testLabel) result
TestLeaf testLabel (Left Pending) -> do
putStrLn $ inYellow (labelStr testLabel) ++ " - " ++ inYellow "PENDING"
TestBranch testLabel _ -> do
putStrLn $ labelStr testLabel
where
indentationFor :: Int -> String
indentationFor n = replicate (n*2) ' '
showResult :: String -> QC.Result -> String
showResult testLabel = \case
Success {} ->
inGreen testLabel
failure@(Failure{theException=Nothing}) ->
inRed testLabel ++ " - "++inRed (replaceNewline (output failure))
failure ->
inRed testLabel ++" - "++inRed (replaceNewline (output failure))
replaceNewline :: String -> String
replaceNewline = concatMap $ \case '\n' -> " | " ; x -> [x]
labelStr :: String -> String
labelStr s = case filter (not . isSpace) s of
"" -> "(untitled)"
_ -> s
filterPendingAndFails :: [TestTree QC.Result] -> [TestTree QC.Result]
filterPendingAndFails l = mapMaybe f l
where
f :: TestTree QC.Result -> Maybe (TestTree QC.Result)
f = \case
TestLeaf _ (Right Success{}) -> Nothing
x@(TestLeaf _ (Right _)) -> Just x
x@(TestLeaf _ (Left Pending)) -> Just x
TestBranch theLabel xs -> case filterPendingAndFails xs of
[] -> Nothing
leftover -> Just $ TestBranch theLabel leftover
it :: MTestable t => String -> t -> Microspec ()
it = describe
addTestTree :: TestTree Property -> Microspec ()
addTestTree tree = Microspec [tree] ()
class MTestable t where
describe :: String -> t -> Microspec ()
instance MTestable Property where
describe testLabel aProp =
addTestTree $ TestLeaf testLabel (Right aProp)
instance MTestable Bool where
describe testLabel bool =
describe testLabel $ property bool
instance MTestable (TestTree Property) where
describe testLabel x =
addTestTree $ TestBranch testLabel [x]
instance MTestable Pending where
describe testLabel pend =
addTestTree $ TestLeaf testLabel (Left pend)
instance MTestable (Microspec ()) where
describe testLabel x =
let forest = buildTestTrees x
in addTestTree $ TestBranch testLabel forest
instance (Arbitrary a, Show a, Testable prop) => MTestable (a -> prop) where
describe testLabel f =
describe testLabel $ property f
numSuccesses, numFailures, numPending :: TestTree QC.Result -> Int
numSuccesses = \case
TestBranch _ ts -> (sum::[Int]->Int) $ map numSuccesses ts
TestLeaf _ (Right Success{}) -> 1
TestLeaf _ (Right _) -> 0
TestLeaf _ (Left _) -> 0
numFailures = \case
TestBranch _ ts -> (sum::[Int]->Int) $ map numFailures ts
TestLeaf _ (Right Success{}) -> 0
TestLeaf _ (Right _) -> 1
TestLeaf _ (Left _) -> 0
numPending = \case
TestBranch _ ts -> (sum::[Int]->Int) $ map numPending ts
TestLeaf _ (Right _) -> 0
TestLeaf _ (Left _) -> 1
instance Show (TestTree x) where
show = \case
TestBranch testLabel subs ->
"Branch "++show testLabel++" "++show subs
TestLeaf testLabel _ ->
"Leaf " ++ show testLabel
instance Functor Microspec where
fmap f (Microspec forest a) = Microspec forest (f a)
instance Applicative Microspec where
pure a = Microspec [] a
f <*> a =
let Microspec forest0 f' = f
Microspec forest1 a' = a
in Microspec (forest0 ++ forest1) (f' a')
instance Monad Microspec where
return = pure
ma >>= f =
let Microspec forest0 a = ma
Microspec forest1 b = f a
in Microspec (forest0 ++ forest1) b
buildTestTrees :: Microspec () -> [TestTree Property]
buildTestTrees (Microspec x _) = x
defaultMArgs :: MArgs
defaultMArgs = MArgs {
_mArgs_timeoutSecs = Nothing
,_mArgs_qcArgs = QC.stdArgs { chatty = False }
}
data MArgs = MArgs {
_mArgs_timeoutSecs :: Maybe Double
,_mArgs_qcArgs :: QC.Args
}
deriving (Show, Read)
inRed, inGreen, inYellow :: String -> String
[inRed,inGreen, inYellow] =
(`map` [31,32,33]) $ \colorNum ->
\s -> "\ESC["++show (colorNum::Int)++"m"++s++"\ESC[m"
shouldBe :: (Eq x, Show x) => x -> x -> Property
shouldBe = (===)
prop :: MTestable prop => String -> prop -> Microspec ()
prop = describe