diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,21 @@ +The MIT License (MIT) + +Copyright (c) 2013 Timothy Jones + +Permission is hereby granted, free of charge, to any person obtaining a copy of +this software and associated documentation files (the "Software"), to deal in +the Software without restriction, including without limitation the rights to +use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of +the Software, and to permit persons to whom the Software is furnished to do so, +subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS +FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR +COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER +IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN +CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. + diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/cabal-test-quickcheck.cabal b/cabal-test-quickcheck.cabal new file mode 100644 --- /dev/null +++ b/cabal-test-quickcheck.cabal @@ -0,0 +1,33 @@ +name: cabal-test-quickcheck +version: 0.1.0 +homepage: https://github.com/zimothy/cabal-test-quickcheck +license: MIT +license-file: LICENSE +author: Timothy Jones +maintainer: Timothy Jones +copyright: (c) 2013 Timothy Jones +category: Testing +build-type: Simple +cabal-version: >=1.10 +synopsis: QuickCheck for Cabal +description: + Support for QuickCheck with the 'detailed' Cabal testing interface. + +library + hs-source-dirs: src + default-language: Haskell2010 + + ghc-options: -Wall + + exposed-modules: + Distribution.TestSuite.QuickCheck + + build-depends: + base >= 4.6.0 && < 4.7, + Cabal >= 1.16.0 && < 1.19, + QuickCheck >= 2.6 && < 2.7 + +source-repository head + type: git + location: git://github.com/zimothy/cabal-test-quickcheck.git + diff --git a/src/Distribution/TestSuite/QuickCheck.hs b/src/Distribution/TestSuite/QuickCheck.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/TestSuite/QuickCheck.hs @@ -0,0 +1,154 @@ +{-# LANGUAGE NamedFieldPuns #-} + +------------------------------------------------------------------------------ +-- | Joins the QuickCheck testing library with Cabal's detailed interface. +module Distribution.TestSuite.QuickCheck + ( + -- * QuickCheck testing + testProperty + , testPropertyWithOptions + + -- * Re-export of Cabal's interface + , Test + , testGroup + ) where + +------------------------------------------------------------------------------ +import Control.Applicative ((<$>), (<|>)) +import Control.Monad (foldM) +import Data.Maybe (catMaybes) +import Distribution.TestSuite hiding (Result) +import Test.QuickCheck + + +------------------------------------------------------------------------------ +-- | Test a QuickCheck property using the current arguments and the given +-- name. +testProperty :: Testable p => String -> p -> Test +testProperty tname prop = Test $ testInstance tname prop stdOptions + + +------------------------------------------------------------------------------ +-- | Test a QuickCheck property using the given arguments and name. +testPropertyWithOptions :: Testable p + => String -> Options -> p -> Either String Test +testPropertyWithOptions tname options prop = do + args <- foldM (uncurry . addToArgs) stdOptions options + let ti = testInstance tname prop args + return $ Test ti { run = testRun args prop } + + +------------------------------------------------------------------------------ +-- | A test instance with the given 'Args'. +testInstance :: Testable p => String -> p -> Args -> TestInstance +testInstance tname prop args = + let ti = TestInstance (testRun args prop) + tname ["QuickCheck"] qcOptions (addOption args prop ti) in ti + + +------------------------------------------------------------------------------ +-- | Given QuickCheck 'Args' and the property to test, produces a Cabal +-- testing action. +testRun :: Testable p => Args -> p -> IO Progress +testRun args prop = toProgress <$> quickCheckWithResult args prop + + +------------------------------------------------------------------------------ +-- | Adds a Cabal option to the TestInstance. Fails if QuickCheck does not +-- support the option. +addOption :: Testable p => Args -> p -> TestInstance -> String -> String + -> Either String TestInstance +addOption args prop test oname value = do + args' <- addToArgs args oname value + Right test { run = testRun args' prop } + + +------------------------------------------------------------------------------ +-- | Validates the option and adds it to the given Args value. +addToArgs :: Args -> String -> String -> Either String Args +addToArgs args oname value = do + option <- lookupOption oname + otype <- validOption option value + case otype of + Bool -> Right args { chatty = read value } + Int -> let int = read value in case oname of + "max-success" -> Right args { maxSuccess = int } + "max-discard-ratio" -> Right args { maxDiscardRatio = int } + "max-size" -> Right args { maxSize = int } + _ -> Left $ "Unrecognised option " ++ oname + + +------------------------------------------------------------------------------ +-- | Finds the option in the option list. +lookupOption :: String -> Either String OptionDescr +lookupOption oname = maybe (Left $ "Unrecognised option" ++ oname) Right $ + foldr f Nothing qcOptions + where f o = (<|> if optionName o == oname then Just o else Nothing) + + +------------------------------------------------------------------------------ +-- | Determines if the option is valid for the given value, returning the +-- type of the option if it is. +validOption :: OptionDescr -> String -> Either String OType +validOption descr value = case optionType descr of + OptionNumber True (lower, upper) -> do + testIsInt + testWithinBounds lower upper + return Int + OptionBool -> + if value `elem` ["True", "False"] then return Bool else + Left $ "Invalid boolean value for option " ++ oname + _ -> + Left $ "Unknown type for option " ++ oname + where + oname = optionName descr + + testIsInt = let parse = reads value :: [(Int, String)] in + if null parse || not (null . snd $ head parse) + then Left $ "Invalid integer value for option " ++ oname + else Right () + + testWithinBounds lower upper = let int = read value in + if or $ catMaybes [(int >=) <$> lower, (int <=) <$> upper] + then Left $ "Value out of bounds for option " ++ oname + else Right () + + +------------------------------------------------------------------------------ +-- | Converts a QuickCheck 'Result' into a Cabal 'Progress'. +toProgress :: Result -> Progress +toProgress result = Finished $ case result of + Success {} -> Pass + GaveUp {} -> Fail "Gave up" + Failure { reason } -> Fail reason + NoExpectedFailure {} -> Fail "Expected failure when none occurred" + + +------------------------------------------------------------------------------ +-- | The supported option types. +data OType = Int | Bool + + +------------------------------------------------------------------------------ +-- | The potential QuickCheck options. +qcOptions :: [OptionDescr] +qcOptions = + [ OptionDescr "max-success" msud (int "1") $ Just "100" + , OptionDescr "max-discard-ratio" mdrd (int "0") $ Just "10" + , OptionDescr "max-size" msid (int "1") $ Just "100" + , OptionDescr "chatty" cd OptionBool $ Just "False" + ] + where + int b = OptionNumber True (Just b, Nothing) + msud = "Maximum number of successful test before succeeding" + mdrd = "Maximum number of discarded tests per successful test before \ + \ giving up" + msid = "Size to use for the biggest test cases" + cd = "Whether to print anything" + + +------------------------------------------------------------------------------ +-- | The standard QuickCheck 'Args', but with the 'chatty' option turned off. +stdOptions :: Args +stdOptions = stdArgs { chatty = False } +