microspec-0.2.0.0: Test/Microspec.hs

-- | Tests can be structured as nested 'it' / 'describe' statements
-- 
--   E.g.
-- 
--   > microspec $ do
--   >    describe "plus" $ do
--   >       it "adds positive numbers" $ do
--   >          it "does 1 + 1" $
--   >             1 + 1 === 2
--   >          it "does 2 + 2" $
--   >             2 + 2 === 4
--   >       it "is commutative" $
--   >          \x y -> x + y === y + (x :: Int)
-- 
--   ...which will return, nicely in green instead of bold:
-- 
--   @
--   plus
--     adds positive numbers
--       __does 1 + 1__
--       __does 2 + 2__
--     __is commutative__
-- 
--   -----
--   Successes: 3, Pending: 0, Failures: 0
--   @

{-# LANGUAGE
     FlexibleInstances
   , LambdaCase
   #-}

module Test.Microspec (
     -- * Specification
     microspec
   , microspecWith
   , describe
   , it
   , pending
   , prop
   , Microspec
   , MTestable

     -- * Configuration
   , MArgs(..)
   , defaultMArgs

     -- * Compatibility
   , shouldBe

     -- Reexports
   , module Test.QuickCheck
   , module Test.QuickCheck.Modifiers
   , module Test.QuickCheck.Monadic
   -- , 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
import Test.QuickCheck.Modifiers
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
microspec :: Microspec () -> IO ()
microspec = microspecWith defaultMArgs

-- | 'microspec' with 'MArgs'
microspecWith :: MArgs -> Microspec () -> IO ()
microspecWith args spec = do
   putStrLn ""
   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

-- 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
      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 [] -- 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) ' ' -- ++ "- "

   showResult :: String -> QC.Result -> String
   showResult testLabel = \case
       -- note: if we wanted to show quickcheck labels, this is where we would:
      Success _ _ _ ->
         inGreen testLabel
      failure@(Failure{theException=Nothing}) ->
         inRed (testLabel ++ " - "++replaceNewline (output failure))
      failure {- @(Failure{}) -} ->
         inRed (testLabel ++" - "++replaceNewline (output failure))
   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
       -- 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

-- | An alias for 'describe'. Usually used inside a 'describe' block:
-- 
--   >  describe "replicate" $ do
--   >     it "doubles with 2" $
--   >        replicate 2 'x' === "xx"
--   >     it "creates a list of the right size" $
--   >        \(Positive n) -> length (replicate n 'x') === n
it :: MTestable t => String -> t -> Microspec ()
it = describe


---------- Constructing a test tree:

addTestTree :: TestTree Property -> Microspec ()
addTestTree tree = Microspec [tree] ()

-- | Something which can be tested
-- 
--   Note both Bools and Properties can be tested, but only Properties show
--   the values that weren't equal
-- 
--   For both unit tests and property tests, if you want to see the outputs
--   of failed tests use 'Test.QuickCheck.==='. If you just want to test for
--   equality, use 'Prelude.=='.
-- 
--   For example, the outputs of running:
-- 
--   @
--   microspec $ do
--      describe "baddies" $ do
--         it "isn't 1 =="  $ 0 == (1 :: Int)
--         it "isn't 1 ===" $ 0 === (1 :: Int)
--         it "isn't always 1 =="  $ \x -> x == (1 :: Int)
--         it "isn't always 1 ===" $ \x -> x === (1 :: Int)
--   @
-- 
--   are:
-- 
--   @
--   isn't 1 == - *** Failed! Falsifiable (after 1 test)
--   isn't 1 === - *** Failed! Falsifiable (after 1 test):  | 0 /= 1
--   isn't always 1 == - *** Failed! Falsifiable (after 1 test):  | 0
--   isn't always 1 === - *** Failed! Falsifiable (after 1 test):  | 0 | 0 /= 1
--   @


class MTestable t where
   -- | Describe a test, e.g.:
   -- 
   --   > describe "reverse 'foo' is 'oof'" $
   --   >    reverse "foo" === "oof"
   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

-- 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 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




---------- Configuration:

-- | Default arguments. Calling \"microspec\" is the same as calling
--   \"microspecWith defaultMArgs\".
defaultMArgs :: MArgs
defaultMArgs = MArgs {
    _mArgs_timeoutSecs = Nothing -- Just 60
   ,_mArgs_qcArgs = QC.stdArgs { chatty = False }
   }

-- | Tweak how tests are run, with 'microspecWith'.
data MArgs = MArgs {
    _mArgs_timeoutSecs :: Maybe Double -- ^ Number of seconds before each
                                        --   test times out. If you want to
                                        --   do this on a per-test basis, try
                                        --   'Test.QuickCheck.Property.within'
   ,_mArgs_qcArgs :: QC.Args -- ^ Arguments to use with QuickCheck tests
   }
 deriving (Show, Read) -- , Eq, Ord)



---------- Pretty-printing:

inRed, inGreen, inYellow :: String -> String
[inRed,inGreen, inYellow] =
   (`map` [31,32,33]) $ \colorNum ->
      \s -> "\ESC["++show (colorNum::Int)++"m"++s++"\ESC[m"



---------- HSpec compatibility

-- | Hspec compatibility. Equivalent to using 'Test.QuickCheck.==='
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