{-# LANGUAGE
FlexibleInstances
, LambdaCase
#-}
module Test.Microspec (
microspec
, microspecWith
, describe
, it
, pending
, prop
, Microspec
, MTestable
, MArgs(..)
, defaultMArgs
, shouldBe
, shouldSatisfy
, module Test.QuickCheck
, module Test.QuickCheck.Modifiers
, module Test.QuickCheck.Monadic
) where
import Control.Applicative (Applicative(..))
import Control.Monad
import Data.Char (isSpace)
import Data.List (foldl')
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 (Microspec specs ()) = do
putStrLn ""
startTime <- getCurrentTime
results <- forM specs $ \test -> do
runTestWith args 0 test
let resultCount :: ResultCounts
resultCount = joinResultList $ map countResults results
endTime <- getCurrentTime
when ((numPending resultCount + numFailures resultCount) /= 0) $
putStrLn "\n ----- Failures and pending:\n"
forM_ (pruneOutSuccesses results) $ \x -> do
printAllTestResults 0 x
putStrLn ""
putStrLn $ "\n -----\nRuntime: " ++ show (diffUTCTime endTime startTime)
let colorF :: String -> String
colorF = case resultCount of
ResultCounts { numPending = 0, numFailures = 0 } -> inGreen
ResultCounts { numFailures = 0 } -> inYellow
_ -> inRed
putStrLn $ colorF $
"Successes: " ++ show (numSuccesses resultCount)
++ ", Pending: " ++ show (numPending resultCount)
++ ", Failures: " ++ show (numFailures resultCount)
when (numFailures resultCount /= 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
pruneOutSuccesses :: [TestTree QC.Result] -> [TestTree QC.Result]
pruneOutSuccesses 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 pruneOutSuccesses xs of
[] -> Nothing
leftover -> Just $ TestBranch theLabel leftover
it :: MTestable t => String -> t -> Microspec ()
it = describe
class MTestable t where
describe :: String -> t -> Microspec ()
instance MTestable Property where
describe testLabel aProp =
Microspec [TestLeaf testLabel (Right aProp)] ()
instance MTestable Bool where
describe testLabel bool =
describe testLabel $ QC.property bool
instance MTestable (TestTree Property) where
describe testLabel x =
Microspec [TestBranch testLabel [x]] ()
instance MTestable Pending where
describe testLabel pend =
Microspec [TestLeaf testLabel (Left pend)] ()
instance MTestable (Microspec ()) where
describe testLabel (Microspec forest ()) =
Microspec [TestBranch testLabel forest] ()
instance (Arbitrary a, Show a, Testable prop) => MTestable (a -> prop) where
describe testLabel f =
describe testLabel $ QC.property f
data ResultCounts
= ResultCounts {
numSuccesses :: Int
, numFailures :: Int
, numPending :: Int
} deriving (Show)
emptyResults :: ResultCounts
emptyResults =
ResultCounts 0 0 0
joinResults :: ResultCounts -> ResultCounts -> ResultCounts
(ResultCounts a0 b0 c0) `joinResults` (ResultCounts a1 b1 c1) =
ResultCounts (a0+a1) (b0+b1) (c0+c1)
joinResultList :: [ResultCounts] -> ResultCounts
joinResultList = foldl' joinResults (ResultCounts 0 0 0)
countResults :: TestTree QC.Result -> ResultCounts
countResults = \case
TestLeaf _ (Right Success{}) ->
emptyResults { numSuccesses = 1 }
TestLeaf _ (Right _) ->
emptyResults { numFailures = 1 }
TestLeaf _ (Left Pending) ->
emptyResults { numPending = 1 }
TestBranch _ ts ->
joinResultList $ map countResults ts
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
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 = (===)
shouldSatisfy :: Show x => x -> (x -> Bool) -> Property
shouldSatisfy x predicate =
counterexample ("Predicate failed on: "++show x) (predicate x)
prop :: MTestable prop => String -> prop -> Microspec ()
prop = describe