diff --git a/src/Test/Simple.hs b/src/Test/Simple.hs --- a/src/Test/Simple.hs +++ b/src/Test/Simple.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving, MultiParamTypeClasses, TemplateHaskell #-} +{-# LANGUAGE GeneralizedNewtypeDeriving, MultiParamTypeClasses, TemplateHaskell, FlexibleInstances #-} ---------------------------------------------------------------------- -- | -- Module : Test.Simple @@ -11,7 +11,14 @@ -- Test.Simple is yet another testing library for Haskell. It has testing primitives -- familiar to recovering Perl programmers :). -- --- Here is example suitable for cabal test-suite integration. Note that TemplateHaskell +-- Having 'MonadPlus' instance allows to cut tests early e.g using 'guard' function. +-- +-- Being monad transformer it includes integration with 'QuickCheck' by declaring 'Testable' instance +-- on @TestSimpleT Gen a@. +-- +-- Test.Simple also has the ability to run in pure context (see 'runTestSimple' function). +-- +-- Here is an example suitable for cabal test-suite integration. Note that TemplateHaskell -- usage is optional and is needed for test failure locations only. -- -- @ @@ -41,7 +48,7 @@ TestSimpleT, Likeable(isLike), -- * Main - testSimpleMain, runTestSimple, + testSimpleMain, runTestSimple, qcTestSimpleMain, -- * Plan plan, @@ -55,9 +62,12 @@ import Control.Monad.Trans.State.Plus import Control.Monad.State import System.Exit (exitFailure) -import Data.List (isInfixOf) +import Data.List (isInfixOf, intercalate) import System.IO (hPutStrLn, stderr) import qualified Language.Haskell.TH as TH +import Test.QuickCheck (Testable(property), quickCheckResult, Gen) +import Test.QuickCheck.Test (isSuccess) +import Test.QuickCheck.Property (Result(reason), succeeded, failed) -- | Is used in 'like', 'unlike' tests. class Likeable a b where @@ -87,9 +97,9 @@ where finish = do s <- get - let failed = tsFailed s > 0 + let fld = tsFailed s > 0 let mismatch = (tsPlanned s /= tsCounter s) - if failed + if fld then diag $ "Looks like you failed " ++ show (tsFailed s) ++ " test of " ++ show (tsPlanned s) ++ "." else if mismatch @@ -97,7 +107,7 @@ ++ " tests but ran " ++ show (tsCounter s) ++ "." else return () modify finOutput - return $ not (failed || mismatch) + return $ not (fld || mismatch) finOutput s = s { tsOutput = (StdOut $ "1.." ++ show (tsPlanned s)):(reverse $ tsOutput s) } isFailed s = tsFailed s > 0 || (tsPlanned s /= tsCounter s) @@ -203,3 +213,14 @@ m = TH.loc_module l s = TH.loc_start l e = TH.loc_end l + +instance Testable (TestSimpleT Gen a) where + property m = do + (b, lns) <- runTestSimple m + property $ if b then succeeded else failed { reason = intercalate "\n" lns } + +-- | Run some 'Testable' monad through 'QuickCheck'. Exit with failure on error. +qcTestSimpleMain :: (Testable (m a), Monad m) => m a -> IO () +qcTestSimpleMain m = do + res <- quickCheckResult m + unless (isSuccess res) exitFailure diff --git a/test-simple.cabal b/test-simple.cabal --- a/test-simple.cabal +++ b/test-simple.cabal @@ -1,5 +1,5 @@ Name: test-simple -Version: 0.1.2 +Version: 0.1.3 License: BSD3 License-File: COPYING Copyright: Boris Sukholitko, 2012 @@ -14,14 +14,14 @@ results in TAP format. library - build-depends: base < 5, mtl, template-haskell, state-plus + build-depends: base < 5, mtl, template-haskell, state-plus, QuickCheck > 2.4 hs-source-dirs: src ghc-options: -Wall exposed-modules: Test.Simple test-suite Main type: exitcode-stdio-1.0 - build-depends: base < 5, test-simple, process, executable-path, mtl + build-depends: base < 5, test-simple, process, executable-path, mtl, QuickCheck > 2.4 ghc-options: -Wall hs-source-dirs: tests main-is: Main.hs diff --git a/tests/Main.hs b/tests/Main.hs --- a/tests/Main.hs +++ b/tests/Main.hs @@ -4,9 +4,10 @@ import System.Environment (getArgs) import System.Environment.Executable (getExecutablePath) import System.Process (readProcessWithExitCode) -import Control.Monad.Trans (liftIO) +import Control.Monad.Trans (liftIO, lift) import System.Exit (ExitCode(ExitSuccess)) import Control.Monad (guard) +import Test.QuickCheck (Gen, arbitrary) locTest :: TestSimpleT IO Bool locTest = $loc >> ok False @@ -55,7 +56,7 @@ testLocationPrint :: ExitCode -> String -> String -> TestSimpleT IO Bool testLocationPrint ec _ err = do isnt ec ExitSuccess - like err " Failed test at tests/Main.hs line 12" + like err " Failed test at tests/Main.hs line 13" like err "# Looks like you failed 1 test of 1.\n" testMPlus :: ExitCode -> String -> String -> TestSimpleT IO Bool @@ -91,9 +92,20 @@ is err "" is out "True\n1..1\n# Bar\nok 1\n" +testQCOK :: ExitCode -> String -> String -> TestSimpleT IO Bool +testQCOK ec out _ = do + is ec ExitSuccess + is out "+++ OK, passed 100 tests.\n" + +testQCFail :: ExitCode -> String -> String -> TestSimpleT IO Bool +testQCFail ec out err = do + isnt ec ExitSuccess + like err "not ok 1" + like out "Failed! 1..1" + testAll :: IO () testAll = testSimpleMain $ do - plan 47 + plan 52 pn <- liftIO getExecutablePath mapM_ (runMyself pn) [ ("bbbf", testUnknown), ("ok1", testOk1), ("nok1", testNOk1) , ("mism", testMismatch), ("isf", testIsFailure) @@ -101,11 +113,20 @@ , ("unlike", testOk1), ("fail_unlike", testUnlikeFailure) , ("guard", testOk1), ("mplus", testMPlus), ("fail_mplus", testMPlusFail) , ("guardisnt", testGuard), ("either", testEither) - , ("runts", testRunTS) ] + , ("runts", testRunTS), ("qcrunok", testQCOK), ("qcfail", testQCFail) ] where runMyself pn (arg, act) = do (ec, out, err) <- liftIO $ readProcessWithExitCode pn [ arg ] "" act ec out err +identTS :: TestSimpleT Gen () +identTS = plan 1 >> ok True >> return () + +failQC :: TestSimpleT Gen Bool +failQC = do + plan 1 + b <- lift arbitrary + ok b + main :: IO () main = do as <- getArgs @@ -131,5 +152,7 @@ (b, lg) <- runTestSimple $ plan 1 >> diag "Bar" >> ok True putStrLn $ show b mapM_ putStrLn lg + [ "qcrunok" ] -> qcTestSimpleMain identTS + [ "qcfail" ] -> qcTestSimpleMain failQC _ -> error $ "Unknown: " ++ show as