cabal-detailed-quickcheck (empty) → 0.1.0.0
raw patch · 4 files changed
+379/−0 lines, 4 filesdep +Cabaldep +QuickCheckdep +base
Dependencies added: Cabal, QuickCheck, base
Files
- CHANGELOG.md +5/−0
- LICENSE +20/−0
- cabal-detailed-quickcheck.cabal +32/−0
- lib/Distribution/TestSuite/QuickCheck.hs +322/−0
+ CHANGELOG.md view
@@ -0,0 +1,5 @@+# Revision history for cabal-detailed-quickcheck++## 0.1.0.0 -- YYYY-mm-dd++* First version. Released on an unsuspecting world.
+ LICENSE view
@@ -0,0 +1,20 @@+Copyright (c) 2022 Anselm Schüler++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.
+ cabal-detailed-quickcheck.cabal view
@@ -0,0 +1,32 @@+cabal-version: 2.4+name: cabal-detailed-quickcheck+version: 0.1.0.0+synopsis: QuickCheck for Cabal tests+description: Turn QuickCheck properties into detailed Cabal tests+homepage: https://github.com/schuelermine/cabal-detailed-quickcheck+bug-reports: https://github.com/schuelermine/cabal-detailed-quickcheck/issues+license: MIT+license-file: LICENSE+author: Anselm Schüler+maintainer: mail@anselmschueler.com+copyright: Ⓒ Anselm Schüler 2022+category: Testing+extra-source-files: CHANGELOG.md++library+ exposed-modules: Distribution.TestSuite.QuickCheck+ build-depends: base >=4.14&&<4.18,+ QuickCheck ^>=2.14.2,+ Cabal ^>=3.6.3+ hs-source-dirs: lib+ default-language: Haskell2010++source-repository head+ type: git+ location: https://github.com/schuelermine/cabal-detailed-quickcheck.git+ branch: b0++source-repository this+ type: git+ location: https://github.com/schuelermine/cabal-detailed-quickcheck.git+ tag: 0.1.0.0
+ lib/Distribution/TestSuite/QuickCheck.hs view
@@ -0,0 +1,322 @@+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE RecordWildCards #-}++-- NoFieldSelectors is implemented in GHC 9.2.2, but HLS doesn’t support it+-- {-# LANGUAGE NoFieldSelectors #-}++-- |+-- Module: Distribution.TestSuite.QuickCheck+-- Description: Convert QuickCheck properties into Cabal tests+-- Copyright: ⓒ Anselm Schüler 2022+-- License: MIT+-- Maintainer: Anselm Schüler <mail@anselmschueler.com>+-- Stability: stable+-- Portability: Portable+--+-- This module allows you to easily make Cabal tests for the @detailed-0.9@ interface.+-- It sets sensible option declarations for the tests.+--+-- This module re-uses record names from 'Distribution.TestSuite' and 'Test.QuickCheck'.+-- It is recommended that you enable the @DisambiguateRecordFields@ extension in GHC and/or import the module qualified.+-- For basic tests, you don’t need to import 'Distribution.TestSuite'.+module Distribution.TestSuite.QuickCheck+ ( -- * Create tests+ getPropertyTest,+ getPropertyTestWith,+ getPropertyTestUsing,+ getPropertyTestWithUsing,++ -- * Argument data types+ PropertyTest (..),+ TestArgs (..),+ Verbosity (..),++ -- * Functions for using arguments+ argsToTestArgs,+ testArgsToArgs,+ stdTestArgs,+ )+where++import Data.Bool (bool)+import Data.Functor ((<&>))+import qualified Distribution.TestSuite as T+import qualified Test.QuickCheck as QC+import Text.Read (readMaybe)++-- | Datatype for setting the verbosity of tests+data Verbosity+ = -- | QuickCheck prints nothing+ Silent+ | -- | Print basic statistics+ Chatty+ | -- | Print every test case+ Verbose+ deriving+ ( Eq,+ -- | 'Silent' < 'Chatty' < 'Verbose'+ Ord,+ Show,+ Read,+ Enum,+ Bounded+ )++-- ! [PARTIAL] This function fails when passed Silent+switchVerbosity :: Verbosity -> Bool -> Verbosity -> Verbosity+switchVerbosity v' q v = bool max min q v $ bool id pred q v'++-- | Arguments for altering property test behaviour.+-- These can be altered in the final Cabal 'T.Test' using 'T.setOption'.+data TestArgs = TestArgs+ { verbosity :: Verbosity,+ verboseShrinking :: Bool,+ maxDiscardRatio :: Int,+ noShrinking :: Bool,+ maxShrinks :: Int,+ maxSuccess :: Int,+ maxSize :: Int,+ sizeScale :: Int+ }++-- | Transform a QuickCheck 'QC.Args' value to a 'TestArgs' value, defaulting all missing properties+argsToTestArgs :: QC.Args -> TestArgs+argsToTestArgs QC.Args {..} =+ TestArgs+ { verbosity = if chatty then Chatty else Silent,+ verboseShrinking = False,+ maxDiscardRatio,+ noShrinking = False,+ maxShrinks,+ maxSuccess,+ maxSize,+ sizeScale = 1+ }++-- | Default arguments for property tests+stdTestArgs :: TestArgs+stdTestArgs = argsToTestArgs QC.stdArgs++-- | Recover arguments passed to 'QC.quickCheck' from a 'TestArgs'+testArgsToArgs :: TestArgs -> QC.Args+testArgsToArgs+ TestArgs+ { verbosity,+ maxDiscardRatio,+ maxShrinks,+ maxSuccess,+ maxSize+ } =+ QC.Args+ { replay = Nothing,+ maxSuccess,+ maxDiscardRatio,+ maxSize,+ chatty = verbosity >= Chatty,+ maxShrinks+ }++useModifiers :: QC.Testable a => TestArgs -> a -> QC.Property+useModifiers TestArgs {verbosity, noShrinking, verboseShrinking, sizeScale} =+ foldr (.) QC.property $+ snd+ <$> filter+ fst+ [ (verbosity == Verbose, QC.verbose),+ (verboseShrinking, QC.verboseShrinking),+ (noShrinking, QC.noShrinking),+ (sizeScale /= 1, QC.mapSize (* sizeScale))+ ]++qcTestArgs :: QC.Testable a => TestArgs -> a -> IO QC.Result+qcTestArgs args property = QC.quickCheckWithResult (testArgsToArgs args) (useModifiers args property)++switchVIn :: Verbosity -> Bool -> TestArgs -> TestArgs+switchVIn v' q args@TestArgs {verbosity} = args {verbosity = switchVerbosity v' q verbosity}++setArgStr :: String -> String -> Maybe (TestArgs -> TestArgs)+setArgStr "silent" str =+ readMaybe str <&> \val args@TestArgs {verbosity} ->+ if val+ then args {verbosity = Silent}+ else args {verbosity = max Chatty verbosity}+setArgStr "chatty" str = readMaybe str <&> switchVIn Chatty+setArgStr "verbose" str = readMaybe str <&> switchVIn Verbose+setArgStr "verboseShrinking" str =+ readMaybe str <&> \val args ->+ args {verboseShrinking = val}+setArgStr "verbosity" str =+ readMaybe str <&> \val args ->+ args {verbosity = val}+setArgStr "maxDiscardRatio" str =+ readMaybe str <&> \val args ->+ args {maxDiscardRatio = val}+setArgStr "noShrinking" str =+ readMaybe str <&> \val args ->+ args {noShrinking = val}+setArgStr "shrinking" str =+ readMaybe str <&> \val args ->+ args {noShrinking = not val}+setArgStr "maxShrinks" str =+ readMaybe str <&> \val args ->+ args {maxShrinks = val}+setArgStr "maxSuccess" str =+ readMaybe str <&> \val args ->+ args {maxSuccess = val}+setArgStr "maxSize" str =+ readMaybe str <&> \val args ->+ args {maxSize = val}+setArgStr "sizeScale" str =+ readMaybe str <&> \val args ->+ args {sizeScale = val}+setArgStr _ _ = Nothing++positiveIntType :: T.OptionType+positiveIntType =+ T.OptionNumber+ { optionNumberIsInt = True,+ optionNumberBounds = (Just "1", Nothing)+ }++getOptionDescrs :: TestArgs -> [T.OptionDescr]+getOptionDescrs TestArgs {..} =+ [ T.OptionDescr+ { optionName = "silent",+ optionDescription = "Suppress QuickCheck output",+ optionType = T.OptionBool,+ optionDefault = Just . show $ verbosity == Silent+ },+ T.OptionDescr+ { optionName = "chatty",+ optionDescription = "Print QuickCheck output",+ optionType = T.OptionBool,+ optionDefault = Just . show $ verbosity > Chatty+ },+ T.OptionDescr+ { optionName = "verbose",+ optionDescription = "Print checked values",+ optionType = T.OptionBool,+ optionDefault = Just . show $ verbosity > Verbose+ },+ T.OptionDescr+ { optionName = "verboseShrinking",+ optionDescription = "Print all checked and shrunk values",+ optionType = T.OptionBool,+ optionDefault = Just . show $ verboseShrinking+ },+ T.OptionDescr+ { optionName = "verbosity",+ optionDescription = "Verbosity level",+ optionType = T.OptionEnum ["Silent", "Chatty", "Verbose", "VerboseShrinking"],+ optionDefault = Just $ show verbosity+ },+ T.OptionDescr+ { optionName = "maxDiscardRatio",+ optionDescription = "Maximum number of discarded tests per successful test before giving up",+ optionType = positiveIntType,+ optionDefault = Just $ show maxDiscardRatio+ },+ T.OptionDescr+ { optionName = "noShrinking",+ optionDescription = "Disable shrinking",+ optionType = T.OptionBool,+ optionDefault = Just $ show noShrinking+ },+ T.OptionDescr+ { optionName = "shrinking",+ optionDescription = "Enable shrinking",+ optionType = T.OptionBool,+ optionDefault = Just . show $ not noShrinking+ },+ T.OptionDescr+ { optionName = "maxShrinks",+ optionDescription = "Maximum number of shrinks to before giving up or zero to disable shrinking",+ optionType = positiveIntType,+ optionDefault = Just $ show maxShrinks+ },+ T.OptionDescr+ { optionName = "maxSuccess",+ optionDescription = "Maximum number of successful tests before succeeding",+ optionType = positiveIntType,+ optionDefault = Just $ show maxSuccess+ },+ T.OptionDescr+ { optionName = "maxSize",+ optionDescription = "Size to use for the biggest test cases",+ optionType = positiveIntType,+ optionDefault = Just $ show maxSize+ },+ T.OptionDescr+ { optionName = "sizeScale",+ optionDescription = "Scale all sizes by a number",+ optionType = positiveIntType,+ optionDefault = Just $ show sizeScale+ }+ ]++-- | Property test declaration with metadata+data PropertyTest prop = PropertyTest+ { -- | Name of the test, for Cabal. See See Cabal’s 'T.name'.+ name :: String,+ -- | Tags of the test, for Cabal. See Cabal’s 'T.tags'.+ tags :: [String],+ -- | Property to check. This should usually be or return an instance of 'QC.Testable'.+ property :: prop+ }++-- | Get a Cabal 'T.Test' with custom 'TestArgs' from a 'PropertyTest' that takes the test arguments and returns a 'QC.testable' value+getPropertyTestWithUsing ::+ QC.Testable prop =>+ -- | The arguments for the test+ TestArgs ->+ -- | A property test whose 'property' takes a 'TestArgs' argument+ PropertyTest (TestArgs -> prop) ->+ T.Test+getPropertyTestWithUsing originalArgs PropertyTest {..} =+ let withArgs args =+ T.TestInstance+ { run = do+ result <- qcTestArgs args (property args)+ let resultStr = "\n" ++ show result+ return $ T.Finished case result of+ QC.Success {} -> T.Pass+ QC.GaveUp {} -> T.Error $ "GaveUp: QuickCheck gave up" ++ resultStr+ QC.Failure {} -> T.Fail $ "Failure: A property failed" ++ resultStr+ QC.NoExpectedFailure {} ->+ T.Fail $+ "NoExpectedFailure: A property that should have failed did not"+ ++ "\n"+ ++ show result,+ name,+ tags,+ options = getOptionDescrs originalArgs,+ setOption = \opt str -> case setArgStr opt str of+ Nothing -> Left "Parse error"+ Just f -> Right . withArgs $ f args+ }+ in T.Test $ withArgs originalArgs++discardingTestArgs :: PropertyTest prop -> PropertyTest (TestArgs -> prop)+discardingTestArgs test@PropertyTest {property} = test {property = const property}++-- | Get a Cabal 'T.Test' from a 'PropertyTest' that takes the test arguments and returns a 'QC.Testable' value+getPropertyTestUsing ::+ QC.Testable prop =>+ -- | A property test whose 'property' takes a 'TestArgs' argument+ PropertyTest (TestArgs -> prop) ->+ T.Test+getPropertyTestUsing = getPropertyTestWithUsing stdTestArgs++-- | Get a Cabal 'T.Test' from a 'PropertyTest' with custom 'TestArgs'+getPropertyTestWith ::+ QC.Testable prop =>+ -- | The arguments for the test+ TestArgs ->+ PropertyTest prop ->+ T.Test+getPropertyTestWith args = getPropertyTestWithUsing args . discardingTestArgs++-- | Get a Cabal 'T.Test' from a 'PropertyTest'+getPropertyTest :: QC.Testable prop => PropertyTest prop -> T.Test+getPropertyTest = getPropertyTestWithUsing stdTestArgs . discardingTestArgs