diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,12 @@ +# Changelog + +All notable changes to this project will be documented in this file. + +The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.1.0/), +and this project adheres to the [Haskell Package Versioning Policy](https://pvp.haskell.org/). + +## [Unreleased] + +### Added + +- Initial release. diff --git a/LICENCE b/LICENCE new file mode 100644 --- /dev/null +++ b/LICENCE @@ -0,0 +1,287 @@ + EUROPEAN UNION PUBLIC LICENCE v. 1.2 + EUPL © the European Union 2007, 2016 + +This European Union Public Licence (the ‘EUPL’) applies to the Work (as defined +below) which is provided under the terms of this Licence. Any use of the Work, +other than as authorised under this Licence is prohibited (to the extent such +use is covered by a right of the copyright holder of the Work). + +The Work is provided under the terms of this Licence when the Licensor (as +defined below) has placed the following notice immediately following the +copyright notice for the Work: + + Licensed under the EUPL + +or has expressed by any other means his willingness to license under the EUPL. + +1. Definitions + +In this Licence, the following terms have the following meaning: + +- ‘The Licence’: this Licence. + +- ‘The Original Work’: the work or software distributed or communicated by the + Licensor under this Licence, available as Source Code and also as Executable + Code as the case may be. + +- ‘Derivative Works’: the works or software that could be created by the + Licensee, based upon the Original Work or modifications thereof. This Licence + does not define the extent of modification or dependence on the Original Work + required in order to classify a work as a Derivative Work; this extent is + determined by copyright law applicable in the country mentioned in Article 15. + +- ‘The Work’: the Original Work or its Derivative Works. + +- ‘The Source Code’: the human-readable form of the Work which is the most + convenient for people to study and modify. + +- ‘The Executable Code’: any code which has generally been compiled and which is + meant to be interpreted by a computer as a program. + +- ‘The Licensor’: the natural or legal person that distributes or communicates + the Work under the Licence. + +- ‘Contributor(s)’: any natural or legal person who modifies the Work under the + Licence, or otherwise contributes to the creation of a Derivative Work. + +- ‘The Licensee’ or ‘You’: any natural or legal person who makes any usage of + the Work under the terms of the Licence. + +- ‘Distribution’ or ‘Communication’: any act of selling, giving, lending, + renting, distributing, communicating, transmitting, or otherwise making + available, online or offline, copies of the Work or providing access to its + essential functionalities at the disposal of any other natural or legal + person. + +2. Scope of the rights granted by the Licence + +The Licensor hereby grants You a worldwide, royalty-free, non-exclusive, +sublicensable licence to do the following, for the duration of copyright vested +in the Original Work: + +- use the Work in any circumstance and for all usage, +- reproduce the Work, +- modify the Work, and make Derivative Works based upon the Work, +- communicate to the public, including the right to make available or display + the Work or copies thereof to the public and perform publicly, as the case may + be, the Work, +- distribute the Work or copies thereof, +- lend and rent the Work or copies thereof, +- sublicense rights in the Work or copies thereof. + +Those rights can be exercised on any media, supports and formats, whether now +known or later invented, as far as the applicable law permits so. + +In the countries where moral rights apply, the Licensor waives his right to +exercise his moral right to the extent allowed by law in order to make effective +the licence of the economic rights here above listed. + +The Licensor grants to the Licensee royalty-free, non-exclusive usage rights to +any patents held by the Licensor, to the extent necessary to make use of the +rights granted on the Work under this Licence. + +3. Communication of the Source Code + +The Licensor may provide the Work either in its Source Code form, or as +Executable Code. If the Work is provided as Executable Code, the Licensor +provides in addition a machine-readable copy of the Source Code of the Work +along with each copy of the Work that the Licensor distributes or indicates, in +a notice following the copyright notice attached to the Work, a repository where +the Source Code is easily and freely accessible for as long as the Licensor +continues to distribute or communicate the Work. + +4. Limitations on copyright + +Nothing in this Licence is intended to deprive the Licensee of the benefits from +any exception or limitation to the exclusive rights of the rights owners in the +Work, of the exhaustion of those rights or of other applicable limitations +thereto. + +5. Obligations of the Licensee + +The grant of the rights mentioned above is subject to some restrictions and +obligations imposed on the Licensee. Those obligations are the following: + +Attribution right: The Licensee shall keep intact all copyright, patent or +trademarks notices and all notices that refer to the Licence and to the +disclaimer of warranties. The Licensee must include a copy of such notices and a +copy of the Licence with every copy of the Work he/she distributes or +communicates. The Licensee must cause any Derivative Work to carry prominent +notices stating that the Work has been modified and the date of modification. + +Copyleft clause: If the Licensee distributes or communicates copies of the +Original Works or Derivative Works, this Distribution or Communication will be +done under the terms of this Licence or of a later version of this Licence +unless the Original Work is expressly distributed only under this version of the +Licence — for example by communicating ‘EUPL v. 1.2 only’. The Licensee +(becoming Licensor) cannot offer or impose any additional terms or conditions on +the Work or Derivative Work that alter or restrict the terms of the Licence. + +Compatibility clause: If the Licensee Distributes or Communicates Derivative +Works or copies thereof based upon both the Work and another work licensed under +a Compatible Licence, this Distribution or Communication can be done under the +terms of this Compatible Licence. For the sake of this clause, ‘Compatible +Licence’ refers to the licences listed in the appendix attached to this Licence. +Should the Licensee's obligations under the Compatible Licence conflict with +his/her obligations under this Licence, the obligations of the Compatible +Licence shall prevail. + +Provision of Source Code: When distributing or communicating copies of the Work, +the Licensee will provide a machine-readable copy of the Source Code or indicate +a repository where this Source will be easily and freely available for as long +as the Licensee continues to distribute or communicate the Work. + +Legal Protection: This Licence does not grant permission to use the trade names, +trademarks, service marks, or names of the Licensor, except as required for +reasonable and customary use in describing the origin of the Work and +reproducing the content of the copyright notice. + +6. Chain of Authorship + +The original Licensor warrants that the copyright in the Original Work granted +hereunder is owned by him/her or licensed to him/her and that he/she has the +power and authority to grant the Licence. + +Each Contributor warrants that the copyright in the modifications he/she brings +to the Work are owned by him/her or licensed to him/her and that he/she has the +power and authority to grant the Licence. + +Each time You accept the Licence, the original Licensor and subsequent +Contributors grant You a licence to their contributions to the Work, under the +terms of this Licence. + +7. Disclaimer of Warranty + +The Work is a work in progress, which is continuously improved by numerous +Contributors. It is not a finished work and may therefore contain defects or +‘bugs’ inherent to this type of development. + +For the above reason, the Work is provided under the Licence on an ‘as is’ basis +and without warranties of any kind concerning the Work, including without +limitation merchantability, fitness for a particular purpose, absence of defects +or errors, accuracy, non-infringement of intellectual property rights other than +copyright as stated in Article 6 of this Licence. + +This disclaimer of warranty is an essential part of the Licence and a condition +for the grant of any rights to the Work. + +8. Disclaimer of Liability + +Except in the cases of wilful misconduct or damages directly caused to natural +persons, the Licensor will in no event be liable for any direct or indirect, +material or moral, damages of any kind, arising out of the Licence or of the use +of the Work, including without limitation, damages for loss of goodwill, work +stoppage, computer failure or malfunction, loss of data or any commercial +damage, even if the Licensor has been advised of the possibility of such damage. +However, the Licensor will be liable under statutory product liability laws as +far such laws apply to the Work. + +9. Additional agreements + +While distributing the Work, You may choose to conclude an additional agreement, +defining obligations or services consistent with this Licence. However, if +accepting obligations, You may act only on your own behalf and on your sole +responsibility, not on behalf of the original Licensor or any other Contributor, +and only if You agree to indemnify, defend, and hold each Contributor harmless +for any liability incurred by, or claims asserted against such Contributor by +the fact You have accepted any warranty or additional liability. + +10. Acceptance of the Licence + +The provisions of this Licence can be accepted by clicking on an icon ‘I agree’ +placed under the bottom of a window displaying the text of this Licence or by +affirming consent in any other similar way, in accordance with the rules of +applicable law. Clicking on that icon indicates your clear and irrevocable +acceptance of this Licence and all of its terms and conditions. + +Similarly, you irrevocably accept this Licence and all of its terms and +conditions by exercising any rights granted to You by Article 2 of this Licence, +such as the use of the Work, the creation by You of a Derivative Work or the +Distribution or Communication by You of the Work or copies thereof. + +11. Information to the public + +In case of any Distribution or Communication of the Work by means of electronic +communication by You (for example, by offering to download the Work from a +remote location) the distribution channel or media (for example, a website) must +at least provide to the public the information requested by the applicable law +regarding the Licensor, the Licence and the way it may be accessible, concluded, +stored and reproduced by the Licensee. + +12. Termination of the Licence + +The Licence and the rights granted hereunder will terminate automatically upon +any breach by the Licensee of the terms of the Licence. + +Such a termination will not terminate the licences of any person who has +received the Work from the Licensee under the Licence, provided such persons +remain in full compliance with the Licence. + +13. Miscellaneous + +Without prejudice of Article 9 above, the Licence represents the complete +agreement between the Parties as to the Work. + +If any provision of the Licence is invalid or unenforceable under applicable +law, this will not affect the validity or enforceability of the Licence as a +whole. Such provision will be construed or reformed so as necessary to make it +valid and enforceable. + +The European Commission may publish other linguistic versions or new versions of +this Licence or updated versions of the Appendix, so far this is required and +reasonable, without reducing the scope of the rights granted by the Licence. New +versions of the Licence will be published with a unique version number. + +All linguistic versions of this Licence, approved by the European Commission, +have identical value. Parties can take advantage of the linguistic version of +their choice. + +14. Jurisdiction + +Without prejudice to specific agreement between parties, + +- any litigation resulting from the interpretation of this License, arising + between the European Union institutions, bodies, offices or agencies, as a + Licensor, and any Licensee, will be subject to the jurisdiction of the Court + of Justice of the European Union, as laid down in article 272 of the Treaty on + the Functioning of the European Union, + +- any litigation arising between other parties and resulting from the + interpretation of this License, will be subject to the exclusive jurisdiction + of the competent court where the Licensor resides or conducts its primary + business. + +15. Applicable Law + +Without prejudice to specific agreement between parties, + +- this Licence shall be governed by the law of the European Union Member State + where the Licensor has his seat, resides or has his registered office, + +- this licence shall be governed by Belgian law if the Licensor has no seat, + residence or registered office inside a European Union Member State. + +Appendix + +‘Compatible Licences’ according to Article 5 EUPL are: + +- GNU General Public License (GPL) v. 2, v. 3 +- GNU Affero General Public License (AGPL) v. 3 +- Open Software License (OSL) v. 2.1, v. 3.0 +- Eclipse Public License (EPL) v. 1.0 +- CeCILL v. 2.0, v. 2.1 +- Mozilla Public Licence (MPL) v. 2 +- GNU Lesser General Public Licence (LGPL) v. 2.1, v. 3 +- Creative Commons Attribution-ShareAlike v. 3.0 Unported (CC BY-SA 3.0) for + works other than software +- European Union Public Licence (EUPL) v. 1.1, v. 1.2 +- Québec Free and Open-Source Licence — Reciprocity (LiLiQ-R) or Strong + Reciprocity (LiLiQ-R+). + +The European Commission may update this Appendix to later versions of the above +licences without producing a new version of the EUPL, as long as they provide +the rights granted in Article 2 of this Licence and protect the covered Source +Code from exclusive appropriation. + +All other changes or additions to this Appendix require the production of a new +EUPL version. 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/quickcheck-effectful.cabal b/quickcheck-effectful.cabal new file mode 100644 --- /dev/null +++ b/quickcheck-effectful.cabal @@ -0,0 +1,89 @@ +cabal-version: 3.0 +name: quickcheck-effectful +version: 1.0.0 +synopsis: Effectful bindings for the QuickCheck library +description: + Adaptation of the @@ library for the @@ ecosystem. + +homepage: https://digital-autonomy.institute +license: EUPL-1.2 +license-file: LICENCE +author: IDA +maintainer: IDA +bug-reports: https://issues.digital-autonomy.institute +category: Test +build-type: Simple +extra-doc-files: + CHANGELOG.md + +common common + default-language: Haskell2010 + ghc-options: + -Weverything + -Wno-unsafe + -Wno-missing-safe-haskell-mode + -Wno-missing-export-lists + -Wno-missing-import-lists + -Wno-missing-kind-signatures + -Wno-all-missed-specialisations + -Wno-missing-role-annotations + -Wno-x-unstable-interface + + default-extensions: + ApplicativeDo + BangPatterns + BlockArguments + DataKinds + DefaultSignatures + DeriveAnyClass + DeriveGeneric + DerivingStrategies + DerivingVia + ExistentialQuantification + ExplicitNamespaces + FlexibleContexts + FlexibleInstances + FunctionalDependencies + GeneralizedNewtypeDeriving + ImportQualifiedPost + ImpredicativeTypes + LambdaCase + MultiParamTypeClasses + NamedFieldPuns + NoImplicitPrelude + NumericUnderscores + OverloadedLabels + OverloadedRecordDot + OverloadedStrings + QuasiQuotes + RankNTypes + RecordWildCards + RecursiveDo + ScopedTypeVariables + TypeApplications + TypeFamilies + TypeOperators + ViewPatterns + + build-depends: + base >=4.10 && <5, + effectful >=2.6 && <2.7, + +library + import: common + hs-source-dirs: src + exposed-modules: + Effectful.QuickCheck + + build-depends: + QuickCheck >=2.15 && <3, + deepseq >=1.1 && <2, + +test-suite test + import: common + type: exitcode-stdio-1.0 + ghc-options: -threaded + hs-source-dirs: test + main-is: Main.hs + build-depends: + quickcheck-effectful diff --git a/src/Effectful/QuickCheck.hs b/src/Effectful/QuickCheck.hs new file mode 100644 --- /dev/null +++ b/src/Effectful/QuickCheck.hs @@ -0,0 +1,642 @@ +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE Trustworthy #-} +{-# OPTIONS_GHC -Wno-deprecations #-} + +-- | +-- Module : Effectful.QuickCheck +-- Copyright : (c) 2026 Institute for Digital Autonomy +-- License : EUPL-1.2 +-- Maintainer : IDA +-- +-- Effectful bindings for the . +-- +-- This library provides lifted 'Testable' and 'Property' types that allow running tests with +-- arbitrary effect stacks. +module Effectful.QuickCheck + ( -- * Running tests + quickCheck + , Args (..) + , Result (..) + , stdArgs + , quickCheckWith + , quickCheckWithResult + , quickCheckResult + , recheck + , isSuccess + + -- ** Running tests verbosely + , verboseCheck + , verboseCheckWith + , verboseCheckWithResult + , verboseCheckResult + + -- * The 'Arbitrary' typeclass: generation of random values + , Arbitrary (..) + + -- ** Helper functions for implementing 'shrink' + , genericShrink + , subterms + , recursivelyShrink + , shrinkNothing + , shrinkList + , shrinkMap + , shrinkMapBy + , shrinkIntegral + , shrinkRealFrac + , shrinkBoundedEnum + , shrinkDecimal + + -- ** Lifting of 'Arbitrary' to unary and binary type constructors + , Arbitrary1 (..) + , arbitrary1 + , shrink1 + , Arbitrary2 (..) + , arbitrary2 + , shrink2 + + -- * The 'Gen' monad: combinators for building random generators + , Gen + + -- ** Generator combinators + , choose + , chooseInt + , chooseInteger + , chooseBoundedIntegral + , chooseEnum + , chooseAny + , oneof + , frequency + , elements + , growingElements + , sized + , getSize + , resize + , scale + , suchThat + , suchThatMap + , suchThatMaybe + , applyArbitrary2 + , applyArbitrary3 + , applyArbitrary4 + + -- ** Generators for lists + , listOf + , listOf1 + , vectorOf + , vector + , infiniteListOf + , infiniteList + , shuffle + , sublistOf + , orderedList + + -- ** Generators for particular types + , arbitrarySizedIntegral + , arbitrarySizedNatural + , arbitrarySizedFractional + , arbitrarySizedBoundedIntegral + , arbitraryBoundedIntegral + , arbitraryBoundedRandom + , arbitraryBoundedEnum + , arbitraryUnicodeChar + , arbitraryASCIIChar + , arbitraryPrintableChar + + -- ** Running generators + , generate + + -- ** Debugging generators + , sample + , sample' + + -- * The 'Function' typeclass: generation of random shrinkable, showable functions + + -- | Example of use: + -- + -- >>> :{ + -- >>> let prop :: Fun String Integer -> Bool + -- >>> prop (Fun _ f) = f "monkey" == f "banana" || f "banana" == f "elephant" + -- >>> :} + -- >>> quickCheck prop + -- *** Failed! Falsified (after 3 tests and 134 shrinks): + -- {"elephant"->1, "monkey"->1, _->0} + -- + -- To generate random values of type @'Fun' a b@, + -- you must have an instance @'Function' a@. + -- If your type has a 'Show' instance, you can use 'functionShow' to write the instance; otherwise, + -- use 'functionMap' to give a bijection between your type and a type that is already an instance of 'Function'. + -- See the @'Function' [a]@ instance for an example of the latter. + -- + -- For more information, see the paper \"Shrinking and showing functions\" by Koen Claessen. + , Fun (..) + , applyFun + , applyFun2 + , applyFun3 + , pattern Fn + , pattern Fn2 + , pattern Fn3 + , Function (..) + , functionMap + , functionShow + , functionIntegral + , functionRealFrac + , functionBoundedEnum + , functionVoid + + -- * The 'CoArbitrary' typeclass: generation of functions the old-fashioned way + , CoArbitrary (..) + , genericCoarbitrary + , variant + , coarbitraryIntegral + , coarbitraryReal + , coarbitraryShow + , coarbitraryEnum + , (><) + + -- * Type-level modifiers for changing generator behavior + + -- | These types do things such as restricting the kind of test data that can be generated. + -- They can be pattern-matched on in properties as a stylistic + -- alternative to using explicit quantification. + -- + -- Examples: + -- + -- @ + -- -- Functions cannot be shown (but see 'Function') + -- prop_TakeDropWhile ('Blind' p) (xs :: ['A']) = + -- takeWhile p xs ++ dropWhile p xs == xs + -- @ + -- + -- @ + -- prop_TakeDrop ('NonNegative' n) (xs :: ['A']) = + -- take n xs ++ drop n xs == xs + -- @ + -- + -- @ + -- -- cycle does not work for empty lists + -- prop_Cycle ('NonNegative' n) ('NonEmpty' (xs :: ['A'])) = + -- take n (cycle xs) == take n (xs ++ cycle xs) + -- @ + -- + -- @ + -- -- Instead of 'forAll' 'orderedList' + -- prop_Sort ('Ordered' (xs :: ['OrdA'])) = + -- sort xs == xs + -- @ + , Blind (..) + , Fixed (..) + , OrderedList (..) + , NonEmptyList (..) + , InfiniteList (..) + , SortedList (..) + , Positive (..) + , Negative (..) + , NonZero (..) + , NonNegative (..) + , NonPositive (..) + , Large (..) + , Small (..) + , Smart (..) + , Shrink2 (..) + , Shrinking (..) + , ShrinkState (..) + , ASCIIString (..) + , UnicodeString (..) + , PrintableString (..) + + -- * Property combinators + , Property + , liftProperty + , unliftProperty + , Testable (..) + , forAll + , forAllShrink + , forAllShow + , forAllShrinkShow + , forAllBlind + , forAllShrinkBlind + , shrinking + , (==>) + , Discard (..) + , discard + , (===) + , (=/=) + , total + , effProperty + , idempotentEffProperty + + -- ** Controlling property execution + , verbose + , verboseShrinking + , noShrinking + , withMaxSuccess + , within + , discardAfter + , withDiscardRatio + , withMaxSize + , withMaxShrinks + , once + , again + , mapSize + + -- ** Conjunction and disjunction + , (.&.) + , (.&&.) + , conjoin + , (.||.) + , disjoin + + -- ** What to do on failure + , Witness (..) + , witness + , coerceWitness + , castWitness + , counterexample + , printTestCase + , whenFail + , whenFail' + , expectFailure + + -- * Analysing test case distribution + , label + , collect + , classify + , tabulate + + -- ** Checking test case distribution + , cover + , coverTable + , checkCoverage + , checkCoverageWith + , Confidence (..) + , stdConfidence + + -- ** Generating example test cases + , labelledExamples + , labelledExamplesWith + , labelledExamplesWithResult + , labelledExamplesResult + ) +where + +import Control.DeepSeq (NFData) +import Data.Functor (void) +import Data.Typeable (Typeable) +import Effectful +import Test.QuickCheck + ( Witness (..) + , castWitness + , coerceWitness + , discard + , stdConfidence + ) +import Test.QuickCheck qualified as QuickCheck +import Test.QuickCheck.Arbitrary +import Test.QuickCheck.Function +import Test.QuickCheck.Gen +import Test.QuickCheck.Gen.Unsafe (promote) +import Test.QuickCheck.Modifiers +import Test.QuickCheck.Property + ( Discard (..) + , Prop (..) + , ioRose + , liftBool + , protectProp + , protectResults + , rejected + , succeeded + ) +import Test.QuickCheck.Property qualified as Property +import Test.QuickCheck.Property qualified as QuickCheck +import Test.QuickCheck.State +import Test.QuickCheck.Test (Args (..), Result (..), isSuccess, stdArgs) +import Prelude + +-- | Lifted 'QuickCheck.Property'. +newtype Property (es :: [Effect]) = Property ((forall a. Eff es a -> IO a) -> QuickCheck.Property) + +liftProperty :: QuickCheck.Property -> Property es +liftProperty = Property . const + +unliftProperty :: (forall a. Eff es a -> IO a) -> Property es -> QuickCheck.Property +unliftProperty unlift (Property p) = p unlift + +mapProperty :: (QuickCheck.Property -> QuickCheck.Property) -> Property es -> Property es +mapProperty f (Property g) = Property $ f . g + +class Testable prop es where + property :: prop -> Property es + +instance (es ~ es') => Testable (Property es') es where + property = id + +instance Testable Discard es where + property Discard = property @_ @es rejected + +instance Testable () es where + property () = property @_ @es succeeded + +instance (Testable prop es) => Testable (Maybe prop) es where + property = maybe (property @_ @es Discard) property + +instance Testable Bool es where + property = property @_ @es . liftBool + +instance Testable Property.Result es where + property = liftProperty . QuickCheck.MkProperty . pure . MkProp . protectResults . pure + +instance Testable Prop es where + property = liftProperty . QuickCheck.MkProperty . pure . protectProp + +instance (Testable prop es) => Testable (Gen prop) es where + property mp = + Property \unlift -> + QuickCheck.MkProperty do + QuickCheck.unProperty . unliftProperty unlift . property =<< mp + +instance Testable QuickCheck.Property es where + property (QuickCheck.MkProperty mp) = + liftProperty . QuickCheck.MkProperty $ protectProp <$> mp + +instance (Arbitrary a, Show a, Testable prop es) => Testable (a -> prop) es where + property f = Property \unlift -> QuickCheck.property (unliftProperty unlift . property . f) + +instance (es ~ es', Testable a es) => Testable (Eff es' a) es where + property eff = + Property \unlift -> + QuickCheck.ioProperty $ + unliftProperty unlift . property <$> unlift eff + +-- | Lifted QuickCheck.ioProperty'. +effProperty :: (Testable prop es) => Eff es prop -> Property es +effProperty = idempotentEffProperty . fmap noShrinking + +-- | Lifted of 'QuickCheck.idempotentIOProperty'. +idempotentEffProperty :: (Testable prop es) => Eff es prop -> Property es +idempotentEffProperty eff = + Property \unlift -> + QuickCheck.MkProperty + . fmap (MkProp . ioRose . unlift . fmap unProp) + . promote + $ QuickCheck.unProperty . unliftProperty unlift . property <$> eff + +-- | Lifted 'QuickCheck.quickCheck'. +quickCheck :: (Testable prop es, IOE :> es) => prop -> Eff es () +quickCheck = quickCheckWith stdArgs + +-- | Lifted 'QuickCheck.quickCheckWith'. +quickCheckWith :: (Testable prop es, IOE :> es) => Args -> prop -> Eff es () +quickCheckWith = (void .) . quickCheckWithResult + +-- | Lifted 'QuickCheck.quickCheckResult'. +quickCheckResult :: (Testable prop es, IOE :> es) => prop -> Eff es Result +quickCheckResult = quickCheckWithResult stdArgs + +-- | Lifted 'QuickCheck.quickCheckWithResult'. +quickCheckWithResult :: (Testable prop es, IOE :> es) => Args -> prop -> Eff es Result +quickCheckWithResult args prop = + withEffToIO (ConcUnlift Ephemeral Unlimited) $ + QuickCheck.quickCheckWithResult args . flip unliftProperty (property prop) + +-- | Lifted 'QuickCheck.recheck'. +recheck :: (Testable prop es, IOE :> es) => Result -> prop -> Eff es () +recheck result prop = + withEffToIO (ConcUnlift Ephemeral Unlimited) $ + QuickCheck.recheck result . flip unliftProperty (property prop) + +-- | Lifted 'QuickCheck.verboseCheck'. +verboseCheck :: (Testable prop es, IOE :> es) => prop -> Eff es () +verboseCheck = quickCheck . verbose + +-- | Lifted 'QuickCheck.verboseCheckWith'. +verboseCheckWith :: (Testable prop es, IOE :> es) => Args -> prop -> Eff es () +verboseCheckWith args = quickCheckWith args . verbose + +-- | Lifted 'QuickCheck.verboseCheckResult'. +verboseCheckResult :: (Testable prop es, IOE :> es) => prop -> Eff es Result +verboseCheckResult = quickCheckResult . verbose + +-- | Lifted 'QuickCheck.verboseCheckWithResult'. +verboseCheckWithResult :: (Testable prop es, IOE :> es) => Args -> prop -> Eff es Result +verboseCheckWithResult args = quickCheckWithResult args . verbose + +-- | Lifted 'QuickCheck.noShrinking'. +noShrinking :: (Testable prop es) => prop -> Property es +noShrinking = mapProperty QuickCheck.noShrinking . property + +-- | Lifted 'QuickCheck.verbose'. +verbose :: (Testable prop es) => prop -> Property es +verbose = mapProperty QuickCheck.verbose . property + +-- | Lifted 'QuickCheck.verboseShrinking'. +verboseShrinking :: (Testable prop es) => prop -> Property es +verboseShrinking = mapProperty QuickCheck.verboseShrinking . property + +-- | Lifted 'QuickCheck.withMaxSuccess'. +withMaxSuccess :: (Testable prop es) => Int -> prop -> Property es +withMaxSuccess n = mapProperty (QuickCheck.withMaxSuccess n) . property + +-- | Lifted 'QuickCheck.withMaxSize'. +withMaxSize :: (Testable prop es) => Int -> prop -> Property es +withMaxSize n = mapProperty (QuickCheck.withMaxSize n) . property + +-- | Lifted 'QuickCheck.withMaxShrinks'. +withMaxShrinks :: (Testable prop es) => Int -> prop -> Property es +withMaxShrinks n = mapProperty (QuickCheck.withMaxShrinks n) . property + +-- | Lifted 'QuickCheck.withDiscardRatio'. +withDiscardRatio :: (Testable prop es) => Int -> prop -> Property es +withDiscardRatio n = mapProperty (QuickCheck.withDiscardRatio n) . property + +-- | Lifted 'QuickCheck.once'. +once :: (Testable prop es) => prop -> Property es +once = mapProperty QuickCheck.once . property + +-- | Lifted 'QuickCheck.again'. +again :: (Testable prop es) => prop -> Property es +again = mapProperty QuickCheck.again . property + +-- | Lifted 'QuickCheck.expectFailure'. +expectFailure :: (Testable prop es) => prop -> Property es +expectFailure = mapProperty QuickCheck.expectFailure . property + +-- | Lifted 'QuickCheck.within'. +within :: (Testable prop es) => Int -> prop -> Property es +within n = mapProperty (QuickCheck.within n) . property + +-- | Lifted 'QuickCheck.discardAfter'. +discardAfter :: (Testable prop es) => Int -> prop -> Property es +discardAfter n = mapProperty (QuickCheck.discardAfter n) . property + +-- | Lifted 'QuickCheck.checkCoverage'. +checkCoverage :: (Testable prop es) => prop -> Property es +checkCoverage = mapProperty QuickCheck.checkCoverage . property + +-- | Lifted 'QuickCheck.checkCoverageWith'. +checkCoverageWith :: (Testable prop es) => Confidence -> prop -> Property es +checkCoverageWith c = mapProperty (QuickCheck.checkCoverageWith c) . property + +-- | Lifted 'QuickCheck.mapSize'. +mapSize :: (Testable prop es) => (Int -> Int) -> prop -> Property es +mapSize f = mapProperty (QuickCheck.mapSize f) . property + +-- | Lifted 'QuickCheck.counterexample'. +counterexample :: (Testable prop es) => String -> prop -> Property es +counterexample s = mapProperty (QuickCheck.counterexample s) . property + +-- | Lifted 'QuickCheck.printTestCase'. +printTestCase :: (Testable prop es) => String -> prop -> Property es +printTestCase s = mapProperty (QuickCheck.printTestCase s) . property + +-- | Lifted 'QuickCheck.label'. +label :: (Testable prop es) => String -> prop -> Property es +label s = mapProperty (QuickCheck.label s) . property + +-- | Lifted 'QuickCheck.collect'. +collect :: (Show a, Testable prop es) => a -> prop -> Property es +collect x = mapProperty (QuickCheck.collect x) . property + +-- | Lifted 'QuickCheck.classify'. +classify :: (Testable prop es) => Bool -> String -> prop -> Property es +classify b s = mapProperty (QuickCheck.classify b s) . property + +-- | Lifted 'QuickCheck.tabulate'. +tabulate :: (Testable prop es) => String -> [String] -> prop -> Property es +tabulate key vals = mapProperty (QuickCheck.tabulate key vals) . property + +-- | Lifted 'QuickCheck.cover'. +cover :: (Testable prop es) => Double -> Bool -> String -> prop -> Property es +cover p b s = mapProperty (QuickCheck.cover p b s) . property + +-- | Lifted 'QuickCheck.coverTable'. +coverTable :: (Testable prop es) => String -> [(String, Double)] -> prop -> Property es +coverTable key tab = mapProperty (QuickCheck.coverTable key tab) . property + +-- | Lifted 'QuickCheck.witness'. +witness :: (Typeable a, Show a, Testable prop es) => a -> prop -> Property es +witness x = mapProperty (QuickCheck.witness x) . property + +-- | Lifted 'QuickCheck.total'. +total :: (NFData a) => a -> Property es +total = liftProperty . QuickCheck.total + +-- | Lifted 'QuickCheck.forAll'. +forAll :: (Show a, Testable prop es) => Gen a -> (a -> prop) -> Property es +forAll gen pf = + Property \unlift -> QuickCheck.forAll gen (unliftProperty unlift . property . pf) + +-- | Lifted 'QuickCheck.forAllShrink'. +forAllShrink :: (Show a, Testable prop es) => Gen a -> (a -> [a]) -> (a -> prop) -> Property es +forAllShrink gen shr pf = + Property \unlift -> QuickCheck.forAllShrink gen shr (unliftProperty unlift . property . pf) + +-- | Lifted 'QuickCheck.forAllShow'. +forAllShow :: (Testable prop es) => Gen a -> (a -> String) -> (a -> prop) -> Property es +forAllShow gen shower pf = + Property \unlift -> QuickCheck.forAllShow gen shower (unliftProperty unlift . property . pf) + +-- | Lifted 'QuickCheck.forAllShrinkShow'. +forAllShrinkShow + :: (Testable prop es) + => Gen a + -> (a -> [a]) + -> (a -> String) + -> (a -> prop) + -> Property es +forAllShrinkShow gen shr shower pf = + Property \unlift -> + QuickCheck.forAllShrinkShow gen shr shower (unliftProperty unlift . property . pf) + +-- | Lifted 'QuickCheck.forAllBlind'. +forAllBlind :: (Testable prop es) => Gen a -> (a -> prop) -> Property es +forAllBlind gen pf = + Property \unlift -> QuickCheck.forAllBlind gen (unliftProperty unlift . property . pf) + +-- | Lifted 'QuickCheck.forAllShrinkBlind'. +forAllShrinkBlind :: (Testable prop es) => Gen a -> (a -> [a]) -> (a -> prop) -> Property es +forAllShrinkBlind gen shr pf = + Property \unlift -> + QuickCheck.forAllShrinkBlind gen shr (unliftProperty unlift . property . pf) + +-- | Lifted 'QuickCheck.shrinking'. +shrinking :: (Testable prop es) => (a -> [a]) -> a -> (a -> prop) -> Property es +shrinking shr x pf = + Property \unlift -> QuickCheck.shrinking shr x (unliftProperty unlift . property . pf) + +-- | Lifted 'QuickCheck.==>'. +(==>) :: (Testable prop es) => Bool -> prop -> Property es +b ==> p = Property \unlift -> b QuickCheck.==> unliftProperty unlift (property p) + +infixr 0 ==> + +-- | Lifted 'QuickCheck.whenFail'. +whenFail :: (Testable prop es) => Eff es () -> prop -> Property es +whenFail m p = + Property \unlift -> QuickCheck.whenFail (unlift m) (unliftProperty unlift (property p)) + +-- | Lifted 'QuickCheck.whenFail\''. +whenFail' :: (Testable prop es) => Eff es () -> prop -> Property es +whenFail' m p = + Property \unlift -> QuickCheck.whenFail' (unlift m) (unliftProperty unlift (property p)) + +-- | Lifted 'QuickCheck..&.'. +(.&.) :: (Testable p1 es, Testable p2 es) => p1 -> p2 -> Property es +p1 .&. p2 = + Property \unlift -> + unliftProperty unlift (property p1) QuickCheck..&. unliftProperty unlift (property p2) + +infixr 1 .&. + +-- | Lifted 'QuickCheck..&&.'. +(.&&.) :: (Testable p1 es, Testable p2 es) => p1 -> p2 -> Property es +p1 .&&. p2 = + Property \unlift -> + unliftProperty unlift (property p1) QuickCheck..&&. unliftProperty unlift (property p2) + +infixr 1 .&&. + +-- | Lifted 'QuickCheck..||.'. +(.||.) :: (Testable p1 es, Testable p2 es) => p1 -> p2 -> Property es +p1 .||. p2 = + Property \unlift -> + unliftProperty unlift (property p1) QuickCheck..||. unliftProperty unlift (property p2) + +infixr 1 .||. + +-- | Lifted 'QuickCheck.==='. +(===) :: (Eq a, Show a) => a -> a -> Property es +x === y = liftProperty (x QuickCheck.=== y) + +infix 4 === + +-- | Lifted 'QuickCheck.=/='. +(=/=) :: (Eq a, Show a) => a -> a -> Property es +x =/= y = liftProperty (x QuickCheck.=/= y) + +infix 4 =/= + +-- | Lifted 'QuickCheck.conjoin'. +conjoin :: (Testable prop es) => [prop] -> Property es +conjoin ps = Property \unlift -> QuickCheck.conjoin $ unliftProperty unlift . property <$> ps + +-- | Lifted 'QuickCheck.disjoin'. +disjoin :: (Testable prop es) => [prop] -> Property es +disjoin ps = Property \unlift -> QuickCheck.disjoin $ unliftProperty unlift . property <$> ps + +-- | Lifted 'QuickCheck.labelledExamples'. +labelledExamples :: (Testable prop es, IOE :> es) => prop -> Eff es () +labelledExamples = labelledExamplesWith stdArgs + +-- | Lifted 'QuickCheck.labelledExamplesWith'. +labelledExamplesWith :: (Testable prop es, IOE :> es) => Args -> prop -> Eff es () +labelledExamplesWith = (void .) . labelledExamplesWithResult + +-- | Lifted 'QuickCheck.labelledExamplesResult'. +labelledExamplesResult :: (Testable prop es, IOE :> es) => prop -> Eff es Result +labelledExamplesResult = labelledExamplesWithResult stdArgs + +-- | Lifted 'QuickCheck.labelledExamplesWithResult'. +labelledExamplesWithResult :: (Testable prop es, IOE :> es) => Args -> prop -> Eff es Result +labelledExamplesWithResult args prop = + withEffToIO (ConcUnlift Ephemeral Unlimited) $ + QuickCheck.labelledExamplesWithResult args . flip unliftProperty (property prop) diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,52 @@ +{- HLINT ignore "Redundant reverse" -} +module Main where + +import Effectful +import Effectful.Error.Static (runError, throwError) +import Effectful.Prim (Prim, runPrim) +import Effectful.Prim.IORef (modifyIORef', newIORef, readIORef) +import Effectful.QuickCheck +import Effectful.Reader.Static (Reader, ask, runReader) +import Prelude + +prop_reverse :: [Int] -> Bool +prop_reverse xs = (reverse . reverse) xs == xs + +prop_readerScaling :: (Reader Int :> es) => Int -> Eff es Bool +prop_readerScaling x = do + factor <- ask + pure (x * factor == factor * x) + +prop_errorRecovers :: Int -> Eff es (Property es) +prop_errorRecovers n = do + result <- runError @String (if odd n then throwError ("odd" :: String) else pure n) + pure $ either (const $ property (odd n)) (=== n) result + +prop_iorefAccumulates :: (Prim :> es) => [Int] -> Eff es (Property es) +prop_iorefAccumulates xs = do + ref <- newIORef (0 :: Int) + mapM_ (\x -> modifyIORef' ref (+ x)) xs + acc <- readIORef ref + pure $ counterexample ("running total was " <> show acc) (acc === sum xs) + +main :: IO () +main = runEff . runPrim . runReader (7 :: Int) $ do + -- Pure props + quickCheck prop_reverse + quickCheck $ withMaxSuccess 10_000 prop_reverse + + -- Effectful props + quickCheck prop_readerScaling + quickCheck prop_errorRecovers + quickCheck prop_iorefAccumulates + + -- Composition + quickCheck $ withMaxSuccess 500 prop_readerScaling + quickCheck $ prop_readerScaling .&&. prop_iorefAccumulates + quickCheck $ prop_reverse .||. prop_readerScaling + quickCheck . forAll (chooseInt (0, 100)) $ \x -> + counterexample ("x = " <> show x) (prop_readerScaling x) + quickCheck $ \x -> x > 0 ==> prop_readerScaling x + quickCheck $ classify True "always" . label "reader" $ prop_readerScaling + quickCheck . conjoin $ [prop_readerScaling, prop_readerScaling] + quickCheck $ once (prop_reverse [])