diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,8 @@ +# 0.0.0.0 + +- Provides support for testing instances of classes defined in the following + modules: + - `Data.Monoid.GCD` + - `Data.Monoid.Monus` + - `Data.Monoid.Null` + - `Data.Semigroup.Cancellative` diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,201 @@ + Apache License + Version 2.0, January 2004 + http://www.apache.org/licenses/ + + TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION + + 1. Definitions. + + "License" shall mean the terms and conditions for use, reproduction, + and distribution as defined by Sections 1 through 9 of this document. + + "Licensor" shall mean the copyright owner or entity authorized by + the copyright owner that is granting the License. + + "Legal Entity" shall mean the union of the acting entity and all + other entities that control, are controlled by, or are under common + control with that entity. For the purposes of this definition, + "control" means (i) the power, direct or indirect, to cause the + direction or management of such entity, whether by contract or + otherwise, or (ii) ownership of fifty percent (50%) or more of the + outstanding shares, or (iii) beneficial ownership of such entity. + + "You" (or "Your") shall mean an individual or Legal Entity + exercising permissions granted by this License. + + "Source" form shall mean the preferred form for making modifications, + including but not limited to software source code, documentation + source, and configuration files. + + "Object" form shall mean any form resulting from mechanical + transformation or translation of a Source form, including but + not limited to compiled object code, generated documentation, + and conversions to other media types. + + "Work" shall mean the work of authorship, whether in Source or + Object form, made available under the License, as indicated by a + copyright notice that is included in or attached to the work + (an example is provided in the Appendix below). + + "Derivative Works" shall mean any work, whether in Source or Object + form, that is based on (or derived from) the Work and for which the + editorial revisions, annotations, elaborations, or other modifications + represent, as a whole, an original work of authorship. For the purposes + of this License, Derivative Works shall not include works that remain + separable from, or merely link (or bind by name) to the interfaces of, + the Work and Derivative Works thereof. + + "Contribution" shall mean any work of authorship, including + the original version of the Work and any modifications or additions + to that Work or Derivative Works thereof, that is intentionally + submitted to Licensor for inclusion in the Work by the copyright owner + or by an individual or Legal Entity authorized to submit on behalf of + the copyright owner. For the purposes of this definition, "submitted" + means any form of electronic, verbal, or written communication sent + to the Licensor or its representatives, including but not limited to + communication on electronic mailing lists, source code control systems, + and issue tracking systems that are managed by, or on behalf of, the + Licensor for the purpose of discussing and improving the Work, but + excluding communication that is conspicuously marked or otherwise + designated in writing by the copyright owner as "Not a Contribution." + + "Contributor" shall mean Licensor and any individual or Legal Entity + on behalf of whom a Contribution has been received by Licensor and + subsequently incorporated within the Work. + + 2. Grant of Copyright License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + copyright license to reproduce, prepare Derivative Works of, + publicly display, publicly perform, sublicense, and distribute the + Work and such Derivative Works in Source or Object form. + + 3. Grant of Patent License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + (except as stated in this section) patent license to make, have made, + use, offer to sell, sell, import, and otherwise transfer the Work, + where such license applies only to those patent claims licensable + by such Contributor that are necessarily infringed by their + Contribution(s) alone or by combination of their Contribution(s) + with the Work to which such Contribution(s) was submitted. If You + institute patent litigation against any entity (including a + cross-claim or counterclaim in a lawsuit) alleging that the Work + or a Contribution incorporated within the Work constitutes direct + or contributory patent infringement, then any patent licenses + granted to You under this License for that Work shall terminate + as of the date such litigation is filed. + + 4. Redistribution. You may reproduce and distribute copies of the + Work or Derivative Works thereof in any medium, with or without + modifications, and in Source or Object form, provided that You + meet the following conditions: + + (a) You must give any other recipients of the Work or + Derivative Works a copy of this License; and + + (b) You must cause any modified files to carry prominent notices + stating that You changed the files; and + + (c) You must retain, in the Source form of any Derivative Works + that You distribute, all copyright, patent, trademark, and + attribution notices from the Source form of the Work, + excluding those notices that do not pertain to any part of + the Derivative Works; and + + (d) If the Work includes a "NOTICE" text file as part of its + distribution, then any Derivative Works that You distribute must + include a readable copy of the attribution notices contained + within such NOTICE file, excluding those notices that do not + pertain to any part of the Derivative Works, in at least one + of the following places: within a NOTICE text file distributed + as part of the Derivative Works; within the Source form or + documentation, if provided along with the Derivative Works; or, + within a display generated by the Derivative Works, if and + wherever such third-party notices normally appear. The contents + of the NOTICE file are for informational purposes only and + do not modify the License. You may add Your own attribution + notices within Derivative Works that You distribute, alongside + or as an addendum to the NOTICE text from the Work, provided + that such additional attribution notices cannot be construed + as modifying the License. + + You may add Your own copyright statement to Your modifications and + may provide additional or different license terms and conditions + for use, reproduction, or distribution of Your modifications, or + for any such Derivative Works as a whole, provided Your use, + reproduction, and distribution of the Work otherwise complies with + the conditions stated in this License. + + 5. Submission of Contributions. Unless You explicitly state otherwise, + any Contribution intentionally submitted for inclusion in the Work + by You to the Licensor shall be under the terms and conditions of + this License, without any additional terms or conditions. + Notwithstanding the above, nothing herein shall supersede or modify + the terms of any separate license agreement you may have executed + with Licensor regarding such Contributions. + + 6. Trademarks. This License does not grant permission to use the trade + names, trademarks, service marks, or product 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 NOTICE file. + + 7. Disclaimer of Warranty. Unless required by applicable law or + agreed to in writing, Licensor provides the Work (and each + Contributor provides its Contributions) on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or + implied, including, without limitation, any warranties or conditions + of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A + PARTICULAR PURPOSE. You are solely responsible for determining the + appropriateness of using or redistributing the Work and assume any + risks associated with Your exercise of permissions under this License. + + 8. Limitation of Liability. In no event and under no legal theory, + whether in tort (including negligence), contract, or otherwise, + unless required by applicable law (such as deliberate and grossly + negligent acts) or agreed to in writing, shall any Contributor be + liable to You for damages, including any direct, indirect, special, + incidental, or consequential damages of any character arising as a + result of this License or out of the use or inability to use the + Work (including but not limited to damages for loss of goodwill, + work stoppage, computer failure or malfunction, or any and all + other commercial damages or losses), even if such Contributor + has been advised of the possibility of such damages. + + 9. Accepting Warranty or Additional Liability. While redistributing + the Work or Derivative Works thereof, You may choose to offer, + and charge a fee for, acceptance of support, warranty, indemnity, + or other liability obligations and/or rights consistent with this + License. However, in accepting such obligations, You may act only + on Your own behalf and on Your sole responsibility, not on behalf + of 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 reason + of your accepting any such warranty or additional liability. + + END OF TERMS AND CONDITIONS + + APPENDIX: How to apply the Apache License to your work. + + To apply the Apache License to your work, attach the following + boilerplate notice, with the fields enclosed by brackets "[]" + replaced with your own identifying information. (Don't include + the brackets!) The text should be enclosed in the appropriate + comment syntax for the file format. We also recommend that a + file or class name and description of purpose be included on the + same "printed page" as the copyright notice for easier + identification within third-party archives. + + Copyright © 2022 Jonathan Knowles + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,108 @@ +# `quickcheck-monoid-subclasses` + + + +## Overview + +The `quickcheck-monoid-subclasses` library provides: +- [QuickCheck](https://hackage.haskell.org/package/QuickCheck) support for testing instances of type classes defined in the [`monoid-subclasses`](https://hackage.haskell.org/package/monoid-subclasses) library. +- Compatibility with the [`quickcheck-classes`](https://hackage.haskell.org/package/quickcheck-classes) library. +- Reusable properties for type class laws, in the form of [`Laws`](https://hackage.haskell.org/package/quickcheck-classes/docs/Test-QuickCheck-Classes.html#t:Laws) definitions. + +## Usage + +In general, usage is identical to that of the [`quickcheck-classes`](https://hackage.haskell.org/package/quickcheck-classes) library. If you're already familiar with [`quickcheck-classes`](https://hackage.haskell.org/package/quickcheck-classes), then using this library should be straightforward. + +### Testing laws for a single type class + +To test that the laws of a particular class hold for a particular type, use the [`lawsCheck`](https://hackage.haskell.org/package/quickcheck-classes/docs/Test-QuickCheck-Classes.html#t:lawsCheck) function with the [`Laws`](https://hackage.haskell.org/package/quickcheck-classes/docs/Test-QuickCheck-Classes.html#t:Laws) definition for the class you wish to test. + +> #### :stars: Example +> +> To test that the [`Monus`](https://hackage.haskell.org/package/monoid-subclasses/docs/Data-Monoid-Monus.html#t:Monus) laws hold for the [`Sum`](https://hackage.haskell.org/package/base/docs/Data-Monoid.html#t:Sum) [`Natural`](https://hackage.haskell.org/package/base/docs/Numeric-Natural.html#t:Natural) type: +> +> ```hs +> import Data.Monoid (Sum) +> import Data.Proxy (Proxy (Proxy)) +> import Numeric.Natural (Natural) +> import Test.QuickCheck.Classes (lawsCheck) +> import Test.QuickCheck.Classes.Monoid.Monus (monusLaws) +> +> lawsCheck (monusLaws (Proxy :: Proxy (Sum Natural))) +> ``` +> +> If all tests pass, you should see output similar to: +> +> ```hs +> Monus: axiom1 +++ OK, passed 100 tests. +> Monus: axiom2 +++ OK, passed 100 tests. +> Monus: axiom3 +++ OK, passed 100 tests. +> Monus: axiom4 +++ OK, passed 100 tests. +> Monus: stripPrefixOverlap +++ OK, passed 100 tests. +> Monus: stripSuffixOverlap +++ OK, passed 100 tests. +> ``` + +### Testing laws for multiple type classes + +To test that the laws of __multiple__ classes hold for a particular type, use the [`lawsCheckOne`](https://hackage.haskell.org/package/quickcheck-classes/docs/Test-QuickCheck-Classes.html#t:lawsCheckOne) function with the [`Laws`](https://hackage.haskell.org/package/quickcheck-classes/docs/Test-QuickCheck-Classes.html#t:Laws) definitions for the classes you wish to test. + +> #### :stars: Example +> +> To test that the [`Sum`](https://hackage.haskell.org/package/base/docs/Data-Monoid.html#t:Sum) [`Natural`](https://hackage.haskell.org/package/base/docs/Numeric-Natural.html#t:Natural) type satisfies the laws of [`Semigroup`](https://hackage.haskell.org/package/base/docs/Data-Semigroup.html#t:Semigroup) and its subclasses: +> +> ```hs +> import Data.Monoid (Sum) +> import Data.Proxy (Proxy (Proxy)) +> import Numeric.Natural (Natural) +> import Test.QuickCheck.Classes +> import Test.QuickCheck.Classes.Monoid.GCD +> import Test.QuickCheck.Classes.Monoid.Monus +> import Test.QuickCheck.Classes.Monoid.Null +> import Test.QuickCheck.Classes.Semigroup.Cancellative +> +> lawsCheckOne (Proxy :: Proxy (Sum Natural)) +> [ cancellativeGCDMonoidLaws +> , cancellativeLaws +> , commutativeLaws +> , gcdMonoidLaws +> , leftCancellativeLaws +> , leftGCDMonoidLaws +> , leftReductiveLaws +> , monoidLaws +> , monoidNullLaws +> , monusLaws +> , overlappingGCDMonoidLaws +> , positiveMonoidLaws +> , reductiveLaws +> , rightCancellativeLaws +> , rightGCDMonoidLaws +> , rightReductiveLaws +> , semigroupLaws +> ] +> ``` + +## Subclasses and superclasses + +Each of the [`Laws`](https://hackage.haskell.org/package/quickcheck-classes/docs/Test-QuickCheck-Classes.html#t:Laws) definitions provided by this library corresponds to exactly __one__ type class, and includes __just__ the laws for that class. Laws for subclasses and superclasses are __not__ automatically included. Therefore, you'll need to __explicitly__ test the laws of every single class you wish to cover. + +## Coverage checks + +This library includes __coverage checks__ to ensure that important cases are covered, and to reduce the probability of test passes that are false positives. These coverage checks are performed automatically. + +To increase coverage of interesting and important cases, this library also checks that laws hold for __combinations__ of generated arbitrary values. + +> #### :stars: Example +> +> Suppose we are testing the following law: +> +> ```hs +> isPrefixOf a b == isJust (stripPrefix a b) +> ``` +> +> This library will also test that the following __derived__ laws hold: +> +> ```hs +> isPrefixOf a (a <> a) == isJust (stripPrefix a (a <> a)) +> isPrefixOf a (a <> b) == isJust (stripPrefix a (a <> b)) +> isPrefixOf a (b <> a) == isJust (stripPrefix a (b <> a)) +> ``` diff --git a/quickcheck-monoid-subclasses.cabal b/quickcheck-monoid-subclasses.cabal new file mode 100644 --- /dev/null +++ b/quickcheck-monoid-subclasses.cabal @@ -0,0 +1,151 @@ +cabal-version: 3.0 +name: quickcheck-monoid-subclasses +version: 0.0.0.0 +bug-reports: https://github.com/jonathanknowles/quickcheck-monoid-subclasses/issues +license: Apache-2.0 +license-file: LICENSE +author: Jonathan Knowles +maintainer: mail@jonathanknowles.net +copyright: 2022 Jonathan Knowles +category: Testing +synopsis: Testing monoid subclass instances with QuickCheck +description: + + QuickCheck support for testing instances of type classes defined in the + monoid-subclasses library. + +extra-doc-files: + CHANGELOG.md + README.md + +common dependency-base + build-depends:base >= 4.14.3.0 && < 4.18 +common dependency-bytestring + build-depends:bytestring >= 0.10.12.0 && < 0.12 +common dependency-commutative-semigroups + build-depends:commutative-semigroups >= 0.1.0.0 && < 0.2 +common dependency-containers + build-depends:containers >= 0.6.5.1 && < 0.7 +common dependency-hspec + build-depends:hspec >= 2.10.7 && < 2.11 +common dependency-monoid-subclasses + build-depends:monoid-subclasses >= 1.2.1 && < 1.3 +common dependency-pretty-show + build-depends:pretty-show >= 1.10 && < 1.11 +common dependency-QuickCheck + build-depends:QuickCheck >= 2.14.2 && < 2.15 +common dependency-quickcheck-classes + build-depends:quickcheck-classes >= 0.6.5.0 && < 0.7 +common dependency-quickcheck-instances + build-depends:quickcheck-instances >= 0.3.28 && < 0.4 +common dependency-semigroupoids + build-depends:semigroupoids >= 5.3.7 && < 5.4 +common dependency-text + build-depends:text >= 1.2.4.1 && < 2.1 +common dependency-vector + build-depends:vector >= 0.13.0.0 && < 0.14 + +common extensions + default-extensions: + ConstraintKinds + DataKinds + DerivingStrategies + FlexibleContexts + FlexibleInstances + GeneralizedNewtypeDeriving + LambdaCase + PolyKinds + ScopedTypeVariables + TypeApplications + ViewPatterns + +source-repository head + type: git + location: https://github.com/jonathanknowles/quickcheck-monoid-subclasses + +library + import: + , dependency-base + , dependency-monoid-subclasses + , dependency-QuickCheck + , dependency-quickcheck-classes + , extensions + build-depends: + , internal + default-language: + Haskell2010 + hs-source-dirs: + src/public + exposed-modules: + Test.QuickCheck.Classes.Monoid.GCD + Test.QuickCheck.Classes.Monoid.Monus + Test.QuickCheck.Classes.Monoid.Null + Test.QuickCheck.Classes.Semigroup.Cancellative + +library internal + import: + , dependency-base + , dependency-pretty-show + , dependency-QuickCheck + , dependency-semigroupoids + , extensions + default-language: + Haskell2010 + hs-source-dirs: + src/internal + exposed-modules: + Internal + Internal.Semigroup.Eq + Internal.Semigroup.Tuple + +library prelude + import: + , dependency-base + , dependency-containers + , dependency-monoid-subclasses + , dependency-QuickCheck + , dependency-quickcheck-classes + , dependency-quickcheck-instances + , extensions + build-depends: + , internal + , quickcheck-monoid-subclasses + default-language: + Haskell2010 + hs-source-dirs: + src/prelude + exposed-modules: + Internal.Prelude + +test-suite test + import: + , dependency-base + , dependency-bytestring + , dependency-commutative-semigroups + , dependency-containers + , dependency-hspec + , dependency-monoid-subclasses + , dependency-QuickCheck + , dependency-quickcheck-classes + , dependency-quickcheck-instances + , dependency-text + , dependency-vector + , extensions + build-depends: + , quickcheck-monoid-subclasses + default-language: + Haskell2010 + ghc-options: + -threaded -with-rtsopts=-N + main-is: + Spec.hs + hs-source-dirs: + src/test + other-modules: + ClassSpec + SpecHook + Test.Hspec.Laws + type: + exitcode-stdio-1.0 + build-tool-depends: + hspec-discover:hspec-discover == 2.* diff --git a/src/internal/Internal.hs b/src/internal/Internal.hs new file mode 100644 --- /dev/null +++ b/src/internal/Internal.hs @@ -0,0 +1,136 @@ +-- | +-- Copyright: © 2022 Jonathan Knowles +-- License: Apache-2.0 +-- +module Internal + ( cover + , makeLaw0 + , makeLaw1 + , makeLaw2 + , makeLaw3 + , makeProperty + , report + , (==>) + ) + where + +import Data.Function + ( (&) ) +import Data.Proxy + ( Proxy (..) ) +import Internal.Semigroup.Eq + ( allNonNull, allUnique, allUniqueNonNull ) +import Internal.Semigroup.Tuple + ( Tuple1, Tuple2, Tuple3, evalTuple1, evalTuple2, evalTuple3 ) +import Test.QuickCheck + ( Arbitrary (..) + , Property + , Testable + , checkCoverage + , counterexample + , property + ) + +import qualified Test.QuickCheck as QC + +infixr 0 ==> +(==>) :: Bool -> Bool -> Bool +a ==> b = not a || b + +cover :: Testable t => String -> Bool -> t -> Property +cover name = flip (QC.cover 0.1) (replaceSpecialChars <$> name) + +makeLaw :: Testable t => String -> t -> (String, Property) +makeLaw title t = (title, checkCoverage $ property t) + +makeLaw0 + :: String + -> (Proxy a -> Property) + -> (String, Property) +makeLaw0 s = makeLaw s . makeProperty0 + +makeLaw1 + :: (Arbitrary a, Show a, Eq a, Semigroup a, Testable t) + => String + -> (a -> t) + -> (String, Property) +makeLaw1 s = makeLaw s . makeProperty1 + +makeLaw2 + :: (Arbitrary a, Show a, Eq a, Semigroup a, Testable t) + => String + -> (a -> a -> t) + -> (String, Property) +makeLaw2 s = makeLaw s . makeProperty2 + +makeLaw3 + :: (Arbitrary a, Show a, Eq a, Semigroup a, Testable t) + => String + -> (a -> a -> a -> t) + -> (String, Property) +makeLaw3 s = makeLaw s . makeProperty3 + +makeProperty :: Testable t => String -> t -> Property +makeProperty propertyDescription t = + property t & counterexample counterexampleText + where + counterexampleText = unlines + [ "Property not satisfied:" + , propertyDescription + & fmap replaceSpecialChars + ] + where + +makeProperty0 + :: forall a t. Testable t + => (Proxy a -> t) + -> Property +makeProperty0 p = property $ p $ Proxy @a + +makeProperty1 + :: (Eq a, Semigroup a, Testable t) + => (a -> t) + -> (Tuple1 a -> Property) +makeProperty1 p (evalTuple1 -> a) + = property $ p a + +makeProperty2 + :: (Eq a, Semigroup a, Testable t) + => (a -> a -> t) + -> (Tuple2 a -> Property) +makeProperty2 p (evalTuple2 -> (a, b)) + = cover + "allUnique [a, b]" + (allUnique [a, b]) + $ cover + "allNonNull [a, b]" + (allNonNull [a, b]) + $ cover + "allUniqueNonNull [a, b]" + (allUniqueNonNull [a, b]) + $ property $ p a b + +makeProperty3 + :: (Eq a, Semigroup a, Testable t) + => (a -> a -> a -> t) + -> (Tuple3 a -> Property) +makeProperty3 p (evalTuple3 -> (a, b, c)) + = cover + "allUnique [a, b, c]" + (allUnique [a, b, c]) + $ cover + "allNonNull [a, b, c]" + (allNonNull [a, b, c]) + $ cover + "allUniqueNonNull [a, b, c]" + (allUniqueNonNull [a, b, c]) + $ property $ p a b c + +report :: (Show a, Testable prop) => String -> a -> prop -> Property +report name a = counterexample $ + (replaceSpecialChars <$> name) <> ":\n" <> show a <> "\n" + +replaceSpecialChars :: Char -> Char +replaceSpecialChars = \case + 'λ' -> '\\' + other -> other diff --git a/src/internal/Internal/Semigroup/Eq.hs b/src/internal/Internal/Semigroup/Eq.hs new file mode 100644 --- /dev/null +++ b/src/internal/Internal/Semigroup/Eq.hs @@ -0,0 +1,40 @@ +-- | +-- Copyright: © 2022 Jonathan Knowles +-- License: Apache-2.0 +-- +module Internal.Semigroup.Eq + ( allNonNull + , allUnique + , allUniqueNonNull + ) + where + +import Data.List + ( nub ) + +import Data.Foldable as F + +allNonNull :: (Eq a, Semigroup a, Foldable f) => f a -> Bool +allNonNull as = F.all (as `canVerifyNonNull`) as + +allUnique :: (Eq a, Foldable f) => f a -> Bool +allUnique as = length (nub xs) == length xs + where + xs = F.toList as + +allUniqueNonNull :: (Eq a, Foldable f, Semigroup a) => f a -> Bool +allUniqueNonNull as = allUnique as && allNonNull as + +canModify :: (Eq a, Semigroup a) => a -> a -> Bool +a `canModify` b = (||) + (a `canModifyL` b) + (a `canModifyR` b) + +canModifyL :: (Eq a, Semigroup a) => a -> a -> Bool +a `canModifyL` b = b /= a <> b + +canModifyR :: (Eq a, Semigroup a) => a -> a -> Bool +a `canModifyR` b = b /= b <> a + +canVerifyNonNull :: (Eq a, Semigroup a, Foldable f) => f a -> a -> Bool +canVerifyNonNull as a = F.any (a `canModify`) as diff --git a/src/internal/Internal/Semigroup/Tuple.hs b/src/internal/Internal/Semigroup/Tuple.hs new file mode 100644 --- /dev/null +++ b/src/internal/Internal/Semigroup/Tuple.hs @@ -0,0 +1,175 @@ +{- HLINT ignore "Redundant bracket" -} + +-- | +-- Copyright: © 2022 Jonathan Knowles +-- License: Apache-2.0 +-- +module Internal.Semigroup.Tuple + where + +import Data.List.NonEmpty + ( NonEmpty (..) ) +import Test.QuickCheck + ( Arbitrary (..), Gen, choose, shuffle, suchThatMap ) +import Text.Show.Pretty + ( ppShow ) + +import qualified Data.Foldable as F +import qualified Data.List.NonEmpty as NE +import qualified Data.Semigroup.Foldable as F1 + +-------------------------------------------------------------------------------- +-- Tuple selectors +-------------------------------------------------------------------------------- + +data TupleLens3 + = TupleLens3A + | TupleLens3B + | TupleLens3C + deriving (Bounded, Enum, Eq, Ord, Show) + +evalTupleLens3 :: (s, s, s) -> TupleLens3 -> s +evalTupleLens3 (a, b, c) = \case + TupleLens3A -> a + TupleLens3B -> b + TupleLens3C -> c + +-------------------------------------------------------------------------------- +-- Semigroup combinations +-------------------------------------------------------------------------------- + +newtype Combination3 = Combination3 (NonEmpty TupleLens3) + deriving (Eq, Ord, Show) + +arbitraryCombination3 :: Gen Combination3 +arbitraryCombination3 = + Combination3 <$> arbitraryTupleLensList `suchThatMap` NE.nonEmpty + where + arbitraryTupleLensList :: Gen [TupleLens3] + arbitraryTupleLensList = do + itemCount <- choose (1, 3) + take itemCount <$> shuffle universe + +evalCombination3 :: (s, s, s) -> Combination3 -> NonEmpty s +evalCombination3 tuple (Combination3 selectors) = + evalTupleLens3 tuple <$> selectors + +showCombination3 :: Show s => (s, s, s) -> Combination3 -> String +showCombination3 tuple = + F1.intercalateMap1 " <> " show . evalCombination3 tuple + +-------------------------------------------------------------------------------- +-- Semigroup tuples +-------------------------------------------------------------------------------- + +data Tuple1 s = Tuple1 Combination3 (s, s, s) + deriving (Eq, Ord) + +data Tuple2 s = Tuple2 Combination3 Combination3 (s, s, s) + deriving (Eq, Ord) + +data Tuple3 s = Tuple3 Combination3 Combination3 Combination3 (s, s, s) + deriving (Eq, Ord) + +instance Arbitrary a => Arbitrary (Tuple1 a) where + arbitrary = arbitraryTuple1 + shrink = shrinkTuple1 + +instance Arbitrary a => Arbitrary (Tuple2 a) where + arbitrary = arbitraryTuple2 + shrink = shrinkTuple2 + +instance Arbitrary a => Arbitrary (Tuple3 a) where + arbitrary = arbitraryTuple3 + shrink = shrinkTuple3 + +instance (Show s, Semigroup s) => Show (Tuple1 s) where + show = showTuple1 + +instance (Show s, Semigroup s) => Show (Tuple2 s) where + show = showTuple2 + +instance (Show s, Semigroup s) => Show (Tuple3 s) where + show = showTuple3 + +arbitraryTuple1 :: Arbitrary a => Gen (Tuple1 a) +arbitraryTuple1 = Tuple1 + <$> arbitraryCombination3 + <*> arbitrary + +arbitraryTuple2 :: Arbitrary a => Gen (Tuple2 a) +arbitraryTuple2 = Tuple2 + <$> arbitraryCombination3 + <*> arbitraryCombination3 + <*> arbitrary + +arbitraryTuple3 :: Arbitrary a => Gen (Tuple3 a) +arbitraryTuple3 = Tuple3 + <$> arbitraryCombination3 + <*> arbitraryCombination3 + <*> arbitraryCombination3 + <*> arbitrary + +evalTuple1 :: Semigroup s => Tuple1 s -> s +evalTuple1 (Tuple1 c1 t) = + ( F1.fold1 $ evalCombination3 t c1 + ) + +evalTuple2 :: Semigroup s => Tuple2 s -> (s, s) +evalTuple2 (Tuple2 c1 c2 t) = + ( F1.fold1 $ evalCombination3 t c1 + , F1.fold1 $ evalCombination3 t c2 + ) + +evalTuple3 :: Semigroup s => Tuple3 s -> (s, s, s) +evalTuple3 (Tuple3 c1 c2 c3 t) = + ( F1.fold1 $ evalCombination3 t c1 + , F1.fold1 $ evalCombination3 t c2 + , F1.fold1 $ evalCombination3 t c3 + ) + +showTuple1 :: (Semigroup a, Show a) => Tuple1 a -> String +showTuple1 (evalTuple1 -> a) = unlines + [ mempty, "a:", showWrap a + ] + +showTuple2 :: (Semigroup a, Show a) => Tuple2 a -> String +showTuple2 (evalTuple2 -> (a, b)) = unlines + [ mempty, "a:", showWrap a + , mempty, "b:", showWrap b + ] + +showTuple3 :: (Semigroup a, Show a) => Tuple3 a -> String +showTuple3 (evalTuple3 -> (a, b, c)) = unlines + [ mempty, "a:", showWrap a + , mempty, "b:", showWrap b + , mempty, "c:", showWrap c + ] + +shrinkTuple1 :: Arbitrary a => Tuple1 a -> [Tuple1 a] +shrinkTuple1 (Tuple1 c1 t) = Tuple1 c1 <$> shrink t + +shrinkTuple2 :: Arbitrary a => Tuple2 a -> [Tuple2 a] +shrinkTuple2 (Tuple2 c1 c2 t) = Tuple2 c1 c2 <$> shrink t + +shrinkTuple3 :: Arbitrary a => Tuple3 a -> [Tuple3 a] +shrinkTuple3 (Tuple3 c1 c2 c3 t) = Tuple3 c1 c2 c3 <$> shrink t + +-------------------------------------------------------------------------------- +-- Utilities +-------------------------------------------------------------------------------- + +showWrap :: Show a => a -> String +showWrap x + | singleLineMaxLengthExceeded = + multiLine + | otherwise = + singleLine + where + multiLine = ppShow x + singleLine = show x + singleLineMaxLength = 80 + singleLineMaxLengthExceeded = F.length singleLine > singleLineMaxLength + +universe :: (Bounded a, Enum a) => [a] +universe = [minBound .. maxBound] diff --git a/src/prelude/Internal/Prelude.hs b/src/prelude/Internal/Prelude.hs new file mode 100644 --- /dev/null +++ b/src/prelude/Internal/Prelude.hs @@ -0,0 +1,30 @@ +-- | +-- Copyright: © 2022 Jonathan Knowles +-- License: Apache-2.0 +-- +module Internal.Prelude + ( module Data.Monoid + , module Data.Monoid.Cancellative + , module Data.Monoid.GCD + , module Data.Monoid.Monus + , module Data.Monoid.Null + , module Data.Semigroup.Cancellative + , module Internal.Semigroup.Eq + , module Internal.Semigroup.Tuple + , module Numeric.Natural + , module Test.QuickCheck + ) + where + +import Data.Monoid +import Data.Monoid.Cancellative +import Data.Monoid.GCD +import Data.Monoid.Monus +import Data.Monoid.Null +import Data.Semigroup.Cancellative +import Internal.Semigroup.Eq +import Internal.Semigroup.Tuple +import Numeric.Natural +import Test.QuickCheck +import Test.QuickCheck.Instances.Natural + () diff --git a/src/public/Test/QuickCheck/Classes/Monoid/GCD.hs b/src/public/Test/QuickCheck/Classes/Monoid/GCD.hs new file mode 100644 --- /dev/null +++ b/src/public/Test/QuickCheck/Classes/Monoid/GCD.hs @@ -0,0 +1,666 @@ +{- HLINT ignore "Use camelCase" -} +{- HLINT ignore "Redundant bracket" -} + +-- | +-- Copyright: © 2022 Jonathan Knowles +-- License: Apache-2.0 +-- +-- This module provides 'Laws' definitions for classes exported by +-- "Data.Monoid.GCD". +-- +module Test.QuickCheck.Classes.Monoid.GCD + ( gcdMonoidLaws + , cancellativeGCDMonoidLaws + , leftGCDMonoidLaws + , rightGCDMonoidLaws + , overlappingGCDMonoidLaws + ) + where + +import Prelude hiding + ( gcd ) + +import Data.Function + ( (&) ) +import Data.Maybe + ( isJust ) +import Data.Monoid.GCD + ( GCDMonoid (..) + , LeftGCDMonoid (..) + , OverlappingGCDMonoid (..) + , RightGCDMonoid (..) + ) +import Data.Proxy + ( Proxy (..) ) +import Data.Semigroup.Cancellative + ( Cancellative, LeftReductive (..), Reductive (..), RightReductive (..) ) +import Internal + ( cover, makeLaw2, makeLaw3, makeProperty, report ) +import Test.QuickCheck + ( Arbitrary (..), Property ) +import Test.QuickCheck.Classes + ( Laws (..) ) + +-------------------------------------------------------------------------------- +-- CancellativeGCDMonoid +-------------------------------------------------------------------------------- + +-- | 'Laws' for instances of 'Cancellative' and 'GCDMonoid'. +-- +-- Tests the following laws: +-- +-- @ +-- 'gcd' (a '<>' b) (a '<>' c) '==' a '<>' 'gcd' b c +-- @ +-- +-- @ +-- 'gcd' (a '<>' c) (b '<>' c) '==' 'gcd' a b '<>' c +-- @ +-- +-- Note that the following superclass laws are __not__ included: +-- +-- * 'Test.QuickCheck.Classes.Semigroup.Cancellative.cancellativeLaws' +-- * 'Test.QuickCheck.Classes.Monoid.GCD.gcdMonoidLaws' +-- +cancellativeGCDMonoidLaws + :: forall a. (Arbitrary a, Show a, Eq a, Cancellative a, GCDMonoid a) + => Proxy a + -> Laws +cancellativeGCDMonoidLaws _ = Laws "CancellativeGCDMonoid" + [ makeLaw3 @a + "cancellativeGCDMonoidLaw_prefix" + (cancellativeGCDMonoidLaw_prefix) + , makeLaw3 @a + "cancellativeGCDMonoidLaw_suffix" + (cancellativeGCDMonoidLaw_suffix) + ] + +cancellativeGCDMonoidLaw_prefix + :: (Eq a, Show a, Cancellative a, GCDMonoid a) => a -> a -> a -> Property +cancellativeGCDMonoidLaw_prefix a b c = + makeProperty + "gcd (a <> b) (a <> c) == a <> gcd b c" + (gcd (a <> b) (a <> c) == a <> gcd b c) + & report + "a <> b" + (a <> b) + & report + "a <> c" + (a <> c) + & report + "gcd (a <> b) (a <> c)" + (gcd (a <> b) (a <> c)) + & report + "gcd b c" + (gcd b c) + & report + "a <> gcd b c" + (a <> gcd b c) + & cover + "a /= mempty && gcd b c /= mempty && a /= gcd b c" + (a /= mempty && gcd b c /= mempty && a /= gcd b c) + +cancellativeGCDMonoidLaw_suffix + :: (Eq a, Show a, Cancellative a, GCDMonoid a) => a -> a -> a -> Property +cancellativeGCDMonoidLaw_suffix a b c = + makeProperty + "gcd (a <> c) (b <> c) == gcd a b <> c" + (gcd (a <> c) (b <> c) == gcd a b <> c) + & report + "a <> c" + (a <> c) + & report + "b <> c" + (b <> c) + & report + "gcd (a <> c) (b <> c)" + (gcd (a <> c) (b <> c)) + & report + "gcd a b" + (gcd a b) + & report + "gcd a b <> c" + (gcd a b <> c) + & cover + "c /= mempty && gcd a b /= mempty && c /= gcd a b" + (c /= mempty && gcd a b /= mempty && c /= gcd a b) + +-------------------------------------------------------------------------------- +-- GCDMonoid +-------------------------------------------------------------------------------- + +-- | 'Laws' for instances of 'GCDMonoid'. +-- +-- Tests the following laws: +-- +-- @ +-- 'gcd' a b '==' 'commonPrefix' a b +-- @ +-- +-- @ +-- 'gcd' a b '==' 'commonSuffix' a b +-- @ +-- +-- @ +-- 'isJust' (a '' 'gcd' a b) +-- @ +-- +-- @ +-- 'isJust' (b '' 'gcd' a b) +-- @ +-- +-- Note that the following superclass laws are __not__ included: +-- +-- * 'Test.QuickCheck.Classes.monoidLaws' +-- * 'Test.QuickCheck.Classes.Semigroup.Cancellative.commutativeLaws' +-- * 'Test.QuickCheck.Classes.Semigroup.Cancellative.reductiveLaws' +-- * 'Test.QuickCheck.Classes.Monoid.GCD.leftGCDMonoidLaws' +-- * 'Test.QuickCheck.Classes.Monoid.GCD.rightGCDMonoidLaws' +-- * 'Test.QuickCheck.Classes.Monoid.GCD.overlappingGCDMonoidLaws' +-- +gcdMonoidLaws + :: forall a. (Arbitrary a, Show a, Eq a, GCDMonoid a) + => Proxy a + -> Laws +gcdMonoidLaws _ = Laws "GCDMonoid" + [ makeLaw2 @a + "gcdMonoidLaw_gcd_commonPrefix" + (gcdMonoidLaw_gcd_commonPrefix) + , makeLaw2 @a + "gcdMonoidLaw_gcd_commonSuffix" + (gcdMonoidLaw_gcd_commonSuffix) + , makeLaw2 @a + "gcdMonoidLaw_gcd_reduction_1" + (gcdMonoidLaw_gcd_reduction_1) + , makeLaw2 @a + "gcdMonoidLaw_gcd_reduction_2" + (gcdMonoidLaw_gcd_reduction_2) + ] + +gcdMonoidLaw_gcd_commonPrefix + :: (Eq a, Show a, GCDMonoid a) => a -> a -> Property +gcdMonoidLaw_gcd_commonPrefix a b = + makeProperty + "gcd a b == commonPrefix a b" + (gcd a b == commonPrefix a b) + & cover + "gcd a b /= mempty" + (gcd a b /= mempty) + & cover + "commonPrefix a b /= mempty" + (commonPrefix a b /= mempty) + & report + "gcd a b" + (gcd a b) + & report + "commonPrefix a b" + (commonPrefix a b) + +gcdMonoidLaw_gcd_commonSuffix + :: (Eq a, Show a, GCDMonoid a) => a -> a -> Property +gcdMonoidLaw_gcd_commonSuffix a b = + makeProperty + "gcd a b == commonSuffix a b" + (gcd a b == commonSuffix a b) + & cover + "gcd a b /= mempty" + (gcd a b /= mempty) + & cover + "commonSuffix a b /= mempty" + (commonSuffix a b /= mempty) + & report + "gcd a b" + (gcd a b) + & report + "commonSuffix a b" + (commonSuffix a b) + +gcdMonoidLaw_gcd_reduction_1 + :: (Eq a, Show a, GCDMonoid a) => a -> a -> Property +gcdMonoidLaw_gcd_reduction_1 a b = + makeProperty + "isJust (a gcd a b)" + (isJust (a gcd a b)) + & cover + "gcd a b /= mempty" + (gcd a b /= mempty) + & cover + "(a gcd a b) /= mempty" + ((a gcd a b) /= mempty) + & report + "gcd a b" + (gcd a b) + & report + "a gcd a b" + (a gcd a b) + +gcdMonoidLaw_gcd_reduction_2 + :: (Eq a, Show a, GCDMonoid a) => a -> a -> Property +gcdMonoidLaw_gcd_reduction_2 a b = + makeProperty + "isJust (b gcd a b)" + (isJust (b gcd a b)) + & cover + "gcd a b /= mempty" + (gcd a b /= mempty) + & cover + "(b gcd a b) /= mempty" + ((b gcd a b) /= mempty) + & report + "gcd a b" + (gcd a b) + & report + "b gcd a b" + (b gcd a b) + +-------------------------------------------------------------------------------- +-- LeftGCDMonoid +-------------------------------------------------------------------------------- + +-- | 'Laws' for instances of 'LeftGCDMonoid'. +-- +-- Tests the following laws: +-- +-- @ +-- 'stripCommonPrefix' a b '&' \\(p, _, _) -> p '==' 'commonPrefix' a b +-- @ +-- +-- @ +-- 'stripCommonPrefix' a b '&' \\(p, x, _) -> p '<>' x '==' a +-- @ +-- +-- @ +-- 'stripCommonPrefix' a b '&' \\(p, _, x) -> p '<>' x '==' b +-- @ +-- +-- @ +-- 'stripCommonPrefix' a b '&' \\(p, x, _) -> 'Just' x '==' 'stripPrefix' p a +-- @ +-- +-- @ +-- 'stripCommonPrefix' a b '&' \\(p, _, x) -> 'Just' x '==' 'stripPrefix' p b +-- @ +-- +-- Note that the following superclass laws are __not__ included: +-- +-- * 'Test.QuickCheck.Classes.monoidLaws' +-- * 'Test.QuickCheck.Classes.Semigroup.Cancellative.leftReductiveLaws' +-- +leftGCDMonoidLaws + :: forall a. (Arbitrary a, Show a, Eq a, LeftGCDMonoid a) + => Proxy a + -> Laws +leftGCDMonoidLaws _ = Laws "LeftGCDMonoid" + [ makeLaw2 @a + "leftGCDMonoidLaw_stripCommonPrefix_commonPrefix" + (leftGCDMonoidLaw_stripCommonPrefix_commonPrefix) + , makeLaw2 @a + "leftGCDMonoidLaw_stripCommonPrefix_mappend_1" + (leftGCDMonoidLaw_stripCommonPrefix_mappend_1) + , makeLaw2 @a + "leftGCDMonoidLaw_stripCommonPrefix_mappend_2" + (leftGCDMonoidLaw_stripCommonPrefix_mappend_2) + , makeLaw2 @a + "leftGCDMonoidLaw_stripCommonPrefix_stripPrefix_1" + (leftGCDMonoidLaw_stripCommonPrefix_stripPrefix_1) + , makeLaw2 @a + "leftGCDMonoidLaw_stripCommonPrefix_stripPrefix_2" + (leftGCDMonoidLaw_stripCommonPrefix_stripPrefix_2) + ] + +leftGCDMonoidLaw_stripCommonPrefix_commonPrefix + :: (Eq a, Show a, LeftGCDMonoid a) => a -> a -> Property +leftGCDMonoidLaw_stripCommonPrefix_commonPrefix a b = + makeProperty + "stripCommonPrefix a b & λ(p, _, _) -> p == commonPrefix a b" + (stripCommonPrefix a b & \(p, _, _) -> p == commonPrefix a b) + & cover + "commonPrefix a b /= mempty" + (commonPrefix a b /= mempty) + & report + "stripCommonPrefix a b" + (stripCommonPrefix a b) + & report + "commonPrefix a b" + (commonPrefix a b) + +leftGCDMonoidLaw_stripCommonPrefix_mappend_1 + :: (Eq a, Show a, LeftGCDMonoid a) => a -> a -> Property +leftGCDMonoidLaw_stripCommonPrefix_mappend_1 a b = + makeProperty + "stripCommonPrefix a b & λ(p, x, _) -> p <> x == a" + (stripCommonPrefix a b & \(p, x, _) -> p <> x == a) + & cover + "stripCommonPrefix a b & λ(p, x, _) -> p /= mempty && x /= mempty" + (stripCommonPrefix a b & \(p, x, _) -> p /= mempty && x /= mempty) + & report + "stripCommonPrefix a b" + (stripCommonPrefix a b) + & report + "stripCommonPrefix a b & λ(p, x, _) -> p <> x" + (stripCommonPrefix a b & \(p, x, _) -> p <> x) + +leftGCDMonoidLaw_stripCommonPrefix_mappend_2 + :: (Eq a, Show a, LeftGCDMonoid a) => a -> a -> Property +leftGCDMonoidLaw_stripCommonPrefix_mappend_2 a b = + makeProperty + "stripCommonPrefix a b & λ(p, _, x) -> p <> x == b" + (stripCommonPrefix a b & \(p, _, x) -> p <> x == b) + & cover + "stripCommonPrefix a b & λ(p, _, x) -> p /= mempty && x /= mempty" + (stripCommonPrefix a b & \(p, _, x) -> p /= mempty && x /= mempty) + & report + "stripCommonPrefix a b" + (stripCommonPrefix a b) + & report + "stripCommonPrefix a b & λ(p, _, x) -> p <> x" + (stripCommonPrefix a b & \(p, _, x) -> p <> x) + +leftGCDMonoidLaw_stripCommonPrefix_stripPrefix_1 + :: (Eq a, Show a, LeftGCDMonoid a) => a -> a -> Property +leftGCDMonoidLaw_stripCommonPrefix_stripPrefix_1 a b = + makeProperty + "stripCommonPrefix a b & λ(p, x, _) -> Just x == stripPrefix p a" + (stripCommonPrefix a b & \(p, x, _) -> Just x == stripPrefix p a) + & cover + "stripCommonPrefix a b & λ(p, x, _) -> p /= mempty && x /= mempty" + (stripCommonPrefix a b & \(p, x, _) -> p /= mempty && x /= mempty) + & report + "stripCommonPrefix a b" + (stripCommonPrefix a b) + & report + "stripCommonPrefix a b & λ(p, _, _) -> stripPrefix p a" + (stripCommonPrefix a b & \(p, _, _) -> stripPrefix p a) + +leftGCDMonoidLaw_stripCommonPrefix_stripPrefix_2 + :: (Eq a, Show a, LeftGCDMonoid a) => a -> a -> Property +leftGCDMonoidLaw_stripCommonPrefix_stripPrefix_2 a b = + makeProperty + "stripCommonPrefix a b & λ(p, _, x) -> Just x == stripPrefix p b" + (stripCommonPrefix a b & \(p, _, x) -> Just x == stripPrefix p b) + & cover + "stripCommonPrefix a b & λ(p, _, x) -> p /= mempty && x /= mempty" + (stripCommonPrefix a b & \(p, _, x) -> p /= mempty && x /= mempty) + & report + "stripCommonPrefix a b" + (stripCommonPrefix a b) + & report + "stripCommonPrefix a b & λ(p, _, _) -> stripPrefix p b" + (stripCommonPrefix a b & \(p, _, _) -> stripPrefix p b) + +-------------------------------------------------------------------------------- +-- OverlappingGCDMonoid +-------------------------------------------------------------------------------- + +-- | 'Laws' for instances of 'OverlappingGCDMonoid'. +-- +-- Tests the following laws: +-- +-- @ +-- 'overlap' a b '<>' 'stripPrefixOverlap' a b '==' b +-- @ +-- +-- @ +-- 'stripSuffixOverlap' b a '<>' 'overlap' a b '==' a +-- @ +-- +-- @ +-- 'stripOverlap' a b '&' \\(_, x, _) -> x '==' 'overlap' a b +-- @ +-- +-- @ +-- 'stripOverlap' a b '&' \\(_, _, x) -> x '==' 'stripPrefixOverlap' a b +-- @ +-- +-- @ +-- 'stripOverlap' a b '&' \\(x, _, _) -> x '==' 'stripSuffixOverlap' b a +-- @ +-- +-- Note that the following superclass laws are __not__ included: +-- +-- * 'Test.QuickCheck.Classes.monoidLaws' +-- * 'Test.QuickCheck.Classes.Semigroup.Cancellative.leftReductiveLaws' +-- * 'Test.QuickCheck.Classes.Semigroup.Cancellative.rightReductiveLaws' +-- +overlappingGCDMonoidLaws + :: forall a. (Arbitrary a, Show a, Eq a, OverlappingGCDMonoid a) + => Proxy a + -> Laws +overlappingGCDMonoidLaws _ = Laws "OverlappingGCDMonoid" + [ makeLaw2 @a + "overlappingGCDMonoidLaw_overlap_stripPrefixOverlap" + (overlappingGCDMonoidLaw_overlap_stripPrefixOverlap) + , makeLaw2 @a + "overlappingGCDMonoidLaw_overlap_stripSuffixOverlap" + (overlappingGCDMonoidLaw_overlap_stripSuffixOverlap) + , makeLaw2 @a + "overlappingGCDMonoidLaw_stripOverlap_overlap" + (overlappingGCDMonoidLaw_stripOverlap_overlap) + , makeLaw2 @a + "overlappingGCDMonoidLaw_stripOverlap_stripPrefixOverlap" + (overlappingGCDMonoidLaw_stripOverlap_stripPrefixOverlap) + , makeLaw2 @a + "overlappingGCDMonoidLaw_stripOverlap_stripSuffixOverlap" + (overlappingGCDMonoidLaw_stripOverlap_stripSuffixOverlap) + ] + +overlappingGCDMonoidLaw_overlap_stripPrefixOverlap + :: (Eq a, Show a, OverlappingGCDMonoid a) => a -> a -> Property +overlappingGCDMonoidLaw_overlap_stripPrefixOverlap a b = + makeProperty + "overlap a b <> stripPrefixOverlap a b == b" + (overlap a b <> stripPrefixOverlap a b == b) + & cover + "overlap a b /= mempty && stripPrefixOverlap a b /= mempty" + (overlap a b /= mempty && stripPrefixOverlap a b /= mempty) + & report + "overlap a b" + (overlap a b) + & report + "stripPrefixOverlap a b" + (stripPrefixOverlap a b) + & report + "overlap a b <> stripPrefixOverlap a b" + (overlap a b <> stripPrefixOverlap a b) + +overlappingGCDMonoidLaw_overlap_stripSuffixOverlap + :: (Eq a, Show a, OverlappingGCDMonoid a) => a -> a -> Property +overlappingGCDMonoidLaw_overlap_stripSuffixOverlap a b = + makeProperty + "stripSuffixOverlap b a <> overlap a b == a" + (stripSuffixOverlap b a <> overlap a b == a) + & cover + "stripSuffixOverlap b a /= mempty && overlap a b /= mempty" + (stripSuffixOverlap b a /= mempty && overlap a b /= mempty) + & report + "stripSuffixOverlap b a" + (stripSuffixOverlap b a) + & report + "overlap a b" + (overlap a b) + & report + "stripSuffixOverlap b a <> overlap a b" + (stripSuffixOverlap b a <> overlap a b) + +overlappingGCDMonoidLaw_stripOverlap_overlap + :: (Eq a, Show a, OverlappingGCDMonoid a) => a -> a -> Property +overlappingGCDMonoidLaw_stripOverlap_overlap a b = + makeProperty + "stripOverlap a b & λ(_, x, _) -> x == overlap a b" + (stripOverlap a b & \(_, x, _) -> x == overlap a b) + & cover + "overlap a b /= mempty" + (overlap a b /= mempty) + & report + "stripOverlap a b" + (stripOverlap a b) + & report + "overlap a b" + (overlap a b) + +overlappingGCDMonoidLaw_stripOverlap_stripPrefixOverlap + :: (Eq a, Show a, OverlappingGCDMonoid a) => a -> a -> Property +overlappingGCDMonoidLaw_stripOverlap_stripPrefixOverlap a b = + makeProperty + "stripOverlap a b & λ(_, _, x) -> x == stripPrefixOverlap a b" + (stripOverlap a b & \(_, _, x) -> x == stripPrefixOverlap a b) + & cover + "stripPrefixOverlap a b /= mempty" + (stripPrefixOverlap a b /= mempty) + & report + "stripOverlap a b" + (stripOverlap a b) + & report + "stripPrefixOverlap a b" + (stripPrefixOverlap a b) + +overlappingGCDMonoidLaw_stripOverlap_stripSuffixOverlap + :: (Eq a, Show a, OverlappingGCDMonoid a) => a -> a -> Property +overlappingGCDMonoidLaw_stripOverlap_stripSuffixOverlap a b = + makeProperty + "stripOverlap a b & λ(x, _, _) -> x == stripSuffixOverlap b a" + (stripOverlap a b & \(x, _, _) -> x == stripSuffixOverlap b a) + & cover + "stripSuffixOverlap b a /= mempty" + (stripSuffixOverlap b a /= mempty) + & report + "stripOverlap a b" + (stripOverlap a b) + & report + "stripSuffixOverlap b a" + (stripSuffixOverlap b a) + +-------------------------------------------------------------------------------- +-- RightGCDMonoid +-------------------------------------------------------------------------------- + +-- | 'Laws' for instances of 'RightGCDMonoid'. +-- +-- Tests the following laws: +-- +-- @ +-- 'stripCommonSuffix' a b '&' \\(_, _, s) -> s '==' 'commonSuffix' a b +-- @ +-- +-- @ +-- 'stripCommonSuffix' a b '&' \\(x, _, s) -> x '<>' s '==' a +-- @ +-- +-- @ +-- 'stripCommonSuffix' a b '&' \\(_, x, s) -> x '<>' s '==' b +-- @ +-- +-- @ +-- 'stripCommonSuffix' a b '&' \\(x, _, s) -> 'Just' x '==' 'stripSuffix' s a +-- @ +-- +-- @ +-- 'stripCommonSuffix' a b '&' \\(_, x, s) -> 'Just' x '==' 'stripSuffix' s b +-- @ +-- +-- Note that the following superclass laws are __not__ included: +-- +-- * 'Test.QuickCheck.Classes.monoidLaws' +-- * 'Test.QuickCheck.Classes.Semigroup.Cancellative.rightReductiveLaws' +-- +rightGCDMonoidLaws + :: forall a. (Arbitrary a, Show a, Eq a, RightGCDMonoid a) + => Proxy a + -> Laws +rightGCDMonoidLaws _ = Laws "RightGCDMonoid" + [ makeLaw2 @a + "rightGCDMonoidLaw_stripCommonSuffix_commonSuffix" + (rightGCDMonoidLaw_stripCommonSuffix_commonSuffix) + , makeLaw2 @a + "rightGCDMonoidLaw_stripCommonSuffix_mappend_1" + (rightGCDMonoidLaw_stripCommonSuffix_mappend_1) + , makeLaw2 @a + "rightGCDMonoidLaw_stripCommonSuffix_mappend_2" + (rightGCDMonoidLaw_stripCommonSuffix_mappend_2) + , makeLaw2 @a + "rightGCDMonoidLaw_stripCommonSuffix_stripSuffix_1" + (rightGCDMonoidLaw_stripCommonSuffix_stripSuffix_1) + , makeLaw2 @a + "rightGCDMonoidLaw_stripCommonSuffix_stripSuffix_2" + (rightGCDMonoidLaw_stripCommonSuffix_stripSuffix_2) + ] + +rightGCDMonoidLaw_stripCommonSuffix_commonSuffix + :: (Eq a, Show a, RightGCDMonoid a) => a -> a -> Property +rightGCDMonoidLaw_stripCommonSuffix_commonSuffix a b = + makeProperty + "stripCommonSuffix a b & λ(_, _, s) -> s == commonSuffix a b" + (stripCommonSuffix a b & \(_, _, s) -> s == commonSuffix a b) + & cover + "commonSuffix a b /= mempty" + (commonSuffix a b /= mempty) + & report + "stripCommonSuffix a b" + (stripCommonSuffix a b) + & report + "commonSuffix a b" + (commonSuffix a b) + +rightGCDMonoidLaw_stripCommonSuffix_mappend_1 + :: (Eq a, Show a, RightGCDMonoid a) => a -> a -> Property +rightGCDMonoidLaw_stripCommonSuffix_mappend_1 a b = + makeProperty + "stripCommonSuffix a b & λ(x, _, s) -> x <> s == a" + (stripCommonSuffix a b & \(x, _, s) -> x <> s == a) + & cover + "stripCommonSuffix a b & λ(x, _, s) -> x /= mempty && s /= mempty" + (stripCommonSuffix a b & \(x, _, s) -> x /= mempty && s /= mempty) + & report + "stripCommonSuffix a b" + (stripCommonSuffix a b) + & report + "stripCommonSuffix a b & λ(x, _, s) -> x <> s" + (stripCommonSuffix a b & \(x, _, s) -> x <> s) + +rightGCDMonoidLaw_stripCommonSuffix_mappend_2 + :: (Eq a, Show a, RightGCDMonoid a) => a -> a -> Property +rightGCDMonoidLaw_stripCommonSuffix_mappend_2 a b = + makeProperty + "stripCommonSuffix a b & λ(_, x, s) -> x <> s == b" + (stripCommonSuffix a b & \(_, x, s) -> x <> s == b) + & cover + "stripCommonSuffix a b & λ(_, x, s) -> x /= mempty && s /= mempty" + (stripCommonSuffix a b & \(_, x, s) -> x /= mempty && s /= mempty) + & report + "stripCommonSuffix a b" + (stripCommonSuffix a b) + & report + "stripCommonSuffix a b & λ(_, x, s) -> x <> s" + (stripCommonSuffix a b & \(_, x, s) -> x <> s) + +rightGCDMonoidLaw_stripCommonSuffix_stripSuffix_1 + :: (Eq a, Show a, RightGCDMonoid a) => a -> a -> Property +rightGCDMonoidLaw_stripCommonSuffix_stripSuffix_1 a b = + makeProperty + "stripCommonSuffix a b & λ(x, _, s) -> Just x == stripSuffix s a" + (stripCommonSuffix a b & \(x, _, s) -> Just x == stripSuffix s a) + & cover + "stripCommonSuffix a b & λ(x, _, s) -> x /= mempty && s /= mempty" + (stripCommonSuffix a b & \(x, _, s) -> x /= mempty && s /= mempty) + & report + "stripCommonSuffix a b" + (stripCommonSuffix a b) + & report + "stripCommonSuffix a b & λ(_, _, s) -> stripSuffix s a" + (stripCommonSuffix a b & \(_, _, s) -> stripSuffix s a) + +rightGCDMonoidLaw_stripCommonSuffix_stripSuffix_2 + :: (Eq a, Show a, RightGCDMonoid a) => a -> a -> Property +rightGCDMonoidLaw_stripCommonSuffix_stripSuffix_2 a b = + makeProperty + "stripCommonSuffix a b & λ(_, x, s) -> Just x == stripSuffix s b" + (stripCommonSuffix a b & \(_, x, s) -> Just x == stripSuffix s b) + & cover + "stripCommonSuffix a b & λ(_, x, s) -> x /= mempty && s /= mempty" + (stripCommonSuffix a b & \(_, x, s) -> x /= mempty && s /= mempty) + & report + "stripCommonSuffix a b" + (stripCommonSuffix a b) + & report + "stripCommonSuffix a b & λ(_, _, s) -> stripSuffix s b" + (stripCommonSuffix a b & \(_, _, s) -> stripSuffix s b) diff --git a/src/public/Test/QuickCheck/Classes/Monoid/Monus.hs b/src/public/Test/QuickCheck/Classes/Monoid/Monus.hs new file mode 100644 --- /dev/null +++ b/src/public/Test/QuickCheck/Classes/Monoid/Monus.hs @@ -0,0 +1,213 @@ +{- HLINT ignore "Use camelCase" -} +{- HLINT ignore "Redundant bracket" -} + +-- | +-- Copyright: © 2022 Jonathan Knowles +-- License: Apache-2.0 +-- +-- This module provides 'Laws' definitions for classes exported by +-- "Data.Monoid.Monus". +-- +module Test.QuickCheck.Classes.Monoid.Monus + ( monusLaws + , overlappingGCDMonoidLaws + ) + where + +import Prelude hiding + ( gcd, null ) + +import Data.Function + ( (&) ) +import Data.Monoid.GCD + ( OverlappingGCDMonoid (..) ) +import Data.Monoid.Monus + ( Monus (..) ) +import Data.Proxy + ( Proxy (..) ) +import Internal + ( cover, makeLaw1, makeLaw2, makeLaw3, makeProperty, report ) +import Test.QuickCheck + ( Arbitrary (..), Property ) +import Test.QuickCheck.Classes + ( Laws (..) ) +import Test.QuickCheck.Classes.Monoid.GCD + ( overlappingGCDMonoidLaws ) + +-------------------------------------------------------------------------------- +-- Monus +-------------------------------------------------------------------------------- + +-- | 'Laws' for instances of 'Monus'. +-- +-- Tests the following laws: +-- +-- @ +-- a '<\>' a '==' 'mempty' +-- @ +-- +-- @ +-- 'mempty' '<\>' a '==' 'mempty' +-- @ +-- +-- @ +-- a '<>' (b '<\>' a) '==' b '<>' (a '<\>' b) +-- @ +-- +-- @ +-- (a '<\>' b) '<\>' c '==' a '<\>' (b '<>' c) +-- @ +-- +-- @ +-- a '<\>' b '==' 'stripPrefixOverlap' b a +-- @ +-- +-- @ +-- a '<\>' b '==' 'stripSuffixOverlap' b a +-- @ +-- +-- Note that the following superclass laws are __not__ included: +-- +-- * 'Test.QuickCheck.Classes.Semigroup.Cancellative.commutativeLaws' +-- * 'Test.QuickCheck.Classes.monoidLaws' +-- * 'Test.QuickCheck.Classes.Monoid.GCD.overlappingGCDMonoidLaws' +-- +monusLaws + :: forall a. (Arbitrary a, Show a, Eq a, Monus a) + => Proxy a + -> Laws +monusLaws _ = Laws "Monus" + [ makeLaw1 @a + "monusLaw_axiom_1" + (monusLaw_axiom_1) + , makeLaw1 @a + "monusLaw_axiom_2" + (monusLaw_axiom_2) + , makeLaw2 @a + "monusLaw_axiom_3" + (monusLaw_axiom_3) + , makeLaw3 @a + "monusLaw_axiom_4" + (monusLaw_axiom_4) + , makeLaw2 @a + "monusLaw_stripPrefixOverlap" + (monusLaw_stripPrefixOverlap) + , makeLaw2 @a + "monusLaw_stripSuffixOverlap" + (monusLaw_stripSuffixOverlap) + ] + +monusLaw_axiom_1 + :: (Eq a, Monus a, Show a) => a -> Property +monusLaw_axiom_1 a = + makeProperty + "a <\\> a == mempty" + (a <\\> a == mempty) + & cover + "a == mempty" + (a == mempty) + & cover + "a /= mempty" + (a /= mempty) + & report + "a <\\> a" + (a <\\> a) + +monusLaw_axiom_2 + :: (Eq a, Monus a, Show a) => a -> Property +monusLaw_axiom_2 a = + makeProperty + "mempty <\\> a == mempty" + (mempty <\\> a == mempty) + & cover + "a == mempty" + (a == mempty) + & cover + "a /= mempty" + (a /= mempty) + & report + "mempty <\\> a" + (mempty <\\> a) + +monusLaw_axiom_3 + :: (Eq a, Monus a, Show a) => a -> a -> Property +monusLaw_axiom_3 a b = + makeProperty + "a <> (b <\\> a) == b <> (a <\\> b)" + (a <> (b <\\> a) == b <> (a <\\> b)) + & cover + "(a <\\> b) /= mempty" + ((a <\\> b) /= mempty) + & cover + "(b <\\> a) /= mempty" + ((b <\\> a) /= mempty) + & report + "b <\\> a" + (b <\\> a) + & report + "a <> (b <\\> a)" + (a <> (b <\\> a)) + & report + "a <\\> b" + (a <\\> b) + & report + "b <> (a <\\> b)" + (b <> (a <\\> b)) + +monusLaw_axiom_4 + :: (Eq a, Monus a, Show a) => a -> a -> a -> Property +monusLaw_axiom_4 a b c = + makeProperty + "(a <\\> b) <\\> c == a <\\> (b <> c)" + ((a <\\> b) <\\> c == a <\\> (b <> c)) + & cover + "(a <\\> b) <\\> c /= mempty" + ((a <\\> b) <\\> c /= mempty) + & report + "a <\\> b" + (a <\\> b) + & report + "(a <\\> b) <\\> c" + ((a <\\> b) <\\> c) + & report + "b <> c" + (b <> c) + & report + "a <\\> (b <> c)" + (a <\\> (b <> c)) + +monusLaw_stripPrefixOverlap + :: (Eq a, Monus a, Show a) => a -> a -> Property +monusLaw_stripPrefixOverlap a b = + makeProperty + "a <\\> b == stripPrefixOverlap b a" + (a <\\> b == stripPrefixOverlap b a) + & cover + "a <\\> b /= mempty" + (a <\\> b /= mempty) + & report + "a <\\> b" + (a <\\> b) + & report + "stripPrefixOverlap b a" + (stripPrefixOverlap b a) + +monusLaw_stripSuffixOverlap + :: (Eq a, Monus a, Show a) => a -> a -> Property +monusLaw_stripSuffixOverlap a b = + makeProperty + "a <\\> b == stripSuffixOverlap b a" + (a <\\> b == stripSuffixOverlap b a) + & cover + "a <\\> b /= mempty" + (a <\\> b /= mempty) + & report + "a <\\> b" + (a <\\> b) + & report + "stripSuffixOverlap b a" + (stripSuffixOverlap b a) + +-- | Convenient synonym for '<\>'. +(<\\>) :: Monus m => m -> m -> m +(<\\>) = (<\>) diff --git a/src/public/Test/QuickCheck/Classes/Monoid/Null.hs b/src/public/Test/QuickCheck/Classes/Monoid/Null.hs new file mode 100644 --- /dev/null +++ b/src/public/Test/QuickCheck/Classes/Monoid/Null.hs @@ -0,0 +1,131 @@ +{- HLINT ignore "Use camelCase" -} +{- HLINT ignore "Redundant bracket" -} + +-- | +-- Copyright: © 2022 Jonathan Knowles +-- License: Apache-2.0 +-- +-- This module provides 'Laws' definitions for classes exported by +-- "Data.Monoid.Null". +-- +module Test.QuickCheck.Classes.Monoid.Null + ( + -- * Null + monoidNullLaws + + -- * Positive + , positiveMonoidLaws + ) + where + +import Prelude hiding + ( null ) + +import Data.Function + ( (&) ) +import Data.Monoid.Null + ( MonoidNull (..), PositiveMonoid ) +import Data.Proxy + ( Proxy (..) ) +import Internal + ( cover, makeLaw1, makeLaw2, makeProperty, report ) +import Test.QuickCheck + ( Arbitrary (..), Property ) +import Test.QuickCheck.Classes + ( Laws (..) ) + +-------------------------------------------------------------------------------- +-- MonoidNull +-------------------------------------------------------------------------------- + +-- | 'Laws' for instances of 'MonoidNull'. +-- +-- Tests the following law: +-- +-- @ +-- 'null' a '==' (a '==' 'mempty') +-- @ +-- +-- Note that the following superclass laws are __not__ included: +-- +-- * 'Test.QuickCheck.Classes.monoidLaws' +-- +monoidNullLaws + :: forall a. (Arbitrary a, Show a, Eq a, MonoidNull a) + => Proxy a + -> Laws +monoidNullLaws _ = Laws "MonoidNull" + [ makeLaw1 @a + "monoidNullLaw_basic" + (monoidNullLaw_basic) + ] + +monoidNullLaw_basic + :: (Eq a, MonoidNull a) => a -> Property +monoidNullLaw_basic a = + makeProperty + "null a == (a == mempty)" + (null a == (a == mempty)) + & cover + "a == mempty" + (a == mempty) + & cover + "a /= mempty" + (a /= mempty) + & report + "null a" + (null a) + & report + "a == mempty" + (a == mempty) + +-------------------------------------------------------------------------------- +-- PositiveMonoid +-------------------------------------------------------------------------------- + +-- | 'Laws' for instances of 'PositiveMonoid'. +-- +-- Tests the following law: +-- +-- @ +-- 'null' (a '<>' b) '==' ('null' a '&&' 'null' b) +-- @ +-- +-- Note that the following superclass laws are __not__ included: +-- +-- * 'Test.QuickCheck.Classes.Monoid.Null.monoidNullLaws' +-- +positiveMonoidLaws + :: forall a. (Arbitrary a, Show a, Eq a, PositiveMonoid a) + => Proxy a + -> Laws +positiveMonoidLaws _ = Laws "PositiveMonoid" + [ makeLaw2 @a + "positiveMonoidLaw_fundamental" + (positiveMonoidLaw_fundamental) + ] + +positiveMonoidLaw_fundamental + :: (Eq a, PositiveMonoid a, Show a) => a -> a -> Property +positiveMonoidLaw_fundamental a b = + makeProperty + "null (a <> b) == (null a && null b)" + (null (a <> b) == (null a && null b)) + & cover + "null (a <> b)" + (null (a <> b)) + & cover + "not (null (a <> b))" + (not (null (a <> b))) + & report + "a <> b" + (a <> b) + & report + "null (a <> b)" + (null (a <> b)) + & report + "null a" + (null a) + & report + "null b" + (null b) diff --git a/src/public/Test/QuickCheck/Classes/Semigroup/Cancellative.hs b/src/public/Test/QuickCheck/Classes/Semigroup/Cancellative.hs new file mode 100644 --- /dev/null +++ b/src/public/Test/QuickCheck/Classes/Semigroup/Cancellative.hs @@ -0,0 +1,483 @@ +{- HLINT ignore "Use camelCase" -} +{- HLINT ignore "Use infix" -} +{- HLINT ignore "Redundant bracket" -} + +-- | +-- Copyright: © 2022 Jonathan Knowles +-- License: Apache-2.0 +-- +-- This module provides 'Laws' definitions for classes exported by +-- "Data.Semigroup.Cancellative". +-- +module Test.QuickCheck.Classes.Semigroup.Cancellative + ( + -- * Commutative + commutativeLaws + + -- * Reductive + , reductiveLaws + , leftReductiveLaws + , rightReductiveLaws + + -- * Cancellative + , cancellativeLaws + , leftCancellativeLaws + , rightCancellativeLaws + ) + where + +import Data.Function + ( (&) ) +import Data.Maybe + ( isJust ) +import Data.Proxy + ( Proxy (..) ) +import Data.Semigroup.Cancellative + ( Cancellative + , Commutative + , LeftCancellative + , LeftReductive (..) + , Reductive (..) + , RightCancellative + , RightReductive (..) + ) +import Internal + ( cover, makeLaw2, makeProperty, report ) +import Test.QuickCheck + ( Arbitrary (..), Property ) +import Test.QuickCheck.Classes + ( Laws (..) ) + +-------------------------------------------------------------------------------- +-- Cancellative +-------------------------------------------------------------------------------- + +-- | 'Laws' for instances of 'Cancellative'. +-- +-- Tests the following laws: +-- +-- @ +-- (a '<>' b) '' a '==' 'Just' b +-- @ +-- +-- @ +-- (a '<>' b) '' b '==' 'Just' a +-- @ +-- +-- Note that the following superclass laws are __not__ included: +-- +-- * 'Test.QuickCheck.Classes.Semigroup.Cancellative.leftCancellativeLaws' +-- * 'Test.QuickCheck.Classes.Semigroup.Cancellative.rightCancellativeLaws' +-- * 'Test.QuickCheck.Classes.Semigroup.Cancellative.reductiveLaws' +-- +cancellativeLaws + :: forall a. (Arbitrary a, Show a, Eq a, Cancellative a) + => Proxy a + -> Laws +cancellativeLaws _ = Laws "Cancellative" + [ makeLaw2 @a + "cancellativeLaw_cancellation_prefix" + (cancellativeLaw_cancellation_prefix) + , makeLaw2 @a + "cancellativeLaw_cancellation_suffix" + (cancellativeLaw_cancellation_suffix) + ] + +cancellativeLaw_cancellation_prefix + :: (Eq a, Show a, Cancellative a) => a -> a -> Property +cancellativeLaw_cancellation_prefix a b = + makeProperty + "(a <> b) a == Just b" + ((a <> b) a == Just b) + & report + "a <> b" + (a <> b) + & report + "(a <> b) a" + ((a <> b) a) + +cancellativeLaw_cancellation_suffix + :: (Eq a, Show a, Cancellative a) => a -> a -> Property +cancellativeLaw_cancellation_suffix a b = + makeProperty + "(a <> b) b == Just a" + ((a <> b) b == Just a) + & report + "a <> b" + (a <> b) + & report + "(a <> b) b" + ((a <> b) b) + +-------------------------------------------------------------------------------- +-- Commutative +-------------------------------------------------------------------------------- + +-- | 'Laws' for instances of 'Commutative'. +-- +-- Tests the following law: +-- +-- @ +-- a '<>' b '==' b '<>' a +-- @ +-- +-- Note that the following superclass laws are __not__ included: +-- +-- * 'Test.QuickCheck.Classes.semigroupLaws' +-- +commutativeLaws + :: forall a. (Arbitrary a, Show a, Eq a, Commutative a) + => Proxy a + -> Laws +commutativeLaws _ = Laws "Commutative" + [ makeLaw2 @a + "commutativeLaw_basic" + (commutativeLaw_basic) + ] + +commutativeLaw_basic + :: (Eq a, Show a, Commutative a) => a -> a -> Property +commutativeLaw_basic a b = + makeProperty + "a <> b == b <> a" + (a <> b == b <> a) + & report + "a <> b" + (a <> b) + & report + "b <> a" + (b <> a) + & cover + "(a /= b) && (a <> b /= a) && (b <> a /= b)" + ((a /= b) && (a <> b /= a) && (b <> a /= b)) + +-------------------------------------------------------------------------------- +-- LeftCancellative +-------------------------------------------------------------------------------- + +-- | 'Laws' for instances of 'LeftCancellative'. +-- +-- Tests the following law: +-- +-- @ +-- 'stripPrefix' a (a '<>' b) '==' 'Just' b +-- @ +-- +-- Note that the following superclass laws are __not__ included: +-- +-- * 'Test.QuickCheck.Classes.Semigroup.Cancellative.leftReductiveLaws' +-- +leftCancellativeLaws + :: forall a. (Arbitrary a, Show a, Eq a, LeftCancellative a) + => Proxy a + -> Laws +leftCancellativeLaws _ = Laws "LeftCancellative" + [ makeLaw2 @a + "leftCancellativeLaw_cancellation" + (leftCancellativeLaw_cancellation) + ] + +leftCancellativeLaw_cancellation + :: (Eq a, Show a, LeftCancellative a) => a -> a -> Property +leftCancellativeLaw_cancellation a b = + makeProperty + "stripPrefix a (a <> b) == Just b" + (stripPrefix a (a <> b) == Just b) + & report + "a <> b" + (a <> b) + & report + "stripPrefix a (a <> b)" + (stripPrefix a (a <> b)) + +-------------------------------------------------------------------------------- +-- LeftReductive +-------------------------------------------------------------------------------- + +-- | 'Laws' for instances of 'LeftReductive'. +-- +-- Tests the following laws: +-- +-- @ +-- a '`isPrefixOf`' (a '<>' b) +-- @ +-- +-- @ +-- 'isPrefixOf' a b '==' 'isJust' ('stripPrefix' a b) +-- @ +-- +-- @ +-- 'maybe' b (a '<>') ('stripPrefix' a b) '==' b +-- @ +-- +-- Note that the following superclass laws are __not__ included: +-- +-- * 'Test.QuickCheck.Classes.semigroupLaws' +-- +leftReductiveLaws + :: forall a. (Arbitrary a, Show a, Eq a, LeftReductive a) + => Proxy a + -> Laws +leftReductiveLaws _ = Laws "LeftReductive" + [ makeLaw2 @a + "leftReductiveLaw_isPrefixOf_mappend" + (leftReductiveLaw_isPrefixOf_mappend) + , makeLaw2 @a + "leftReductiveLaw_isPrefixOf_stripPrefix" + (leftReductiveLaw_isPrefixOf_stripPrefix) + , makeLaw2 @a + "leftReductiveLaw_stripPrefix" + (leftReductiveLaw_stripPrefix) + ] + +leftReductiveLaw_isPrefixOf_mappend + :: (Eq a, Show a, LeftReductive a) => a -> a -> Property +leftReductiveLaw_isPrefixOf_mappend a b = + makeProperty + "a `isPrefixOf` (a <> b)" + (a `isPrefixOf` (a <> b)) + & report + "a <> b" + (a <> b) + +leftReductiveLaw_isPrefixOf_stripPrefix + :: (Eq a, Show a, LeftReductive a) => a -> a -> Property +leftReductiveLaw_isPrefixOf_stripPrefix a b = + makeProperty + "isPrefixOf a b == isJust (stripPrefix a b)" + (isPrefixOf a b == isJust (stripPrefix a b)) + & report + "isPrefixOf a b" + (isPrefixOf a b) + & report + "stripPrefix a b" + (stripPrefix a b) + +leftReductiveLaw_stripPrefix + :: (Eq a, Show a, LeftReductive a) => a -> a -> Property +leftReductiveLaw_stripPrefix a b = + makeProperty + "maybe b (a <>) (stripPrefix a b) == b" + (maybe b (a <>) (stripPrefix a b) == b) + & report + "stripPrefix a b" + (stripPrefix a b) + & report + "maybe b (a <>) (stripPrefix a b)" + (maybe b (a <>) (stripPrefix a b)) + +-------------------------------------------------------------------------------- +-- Reductive +-------------------------------------------------------------------------------- + +-- | 'Laws' for instances of 'Reductive'. +-- +-- Tests the following laws: +-- +-- @ +-- a '' b '==' 'stripPrefix' b a +-- @ +-- +-- @ +-- a '' b '==' 'stripSuffix' b a +-- @ +-- +-- @ +-- 'maybe' a (b '<>') (a '' b) '==' a +-- @ +-- +-- @ +-- 'maybe' a ('<>' b) (a '' b) '==' a +-- @ +-- +-- Note that the following superclass laws are __not__ included: +-- +-- * 'Test.QuickCheck.Classes.Semigroup.Cancellative.commutativeLaws' +-- * 'Test.QuickCheck.Classes.Semigroup.Cancellative.leftReductiveLaws' +-- * 'Test.QuickCheck.Classes.Semigroup.Cancellative.rightReductiveLaws' +-- +reductiveLaws + :: forall a. (Arbitrary a, Show a, Eq a, Reductive a) + => Proxy a + -> Laws +reductiveLaws _ = Laws "Reductive" + [ makeLaw2 @a + "reductiveLaw_equivalence_prefix" + (reductiveLaw_equivalence_prefix) + , makeLaw2 @a + "reductiveLaw_equivalence_suffix" + (reductiveLaw_equivalence_suffix) + , makeLaw2 @a + "reductiveLaw_inversion_prefix" + (reductiveLaw_inversion_prefix) + , makeLaw2 @a + "reductiveLaw_inversion_suffix" + (reductiveLaw_inversion_suffix) + ] + +reductiveLaw_equivalence_prefix + :: (Eq a, Show a, Reductive a) => a -> a -> Property +reductiveLaw_equivalence_prefix a b = + makeProperty + "a b == stripPrefix b a" + (a b == stripPrefix b a) + & report + "a b" + (a b) + & report + "stripPrefix b a" + (stripPrefix b a) + +reductiveLaw_equivalence_suffix + :: (Eq a, Show a, Reductive a) => a -> a -> Property +reductiveLaw_equivalence_suffix a b = + makeProperty + "a b == stripSuffix b a" + (a b == stripSuffix b a) + & report + "a b" + (a b) + & report + "stripSuffix b a" + (stripSuffix b a) + +reductiveLaw_inversion_prefix + :: (Eq a, Show a, Reductive a) => a -> a -> Property +reductiveLaw_inversion_prefix a b = + makeProperty + "maybe a (b <>) (a b) == a" + (maybe a (b <>) (a b) == a) + & report + "a b" + (a b) + & report + "maybe a (b <>) (a b)" + (maybe a (b <>) (a b)) + +reductiveLaw_inversion_suffix + :: (Eq a, Show a, Reductive a) => a -> a -> Property +reductiveLaw_inversion_suffix a b = + makeProperty + "maybe a (<> b) (a b) == a" + (maybe a (<> b) (a b) == a) + & report + "a b" + (a b) + & report + "maybe a (<> b) (a b)" + (maybe a (<> b) (a b)) + +-------------------------------------------------------------------------------- +-- RightCancellative +-------------------------------------------------------------------------------- + +-- | 'Laws' for instances of 'RightCancellative'. +-- +-- Tests the following law: +-- +-- @ +-- 'stripSuffix' b (a '<>' b) '==' 'Just' a +-- @ +-- +-- Note that the following superclass laws are __not__ included: +-- +-- * 'Test.QuickCheck.Classes.Semigroup.Cancellative.rightReductiveLaws' +-- +rightCancellativeLaws + :: forall a. (Arbitrary a, Show a, Eq a, RightCancellative a) + => Proxy a + -> Laws +rightCancellativeLaws _ = Laws "RightCancellative" + [ makeLaw2 @a + "rightCancellativeLaw_cancellation" + (rightCancellativeLaw_cancellation) + ] + +rightCancellativeLaw_cancellation + :: (Eq a, Show a, RightCancellative a) => a -> a -> Property +rightCancellativeLaw_cancellation a b = + makeProperty + "stripSuffix b (a <> b) == Just a" + (stripSuffix b (a <> b) == Just a) + & report + "a <> b" + (a <> b) + & report + "stripSuffix b (a <> b)" + (stripSuffix b (a <> b)) + +-------------------------------------------------------------------------------- +-- RightReductive +-------------------------------------------------------------------------------- + +-- | 'Laws' for instances of 'RightReductive'. +-- +-- Tests the following laws: +-- +-- @ +-- b '`isSuffixOf`' (a '<>' b) +-- @ +-- +-- @ +-- 'isSuffixOf' a b '==' 'isJust' ('stripSuffix' a b) +-- @ +-- +-- @ +-- 'maybe' b ('<>' a) ('stripSuffix' a b) '==' b +-- @ +-- +-- Note that the following superclass laws are __not__ included: +-- +-- * 'Test.QuickCheck.Classes.semigroupLaws' +-- +rightReductiveLaws + :: forall a. (Arbitrary a, Show a, Eq a, RightReductive a) + => Proxy a + -> Laws +rightReductiveLaws _ = Laws "RightReductive" + [ makeLaw2 @a + "rightReductiveLaw_isSuffixOf_mappend" + (rightReductiveLaw_isSuffixOf_mappend) + , makeLaw2 @a + "rightReductiveLaw_isSuffixOf_stripSuffix" + (rightReductiveLaw_isSuffixOf_stripSuffix) + , makeLaw2 @a + "rightReductiveLaw_stripSuffix" + (rightReductiveLaw_stripSuffix) + ] + +rightReductiveLaw_isSuffixOf_mappend + :: (Eq a, Show a, RightReductive a) => a -> a -> Property +rightReductiveLaw_isSuffixOf_mappend a b = + makeProperty + "b `isSuffixOf` (a <> b)" + (b `isSuffixOf` (a <> b)) + & report + "a <> b" + (a <> b) + +rightReductiveLaw_isSuffixOf_stripSuffix + :: (Eq a, Show a, RightReductive a) => a -> a -> Property +rightReductiveLaw_isSuffixOf_stripSuffix a b = + makeProperty + "isSuffixOf a b == isJust (stripSuffix a b)" + (isSuffixOf a b == isJust (stripSuffix a b)) + & report + "isSuffixOf a b" + (isSuffixOf a b) + & report + "stripSuffix a b" + (stripSuffix a b) + +rightReductiveLaw_stripSuffix + :: (Eq a, Show a, RightReductive a) => a -> a -> Property +rightReductiveLaw_stripSuffix a b = + makeProperty + "maybe b (<> a) (stripSuffix a b) == b" + (maybe b (<> a) (stripSuffix a b) == b) + & report + "stripSuffix a b" + (stripSuffix a b) + & report + "maybe b (<> a) (stripSuffix a b)" + (maybe b (<> a) (stripSuffix a b)) diff --git a/src/test/ClassSpec.hs b/src/test/ClassSpec.hs new file mode 100644 --- /dev/null +++ b/src/test/ClassSpec.hs @@ -0,0 +1,405 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + +-- | +-- Copyright: © 2022 Jonathan Knowles +-- License: Apache-2.0 +-- +module ClassSpec where + +import Data.ByteString.Lazy + ( ByteString ) +import Data.IntMap.Strict + ( IntMap ) +import Data.Map.Strict + ( Map ) +import Data.Monoid + ( Product (..), Sum (..) ) +import Data.Monoid.GCD + ( GCDMonoid, LeftGCDMonoid, OverlappingGCDMonoid, RightGCDMonoid ) +import Data.Monoid.Monus + ( Monus ) +import Data.Monoid.Null + ( MonoidNull, PositiveMonoid ) +import Data.Semigroup.Cancellative + ( Cancellative + , Commutative + , LeftCancellative + , LeftReductive + , Reductive + , RightCancellative + , RightReductive + , SumCancellative + ) +import Data.Sequence + ( Seq ) +import Data.Set + ( Set ) +import Data.Text + ( Text ) +import Data.Vector + ( Vector ) +import Numeric.Natural + ( Natural ) +import Numeric.Product.Commutative + ( CommutativeProduct ) +import Test.Hspec + ( Spec ) +import Test.Hspec.Laws + ( testLawsMany ) +import Test.QuickCheck + ( Arbitrary (..) + , Confidence + , Property + , arbitrarySizedIntegral + , scale + , shrinkMap + ) +import Test.QuickCheck.Classes + ( Laws (..) ) +import Test.QuickCheck.Classes.Monoid.GCD + ( cancellativeGCDMonoidLaws + , gcdMonoidLaws + , leftGCDMonoidLaws + , overlappingGCDMonoidLaws + , rightGCDMonoidLaws + ) +import Test.QuickCheck.Classes.Monoid.Monus + ( monusLaws ) +import Test.QuickCheck.Classes.Monoid.Null + ( monoidNullLaws, positiveMonoidLaws ) +import Test.QuickCheck.Classes.Semigroup.Cancellative + ( cancellativeLaws + , commutativeLaws + , leftCancellativeLaws + , leftReductiveLaws + , reductiveLaws + , rightCancellativeLaws + , rightReductiveLaws + ) +import Test.QuickCheck.Instances.ByteString + () +import Test.QuickCheck.Instances.Natural + () +import Test.QuickCheck.Instances.Text + () +import Test.QuickCheck.Instances.Vector + () +import Test.QuickCheck.Property + ( Result (..), mapTotalResult ) + +spec :: Spec +spec = do + testLawsMany @() $ fmap disableCoverageCheck <$> + [ cancellativeGCDMonoidLaws + , cancellativeLaws + , commutativeLaws + , gcdMonoidLaws + , leftCancellativeLaws + , leftGCDMonoidLaws + , leftReductiveLaws + , monoidNullLaws + , monusLaws + , overlappingGCDMonoidLaws + , positiveMonoidLaws + , reductiveLaws + , rightCancellativeLaws + , rightGCDMonoidLaws + , rightReductiveLaws + ] + testLawsMany @ByteString + [ leftCancellativeLaws + , leftGCDMonoidLaws + , leftReductiveLaws + , monoidNullLaws + , overlappingGCDMonoidLaws + , positiveMonoidLaws + , rightCancellativeLaws + , rightGCDMonoidLaws + , rightReductiveLaws + ] + testLawsMany @Text + [ leftCancellativeLaws + , leftGCDMonoidLaws + , leftReductiveLaws + , monoidNullLaws + , overlappingGCDMonoidLaws + , positiveMonoidLaws + , rightCancellativeLaws + , rightGCDMonoidLaws + , rightReductiveLaws + ] + testLawsMany @[SmallInt] + [ leftCancellativeLaws + , leftGCDMonoidLaws + , leftReductiveLaws + , monoidNullLaws + , overlappingGCDMonoidLaws + , positiveMonoidLaws + , rightCancellativeLaws + , rightGCDMonoidLaws + , rightReductiveLaws + ] + testLawsMany @(Seq SmallInt) + [ leftCancellativeLaws + , leftGCDMonoidLaws + , leftReductiveLaws + , monoidNullLaws + , overlappingGCDMonoidLaws + , positiveMonoidLaws + , rightCancellativeLaws + , rightGCDMonoidLaws + , rightReductiveLaws + ] + testLawsMany @(Set SmallInt) + [ commutativeLaws + , gcdMonoidLaws + , leftGCDMonoidLaws + , leftReductiveLaws + , monoidNullLaws + , monusLaws + , overlappingGCDMonoidLaws + , positiveMonoidLaws + , reductiveLaws + , rightGCDMonoidLaws + , rightReductiveLaws + ] + testLawsMany @(Set Natural) + [ commutativeLaws + , gcdMonoidLaws + , leftGCDMonoidLaws + , leftReductiveLaws + , monoidNullLaws + , monusLaws + , overlappingGCDMonoidLaws + , positiveMonoidLaws + , reductiveLaws + , rightGCDMonoidLaws + , rightReductiveLaws + ] + testLawsMany @(Product SmallInt) + [ commutativeLaws + , leftReductiveLaws + , monoidNullLaws + , reductiveLaws + , rightReductiveLaws + ] + testLawsMany @(Product Natural) + [ commutativeLaws + , gcdMonoidLaws + , leftGCDMonoidLaws + , leftReductiveLaws + , monoidNullLaws + , monusLaws + , overlappingGCDMonoidLaws + , positiveMonoidLaws + , reductiveLaws + , rightGCDMonoidLaws + , rightReductiveLaws + ] + testLawsMany @(Sum SmallInt) + [ cancellativeLaws + , commutativeLaws + , leftCancellativeLaws + , leftReductiveLaws + , monoidNullLaws + , reductiveLaws + , rightCancellativeLaws + , rightReductiveLaws + ] + testLawsMany @(Sum Natural) + [ cancellativeGCDMonoidLaws + , cancellativeLaws + , commutativeLaws + , gcdMonoidLaws + , leftCancellativeLaws + , leftGCDMonoidLaws + , leftReductiveLaws + , monoidNullLaws + , monusLaws + , overlappingGCDMonoidLaws + , positiveMonoidLaws + , reductiveLaws + , rightCancellativeLaws + , rightGCDMonoidLaws + , rightReductiveLaws + ] + testLawsMany @(IntMap SmallInt) + [ leftGCDMonoidLaws + , leftReductiveLaws + , monoidNullLaws + , overlappingGCDMonoidLaws + , positiveMonoidLaws + , rightReductiveLaws + ] + testLawsMany @(IntMap Natural) + [ leftGCDMonoidLaws + , leftReductiveLaws + , monoidNullLaws + , overlappingGCDMonoidLaws + , positiveMonoidLaws + , rightReductiveLaws + ] + testLawsMany @(Map Int SmallInt) + [ leftGCDMonoidLaws + , leftReductiveLaws + , monoidNullLaws + , overlappingGCDMonoidLaws + , positiveMonoidLaws + , rightReductiveLaws + ] + testLawsMany @(Map Int Natural) + [ leftGCDMonoidLaws + , leftReductiveLaws + , monoidNullLaws + , overlappingGCDMonoidLaws + , positiveMonoidLaws + , rightReductiveLaws + ] + testLawsMany @(Maybe ()) $ fmap disableCoverageCheck <$> + [ commutativeLaws + , leftGCDMonoidLaws + , leftReductiveLaws + , monoidNullLaws + , monusLaws + , overlappingGCDMonoidLaws + , positiveMonoidLaws + , reductiveLaws + , rightGCDMonoidLaws + , rightReductiveLaws + ] + testLawsMany @(Maybe (Product SmallInt)) + [ commutativeLaws + , leftReductiveLaws + , monoidNullLaws + , positiveMonoidLaws + , reductiveLaws + , rightReductiveLaws + ] + testLawsMany @(Maybe (Product Natural)) + [ commutativeLaws + , leftGCDMonoidLaws + , leftReductiveLaws + , monoidNullLaws + , monusLaws + , overlappingGCDMonoidLaws + , positiveMonoidLaws + , reductiveLaws + , rightGCDMonoidLaws + , rightReductiveLaws + ] + testLawsMany @(Maybe (Sum SmallInt)) + [ commutativeLaws + , leftReductiveLaws + , monoidNullLaws + , positiveMonoidLaws + , reductiveLaws + , rightReductiveLaws + ] + testLawsMany @(Maybe (Sum Natural)) + [ commutativeLaws + , leftGCDMonoidLaws + , leftReductiveLaws + , monoidNullLaws + , monusLaws + , overlappingGCDMonoidLaws + , positiveMonoidLaws + , reductiveLaws + , rightGCDMonoidLaws + , rightReductiveLaws + ] + testLawsMany @(Vector SmallInt) + [ leftCancellativeLaws + , leftGCDMonoidLaws + , leftReductiveLaws + , monoidNullLaws + , overlappingGCDMonoidLaws + , positiveMonoidLaws + , rightCancellativeLaws + , rightGCDMonoidLaws + , rightReductiveLaws + ] + +-------------------------------------------------------------------------------- +-- Notes +-------------------------------------------------------------------------------- + +{- All laws tested in this module: + + [ cancellativeGCDMonoidLaws + , cancellativeLaws + , commutativeLaws + , gcdMonoidLaws + , leftCancellativeLaws + , leftGCDMonoidLaws + , leftReductiveLaws + , monoidNullLaws + , monusLaws + , overlappingGCDMonoidLaws + , positiveMonoidLaws + , reductiveLaws + , rightCancellativeLaws + , rightGCDMonoidLaws + , rightReductiveLaws + ] +-} + +-------------------------------------------------------------------------------- +-- Utility types +-------------------------------------------------------------------------------- + +type SmallInt = Small Int + +newtype Small a = Small {getSmall :: a} + deriving newtype + ( Cancellative + , Commutative + , CommutativeProduct + , Enum + , Eq + , GCDMonoid + , Integral + , LeftCancellative + , LeftGCDMonoid + , LeftReductive + , Monoid + , MonoidNull + , Monus + , Num + , Ord + , OverlappingGCDMonoid + , PositiveMonoid + , Real + , Reductive + , RightCancellative + , RightGCDMonoid + , RightReductive + , Semigroup + , Show + , SumCancellative + ) + +instance Arbitrary a => Arbitrary (Small a) where + arbitrary = Small <$> scale (`div` 2) arbitrary + shrink = shrinkMap Small getSmall + +-------------------------------------------------------------------------------- +-- Coverage checks +-------------------------------------------------------------------------------- + +class HasCoverageCheck p where + disableCoverageCheck :: p -> p + +instance HasCoverageCheck Laws where + disableCoverageCheck = mapLawsProperties disableCoverageCheck + +instance HasCoverageCheck Property where + disableCoverageCheck = mapPropertyCheckCoverage (const Nothing) + +mapLawsProperties + :: (Property -> Property) -> Laws -> Laws +mapLawsProperties f (Laws t ps) = Laws t $ fmap f <$> ps + +mapPropertyCheckCoverage + :: (Maybe Confidence -> Maybe Confidence) -> Property -> Property +mapPropertyCheckCoverage f = + mapTotalResult $ \r -> r {maybeCheckCoverage = f (maybeCheckCoverage r)} diff --git a/src/test/Spec.hs b/src/test/Spec.hs new file mode 100644 --- /dev/null +++ b/src/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} diff --git a/src/test/SpecHook.hs b/src/test/SpecHook.hs new file mode 100644 --- /dev/null +++ b/src/test/SpecHook.hs @@ -0,0 +1,6 @@ +module SpecHook where + +import Test.Hspec + +hook :: Spec -> Spec +hook = parallel diff --git a/src/test/Test/Hspec/Laws.hs b/src/test/Test/Hspec/Laws.hs new file mode 100644 --- /dev/null +++ b/src/test/Test/Hspec/Laws.hs @@ -0,0 +1,61 @@ +-- | +-- Copyright: © 2022 Jonathan Knowles +-- License: Apache-2.0 +-- +-- Provides testing functions to check that type class instances obey laws. +-- +module Test.Hspec.Laws + ( testLaws + , testLawsMany + ) where + +import Prelude + +import Control.Monad + ( forM_ ) +import Data.Proxy + ( Proxy (..) ) +import Data.Typeable + ( Typeable, typeRep ) +import Test.Hspec + ( Spec, describe, it, parallel ) +import Test.QuickCheck.Classes + ( Laws (..) ) + +-- | Constructs a test to check that the given type class instance obeys the +-- given set of laws. +-- +-- Example usage: +-- +-- >>> testLaws @Natural ordLaws +-- >>> testLaws @(Map Int) functorLaws +-- +testLaws + :: forall a. Typeable a + => (Proxy a -> Laws) + -> Spec +testLaws getLaws = + parallel $ describe description $ + forM_ (lawsProperties laws) $ uncurry it + where + description = mconcat + [ "Testing " + , lawsTypeclass laws + , " laws for type " + , show (typeRep $ Proxy @a) + ] + laws = getLaws $ Proxy @a + +-- | Calls `testLaws` with multiple sets of laws. +-- +-- Example usage: +-- +-- >>> testLawsMany @Natural [eqLaws, ordLaws] +-- >>> testLawsMany @(Map Int) [foldableLaws, functorLaws] +-- +testLawsMany + :: forall a. Typeable a + => [Proxy a -> Laws] + -> Spec +testLawsMany getLawsMany = + testLaws @a `mapM_` getLawsMany