diff --git a/Test/Microspec.hs b/Test/Microspec.hs --- a/Test/Microspec.hs +++ b/Test/Microspec.hs @@ -6,11 +6,11 @@ -- > describe "plus" $ do -- > it "adds positive numbers" $ do -- > it "does 1 + 1" $ --- > 1 + 1 == 2 +-- > 1 + 1 === 2 -- > it "does 2 + 2" $ --- > 2 + 2 == 4 +-- > 2 + 2 === 4 -- > it "is commutative" $ --- > \x y -> x + y == y + (x :: Int) +-- > \x y -> x + y === y + (x :: Int) -- -- ...which will return, nicely in green instead of bold: -- @@ -20,10 +20,15 @@ -- __does 1 + 1__ -- __does 2 + 2__ -- __is commutative__ +-- +-- ----- +-- Successes: 3, Pending: 0, Failures: 0 -- @ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE + FlexibleInstances + , LambdaCase + #-} module Test.Microspec ( -- * Specification @@ -50,7 +55,10 @@ -- , module Test.QuickCheck.Property ) where +import Data.Char (isSpace) +import Data.Maybe (mapMaybe) import Control.Monad +import System.Exit (exitWith, ExitCode(ExitFailure)) -- import Data.Time (getCurrentTime, diffUTCTime) import Test.QuickCheck as QC import Test.QuickCheck @@ -58,13 +66,32 @@ import Test.QuickCheck.Monadic -- import Test.QuickCheck.Property + +-- Basically a writer monad: + +-- | A series of tests, to run with 'microspec' +data Microspec a = Microspec [TestTree Property] a + +data TestTree x + = TestBranch String [TestTree x] + | TestLeaf String (Either Pending x) + +-- If you like the word 'pending', this is the place for you!: +data Pending = Pending +-- | Describe a test as unwritten, e.g.: +-- +-- > describe "meaning of life" $ pending +pending :: Pending +pending = Pending + + ---------- User-facing: -- | Run your spec. Put this at the top level, e.g.: -- -- > main = microspec $ do -- > describe "plus 1" $ --- > 3 + 1 == 4 +-- > 3 + 1 === 4 microspec :: Microspec () -> IO () microspec = microspecWith defaultMArgs @@ -72,23 +99,67 @@ microspecWith :: MArgs -> Microspec () -> IO () microspecWith args spec = do putStrLn "" - forM_ (buildTestTrees spec) $ \test -> do - (runTestWith args {- 1 -} 0) test + 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 + when ((numPend + numFail) /= 0) $ + putStrLn "\n ----- Failures and pending:\n" + forM_ (filterPendingAndFails results) $ \x -> do + printAllTestResults 0 x putStrLn "" + putStrLn "\n -----\n" + 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 -> IO () +-- TODO: maybe can separate producer and consumer here +-- Only reason not to is if we wouldn't get incremental printing of results +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 - putStrLn $ showResult testLabel result - TestLeaf testLabel (Left Pending) -> - putStrLn $ indentationFor depth ++ inYellow (testLabel ++ " - PENDING") + 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 - putStrLn $ indentationFor depth ++ testLabel - forM_ forest $ runTestWith args (depth + 1) + printSingleTestResult depth $ TestBranch testLabel [] -- Kinda kludge + 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 ++ " - PENDING") + TestBranch testLabel _ -> do + putStrLn $ labelStr testLabel where indentationFor :: Int -> String indentationFor n = replicate (n*2) ' ' -- ++ "- " @@ -97,28 +168,30 @@ showResult testLabel = \case -- note: if we wanted to show quickcheck labels, this is where we would: Success _ _ _ -> - indentationFor depth ++ inGreen testLabel + inGreen testLabel failure@(Failure{theException=Nothing}) -> - indentationFor depth - ++ inRed (testLabel ++ " - "++replaceNewline (output failure)) -{- - ++ "\n" - ++ indentationFor (depth + 1) ++ inRed (show $ usedSeed failure) --} + inRed (testLabel ++ " - "++replaceNewline (output failure)) failure {- @(Failure{}) -} -> - indentationFor depth - ++ inRed (testLabel ++" - "++replaceNewline (output failure)) + inRed (testLabel ++" - "++replaceNewline (output failure)) replaceNewline = concatMap $ \case '\n' -> " | " ; x -> [x] - - --- If you like the word 'pending', this is the place for you!: -data Pending = Pending --- | Describe a test as unwritten, e.g.: --- --- > describe "meaning of life" $ pending -pending :: Pending -pending = Pending + 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 + -- TODO: might want to explicitly pattern-match here: + x@(TestLeaf _ (Right _)) -> Just x + x@(TestLeaf _ (Left Pending)) -> Just x + TestBranch theLabel xs -> case filterPendingAndFails xs of + [] -> Nothing + leftover -> Just $ TestBranch theLabel leftover + ---------- Handy @@ -128,24 +201,14 @@ -- > it "doubles with 2" $ -- > replicate 2 'x' === "xx" -- > it "creates a list of the right size" $ --- > \(Positive n) -> length (replicate n 'x') == n +-- > \(Positive n) -> length (replicate n 'x') === n it :: MTestable t => String -> t -> Microspec () it = describe --- | Make a test case from a QuickCheck function. Alias for 'Test.QuickCheck.property'. --- --- Note that you don't need to use this to create a test, e.g.: --- --- > describe "reverse preserves length" $ --- > \l -> length (reverse l) == length l -prop :: Testable prop => prop -> Property -prop = property - - ---------- Constructing a test tree: -addTestTree :: TestTree -> Microspec () +addTestTree :: TestTree Property -> Microspec () addTestTree tree = Microspec [tree] () -- | Something which can be tested @@ -185,33 +248,48 @@ -- > reverse "foo" === "oof" describe :: String -> t -> Microspec () instance MTestable Property where - describe testLabel aProp = addTestTree $ TestLeaf testLabel (Right aProp) + 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] + 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) + 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 + describe testLabel f = + describe testLabel $ property f -data TestTree - = TestBranch String [TestTree] - | TestLeaf String (Either Pending Property) +-- TODO: general function for these 3: +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 where +instance Show (TestTree x) where show = \case - TestBranch testLabel subs -> "Branch "++show testLabel++" "++show subs - TestLeaf testLabel _ -> "Leaf " ++ show testLabel - --- Basically a writer monad: - --- | A series of tests, to run with 'microspec' -data Microspec a = Microspec [TestTree] a + 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) @@ -228,7 +306,7 @@ Microspec forest1 b = f a in Microspec (forest0 ++ forest1) b -buildTestTrees :: Microspec () -> [TestTree] +buildTestTrees :: Microspec () -> [TestTree Property] buildTestTrees (Microspec x _) = x @@ -259,8 +337,9 @@ ---------- Pretty-printing: inRed, inGreen, inYellow :: String -> String -[inRed,inGreen, inYellow] = (`map` [31,32,33]) $ \colorNum -> - \s -> "\ESC["++show (colorNum::Int)++"m"++s++"\ESC[m" +[inRed,inGreen, inYellow] = + (`map` [31,32,33]) $ \colorNum -> + \s -> "\ESC["++show (colorNum::Int)++"m"++s++"\ESC[m" @@ -270,3 +349,9 @@ shouldBe :: (Eq x, Show x) => x -> x -> Property shouldBe = (===) +-- | Note that you don't need to use this to create a test, e.g.: +-- +-- > describe "reverse preserves length" $ +-- > \l -> length (reverse l) === length l +prop :: MTestable prop => String -> prop -> Microspec () +prop = describe diff --git a/microspec.cabal b/microspec.cabal --- a/microspec.cabal +++ b/microspec.cabal @@ -1,5 +1,5 @@ name: microspec -version: 0.1.0.0 +version: 0.2.0.0 synopsis: Tiny QuickCheck test library with minimal dependencies description: A tiny (1 module, <500 lines) property-based (and unit) testing library with minimal dependencies. @@ -15,17 +15,17 @@ > main = microspec $ do > describe "replicate" $ do > it "doubles with 2" $ - > replicate 2 'x' == "xx" + > replicate 2 'x' === "xx" > it "creates a list of the right size" $ - > \(Positive n) -> length (replicate n 'x') == n + > \(Positive n) -> length (replicate n 'x') === n > > describe "reverse" $ do - > it "reverse . reverse == id" $ \l -> - > reverse (reverse l) == (l :: [Int]) + > it "reverse . reverse === id" $ \l -> + > reverse (reverse l) === (l :: [Int]) > > describe "tail" $ > it "length is -1" $ \(NonEmpty l) -> - > length (tail l :: [Int]) == length l - 1 + > length (tail l :: [Int]) === length l - 1 > > describe "solve the halting problem" $ > pending