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 Test.QuickCheck as QC
import Test.QuickCheck
import Test.QuickCheck.Modifiers
import Test.QuickCheck.Monadic
microspec :: Microspec () -> IO ()
microspec = microspecWith defaultMArgs
microspecWith :: MArgs -> Microspec () -> IO ()
microspecWith args spec = do
putStrLn ""
forM_ (buildTestTrees spec) $ \test -> do
(runTestWith args 0) test
putStrLn ""
runTestWith :: MArgs -> Int -> TestTree -> IO ()
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
putStrLn $ showResult testLabel result
TestLeaf testLabel (Left Pending) ->
putStrLn $ indentationFor depth ++ inYellow (testLabel ++ " - PENDING")
TestBranch testLabel forest -> do
putStrLn $ indentationFor depth ++ testLabel
forM_ forest $ runTestWith args (depth + 1)
where
indentationFor :: Int -> String
indentationFor n = replicate (n*2) ' '
showResult :: String -> QC.Result -> String
showResult testLabel = \case
Success _ _ _ ->
indentationFor depth ++ inGreen testLabel
failure@(Failure{theException=Nothing}) ->
indentationFor depth
++ inRed (testLabel ++ " - "++replaceNewline (output failure))
failure ->
indentationFor depth
++ inRed (testLabel ++" - "++replaceNewline (output failure))
replaceNewline = concatMap $ \case '\n' -> " | " ; x -> [x]
data Pending = Pending
pending :: Pending
pending = Pending
it :: MTestable t => String -> t -> Microspec ()
it = describe
prop :: Testable prop => prop -> Property
prop = property
addTestTree :: TestTree -> 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 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
data TestTree
= TestBranch String [TestTree]
| TestLeaf String (Either Pending Property)
instance Show TestTree where
show = \case
TestBranch testLabel subs -> "Branch "++show testLabel++" "++show subs
TestLeaf testLabel _ -> "Leaf " ++ show testLabel
data Microspec a = Microspec [TestTree] a
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]
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 = (===)