diff --git a/example/e0.hs b/example/e0.hs --- a/example/e0.hs +++ b/example/e0.hs @@ -1,32 +1,68 @@ import Test.QuickCheck.Simple +import System.IO.Error -int1 :: Int -int1 = 1 +boolTQ :: Test +boolTQ = boolTest "true" True -stringHello :: String -stringHello = "Hello" +boolTV :: Test +boolTV = boolTest' "true-verbose" "verbose true" True -prop_int1 :: Bool -prop_int1 = int1 == 1 +boolFQ :: Test +boolFQ = boolTest "false" False -prop_stringHelloBad :: Bool -prop_stringHelloBad = stringHello == "Hellox" +boolFV :: Test +boolFV = boolTest' "false-verbose" "verbose false error message" False -prop_intComBad :: Int -> Int -> Bool -prop_intComBad i j = i + j == j + i + 1 +eqTQ :: Test +eqTQ = eqTest "eq" 1 (1 :: Int) -prop_intCom2Bad :: Int -> Int -> Bool -prop_intCom2Bad i j = i + j == j + i + 2 +eqTV :: Test +eqTV = eqTest' (==) show "eq-verbose" 1 (1 :: Int) -tests :: [Test] -tests = - [ boolTest "int1" prop_int1 - , boolTest' "stringHelloBad" "Hello =/= Hellox" prop_stringHelloBad - , eqTest "stringHelloBad" stringHello "Hellox" - , qcTest "intComBad" prop_intComBad - , qcTest "intCom2Bad" prop_intCom2Bad +eqFQ :: Test +eqFQ = eqTest "neq" 2 (1 :: Int) + +eqFV :: Test +eqFV = eqTest' (==) show "neq-verbose" 2 (1 :: Int) + +qcT :: Test +qcT = qcTest "qc-true" (\x -> (x :: Int) == x) + +qcF :: Test +qcF = qcTest "qc-false" (\x -> (x :: Int) == x + 1) + +successTests :: [Test] +successTests = + [ boolTQ + , boolTV + , eqTQ + , eqTV + , qcT ] +allTests :: [Test] +allTests = + [ boolTQ + , boolTV + , boolFQ + , boolFV + , eqTQ + , eqTV + , eqFQ + , eqFV + , qcT + , qcF + ] + +putLine :: IO () +putLine = putStrLn "\n------------------------------\n" + main :: IO () -main = defaultMain' True tests +main = do + verboseMain successTests + putLine + _ <- tryIOError $ defaultMain allTests + putLine + _ <- tryIOError $ verboseMain allTests + return () diff --git a/quickcheck-simple.cabal b/quickcheck-simple.cabal --- a/quickcheck-simple.cabal +++ b/quickcheck-simple.cabal @@ -1,5 +1,5 @@ name: quickcheck-simple -version: 0.1.0.4 +version: 0.1.1.0 synopsis: Test properties and default-mains for QuickCheck description: This package contains definitions of test properties and default-mains using QuickCheck library. @@ -7,12 +7,13 @@ license-file: LICENSE author: Kei Hibino maintainer: ex8k.hibino@gmail.com -copyright: Copyright (c) 2015-2018 Kei Hibino +copyright: Copyright (c) 2015-2019 Kei Hibino category: Testing build-type: Simple extra-source-files: example/e0.hs cabal-version: >=1.10 -tested-with: GHC == 8.4.1, GHC == 8.4.2, GHC == 8.4.3 +tested-with: GHC == 8.6.1, GHC == 8.6.2, GHC == 8.6.3, GHC == 8.6.4, GHC == 8.6.5 + , GHC == 8.4.1, GHC == 8.4.2, GHC == 8.4.3, GHC == 8.4.4 , GHC == 8.2.1, GHC == 8.2.2 , GHC == 8.0.1, GHC == 8.0.2 , GHC == 7.10.1, GHC == 7.10.2, GHC == 7.10.3 @@ -21,10 +22,15 @@ , GHC == 7.4.1, GHC == 7.4.2 library - exposed-modules: Test.QuickCheck.Simple + exposed-modules: + Test.QuickCheck.Simple + Test.QuickCheck.CompatIO + build-depends: base <5, QuickCheck >=2 hs-source-dirs: src ghc-options: -Wall + if impl(ghc >= 8) + ghc-options: -Wcompat -Wnoncanonical-monadfail-instances default-language: Haskell2010 source-repository head diff --git a/src/Test/QuickCheck/CompatIO.hs b/src/Test/QuickCheck/CompatIO.hs new file mode 100644 --- /dev/null +++ b/src/Test/QuickCheck/CompatIO.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE CPP #-} + +-- | +-- Module : Test.QuickCheck.CompatIO +-- Copyright : 2019 Kei Hibino +-- License : BSD3 +-- +-- Maintainer : ex8k.hibino@gmail.com +-- Stability : experimental +-- Portability : unknown +-- +-- This module provides a compatible ioProperty definition. +module Test.QuickCheck.CompatIO ( + ioProperty, + ) where + +#if MIN_VERSION_QuickCheck(2,7,0) +import Test.QuickCheck (ioProperty) +#else +import Test.QuickCheck.Property (Testable, Property, morallyDubiousIOProperty) + +ioProperty :: Testable prop => IO prop -> Property +ioProperty = morallyDubiousIOProperty +#endif diff --git a/src/Test/QuickCheck/Simple.hs b/src/Test/QuickCheck/Simple.hs --- a/src/Test/QuickCheck/Simple.hs +++ b/src/Test/QuickCheck/Simple.hs @@ -1,6 +1,6 @@ -- | -- Module : Test.QuickCheck.Simple --- Copyright : 2015 Kei Hibino +-- Copyright : 2015-2019 Kei Hibino -- License : BSD3 -- -- Maintainer : ex8k.hibino@gmail.com @@ -14,14 +14,17 @@ , boolTest', boolTest , eqTest', eqTest , qcTest + , Test, TestError (..) - , runTest - , defaultMain', defaultMain + , runTest_, runTest + , defaultMain_, defaultMain, verboseMain + + , defaultMain' ) where import Control.Applicative ((<$>)) -import Control.Monad (when, unless) -import Data.Maybe (fromMaybe, catMaybes) +import Control.Monad (unless) +import Data.Maybe (catMaybes) import Data.Monoid ((<>)) import Test.QuickCheck (Testable, Result (..), quickCheckResult, label) @@ -30,17 +33,11 @@ -- | Property type. 'Bool' or 'Testable' of QuickCheck. data Property - = Bool (Maybe String) Bool + = Bool (Maybe String {- verbose error message -}) Bool | QuickCheck QC.Property -- | Property with label string -type Test = (String, Property) - --- | Test error result. -data TestError - = BFalse (Maybe String) - | QCError Result - deriving Show +type Test = (String {- label -}, Property) mkBoolTest :: String -> Maybe String -> Bool -> Test mkBoolTest n m = ((,) n) . Bool m @@ -74,54 +71,87 @@ -> Test qcTest n = ((,) n) . QuickCheck . label n +-------------------------------------------------------------------------------- + +-- | Test failure result. +data TestError + = BFalse (Maybe String {- verbose error message -}) + | QCError Result + deriving Show + putErrorLn :: String -> IO () putErrorLn = putStrLn . ("*** " <>) -runBool :: String -> Maybe String -> Bool -> IO (Maybe TestError) -runBool n m = d where +printVerbose :: String -> TestError -> IO () +printVerbose lb te = case te of + BFalse m -> maybe (return ()) format m + QCError r -> format $ show r + where + format s = + mapM_ putErrorLn + $ ("label: " <> lb <> ":") : (map (" " <>) $ lines s) + +runBool :: String + -> Maybe String -- ^ verbose error message. Nothing corresponds to not verbose. + -> Bool + -> IO (Maybe TestError) +runBool lb vmsg = d where d True = do - putStrLn $ "+++ OK, success (" <> n <> ")" + putStrLn $ "+++ OK, success (" <> lb <> ")" return Nothing d False = do - putErrorLn $ "Failed! (" <> n <> ")" - return . Just $ BFalse m + putErrorLn $ "Failed! (" <> lb <> ")" + let r = BFalse vmsg + printVerbose lb r + return $ Just r -runQcProp :: String -> QC.Property -> IO (Maybe TestError) -runQcProp n p = err =<< quickCheckResult p where +runQcProp :: Bool -- ^ verbose flag + -> String + -> QC.Property + -> IO (Maybe TestError) +runQcProp verbose lb p = err =<< quickCheckResult p where err (Success {}) = return Nothing err x = do - putErrorLn $ " label: " <> n - return . Just $ QCError x + let r = QCError x + if verbose + then printVerbose lb r -- this action show label + else putErrorLn $ "label: " <> lb -- quickcheck does not show label + return $ Just r -runProp :: String -> Property -> IO (Maybe TestError) -runProp n = d where - d (Bool m b) = runBool n m b - d (QuickCheck p) = runQcProp n p +runProp :: Bool + -> String + -> Property + -> IO (Maybe TestError) +runProp verbose lb prop = case prop of + Bool m b -> runBool lb (if verbose then m else Nothing) b + QuickCheck p -> runQcProp verbose lb p -- | Run a single test suite. -runTest :: Test - -> IO (Maybe TestError) -runTest = uncurry runProp - -runPropL :: String -> Property -> IO (Maybe (String, TestError)) -runPropL n p = do - me <- runProp n p - return $ fmap ((,) n) me +runTest_ :: Bool -- ^ verbose flag + -> Test -- ^ property to test + -> IO (Maybe TestError) -- ^ result action, and may be failure result +runTest_ verbose = uncurry $ runProp verbose -showTestError :: TestError -> String -showTestError = d where - d (BFalse m) = fromMaybe "" m - d (QCError r) = show r +-- | Not verbose version of runTest_ +runTest :: Test -- ^ property to test + -> IO (Maybe TestError) -- ^ result action, and may be failure result +runTest = runTest_ False -- | Default main to run test suites. -defaultMain' :: Bool -> [Test] -> IO () -defaultMain' verbose xs = do - es <- catMaybes <$> mapM (uncurry runPropL) xs - let rlines m r = (m <> ":") : [ " " <> x | x <- lines $ showTestError r ] - when verbose $ mapM_ (\(m, r) -> mapM_ putStrLn $ rlines m r) es +defaultMain_ :: Bool -> [Test] -> IO () +defaultMain_ verbose xs = do + es <- catMaybes <$> mapM (runTest_ verbose) xs unless (null es) $ fail "Some failures are found." +defaultMain' :: Bool -> [Test] -> IO () +defaultMain' = defaultMain_ +{-# DEPRECATED defaultMain' "Use defaultMain_ instead of this." #-} + -- | Not verbose version of 'defaultMain''. defaultMain :: [Test] -> IO () defaultMain = defaultMain' False + +-- | Verbose verison of defaultMain +verboseMain :: [Test] -> IO () +verboseMain = defaultMain' True