diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,5 @@ +# 0.0.0.0 + +- Provides support for testing instances of classes defined in the following + modules: + - `Data.Group` 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–2023 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,76 @@ +# `quickcheck-groups` + + + +## Overview + +The `quickcheck-groups` library provides: +- [QuickCheck](https://hackage.haskell.org/package/QuickCheck) support for testing instances of type classes defined in the [`groups`](https://hackage.haskell.org/package/groups) 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#v: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 [`Group`](https://hackage.haskell.org/package/groups/docs/Data-Group.html#t:Group) laws hold for the [`Sum`](https://hackage.haskell.org/package/base/docs/Data-Monoid.html#t:Sum) [`Integer`](https://hackage.haskell.org/package/base/docs/Prelude.html#t:Integer) type: +> +> ```hs +> import Data.Monoid (Sum) +> import Data.Proxy (Proxy (Proxy)) +> import Test.QuickCheck.Classes (lawsCheck) +> import Test.QuickCheck.Classes.Group (groupLaws) +> +> lawsCheck (groupLaws (Proxy :: Proxy (Sum Integer))) +> ``` +> +> If all tests pass, you should see output similar to: +> +> ```hs +> Group: groupLaw_invert_mempty +++ OK, passed 1 test. +> Group: groupLaw_invert_invert +++ OK, passed 100 tests. +> Group: groupLaw_invert_mappend_1 +++ OK, passed 100 tests. +> Group: groupLaw_invert_mappend_2 +++ OK, passed 100 tests. +> Group: groupLaw_subtract_mempty +++ OK, passed 100 tests. +> Group: groupLaw_subtract_self +++ OK, passed 100 tests. +> Group: groupLaw_subtract_other +++ OK, passed 100 tests. +> Group: groupLaw_pow_zero +++ OK, passed 100 tests. +> Group: groupLaw_pow_nonNegative +++ OK, passed 100 tests. +> Group: groupLaw_pow_nonPositive +++ 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#v: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) [`Integer`](https://hackage.haskell.org/package/base/docs/Prelude.html#t:Integer) type satisfies the laws of [`Abelian`](https://hackage.haskell.org/package/groups/docs/Data-Group.html#t:Abelian) and all superclasses: +> +> ```hs +> import Data.Monoid (Sum) +> import Data.Proxy (Proxy (Proxy)) +> import Test.QuickCheck.Classes +> import Test.QuickCheck.Classes.Group +> +> lawsCheckOne (Proxy :: Proxy (Sum Integer)) +> [ semigroupLaws +> , monoidLaws +> , groupLaws +> , abelianLaws +> ] +> ``` + +## 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. diff --git a/quickcheck-groups.cabal b/quickcheck-groups.cabal new file mode 100644 --- /dev/null +++ b/quickcheck-groups.cabal @@ -0,0 +1,124 @@ +cabal-version: 3.0 +name: quickcheck-groups +version: 0.0.0.0 +bug-reports: https://github.com/jonathanknowles/quickcheck-groups/issues +license: Apache-2.0 +license-file: LICENSE +author: Jonathan Knowles +maintainer: mail@jonathanknowles.net +copyright: 2022–2023 Jonathan Knowles +category: Testing +synopsis: Testing group class instances with QuickCheck +description: + + QuickCheck support for testing instances of type classes defined in the + groups library. + +extra-source-files: + CHANGELOG.md + README.md + +common dependency-base + build-depends:base >= 4.14.3.0 && < 4.18 +common dependency-hspec + build-depends:hspec >= 2.10.7 && < 2.11 +common dependency-groups + build-depends:groups >= 0.5.3 && < 0.6 +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 extensions + default-extensions: + DerivingStrategies + FlexibleContexts + FlexibleInstances + GeneralizedNewtypeDeriving + LambdaCase + PolyKinds + ScopedTypeVariables + TypeApplications + ViewPatterns + +source-repository head + type: git + location: https://github.com/jonathanknowles/quickcheck-groups + +library + import: + , dependency-base + , dependency-groups + , dependency-QuickCheck + , dependency-quickcheck-classes + , extensions + hs-source-dirs: + src/public + exposed-modules: + Test.QuickCheck.Classes.Group + default-language: + Haskell2010 + build-depends: + , internal + +library internal + import: + , dependency-base + , dependency-pretty-show + , dependency-QuickCheck + , dependency-semigroupoids + , extensions + hs-source-dirs: + src/internal + exposed-modules: + Internal + Internal.Semigroup.Eq + Internal.Semigroup.Tuple + default-language: + Haskell2010 + +library prelude + import: + , dependency-base + , dependency-groups + , dependency-QuickCheck + , dependency-quickcheck-classes + , dependency-quickcheck-instances + , extensions + hs-source-dirs: + src/prelude + exposed-modules: + Internal.Prelude + default-language: + Haskell2010 + build-depends: + , quickcheck-groups + +test-suite test + import: + , dependency-base + , dependency-hspec + , dependency-groups + , dependency-QuickCheck + , dependency-quickcheck-classes + , extensions + main-is: + Spec.hs + hs-source-dirs: + src/test + other-modules: + ClassSpec + Test.Hspec.Laws + type: exitcode-stdio-1.0 + default-language: + Haskell2010 + build-tool-depends: + hspec-discover:hspec-discover ==2.* + build-depends: + , quickcheck-groups 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–2023 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–2023 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–2023 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,18 @@ +-- | +-- Copyright: © 2022–2023 Jonathan Knowles +-- License: Apache-2.0 +-- +module Internal.Prelude + ( module Data.Group + , module Numeric.Natural + , module Test.QuickCheck + , module Test.QuickCheck.Classes.Group + ) + where + +import Data.Group +import Numeric.Natural +import Test.QuickCheck +import Test.QuickCheck.Classes.Group +import Test.QuickCheck.Instances.Natural + () diff --git a/src/public/Test/QuickCheck/Classes/Group.hs b/src/public/Test/QuickCheck/Classes/Group.hs new file mode 100644 --- /dev/null +++ b/src/public/Test/QuickCheck/Classes/Group.hs @@ -0,0 +1,350 @@ +{- HLINT ignore "Use camelCase" -} +{- HLINT ignore "Redundant bracket" -} + +-- | +-- Copyright: © 2022–2023 Jonathan Knowles +-- License: Apache-2.0 +-- +-- This module provides 'Laws' definitions for classes exported by +-- "Data.Group". +-- +module Test.QuickCheck.Classes.Group + ( + -- * Group + groupLaws + + -- * Abelian + , abelianLaws + ) + where + +import Prelude + +import Data.Function + ( (&) ) +import Data.Group + ( Abelian, Group (..) ) +import Data.Proxy + ( Proxy (..) ) +import Internal + ( cover, makeLaw0, makeLaw1, makeLaw2, makeProperty, report ) +import Test.QuickCheck + ( Arbitrary (..) + , NonNegative (..) + , NonPositive (..) + , Property + , forAllShrink + ) +import Test.QuickCheck.Classes + ( Laws (..) ) + +-------------------------------------------------------------------------------- +-- Group +-------------------------------------------------------------------------------- + +-- | 'Laws' for instances of 'Group'. +-- +-- Includes the following laws: +-- +-- __/Inversion/__ +-- +-- @ +-- 'invert' 'mempty' '==' 'mempty' +-- @ +-- +-- @ +-- 'invert' ('invert' a) '==' a +-- @ +-- +-- @ +-- \ \ a '<>' 'invert' a '==' 'mempty' +-- 'invert' a '<>' \ \ a '==' 'mempty' +-- @ +-- +-- __/Subtraction/__ +-- +-- @ +-- a '~~' 'mempty' '==' a +-- @ +-- +-- @ +-- a '~~' a '==' 'mempty' +-- @ +-- +-- @ +-- a '~~' b '==' a '<>' 'invert' b +-- @ +-- +-- __/Exponentiation/__ +-- +-- @ +-- 'pow' a 0 '==' 'mempty' +-- @ +-- +-- @ +-- n '>=' 0 ==> 'pow' a n '==' \ \ 'mconcat' ('replicate' \ \ n a) +-- n '<=' 0 ==> 'pow' a n '==' 'invert' ('mconcat' ('replicate' ('abs' n) a)) +-- @ +-- +-- == Superclass laws +-- +-- Note that the following superclass laws are __not__ included: +-- +-- * 'Test.QuickCheck.Classes.monoidLaws' +-- +groupLaws + :: forall a. (Arbitrary a, Show a, Eq a, Group a) + => Proxy a + -> Laws +groupLaws _ = Laws "Group" + [ makeLaw0 @a + "groupLaw_invert_mempty" + (groupLaw_invert_mempty) + , makeLaw1 @a + "groupLaw_invert_invert" + (groupLaw_invert_invert) + , makeLaw1 @a + "groupLaw_invert_mappend_1" + (groupLaw_invert_mappend_1) + , makeLaw1 @a + "groupLaw_invert_mappend_2" + (groupLaw_invert_mappend_2) + , makeLaw1 @a + "groupLaw_subtract_mempty" + (groupLaw_subtract_mempty) + , makeLaw1 @a + "groupLaw_subtract_self" + (groupLaw_subtract_self) + , makeLaw2 @a + "groupLaw_subtract_other" + (groupLaw_subtract_other) + , makeLaw1 @a + "groupLaw_pow_zero" + (groupLaw_pow_zero) + , makeLaw1 @a + "groupLaw_pow_nonNegative" + (groupLaw_pow_nonNegative) + , makeLaw1 @a + "groupLaw_pow_nonPositive" + (groupLaw_pow_nonPositive) + ] + +groupLaw_invert_mempty + :: forall a. (Eq a, Show a, Group a) => Proxy a -> Property +groupLaw_invert_mempty _ = + makeProperty + "invert (mempty @a) == (mempty @a)" + (invert (mempty @a) == (mempty @a)) + & report + "mempty @a" + (mempty @a) + & report + "invert (mempty @a)" + (invert (mempty @a)) + +groupLaw_invert_invert + :: forall a. (Eq a, Show a, Group a) => a -> Property +groupLaw_invert_invert a = + makeProperty + "invert (invert a) == a" + (invert (invert a) == a) + & report + "invert a" + (invert a) + & report + "invert (invert a)" + (invert (invert a)) + +groupLaw_invert_mappend_1 + :: forall a. (Eq a, Show a, Group a) => a -> Property +groupLaw_invert_mappend_1 a = + makeProperty + "a <> invert a == mempty" + (a <> invert a == mempty) + & report + "mempty @a" + (mempty @a) + & report + "invert a" + (invert a) + & report + "a <> invert a" + (a <> invert a) + +groupLaw_invert_mappend_2 + :: forall a. (Eq a, Show a, Group a) => a -> Property +groupLaw_invert_mappend_2 a = + makeProperty + "invert a <> a == mempty" + (invert a <> a == mempty) + & report + "mempty @a" + (mempty @a) + & report + "invert a" + (invert a) + & report + "invert a <> a" + (invert a <> a) + +groupLaw_subtract_mempty + :: forall a. (Eq a, Show a, Group a) => a -> Property +groupLaw_subtract_mempty a = + makeProperty + "a ~~ mempty == a" + (a ~~ mempty == a) + & report + "mempty @a" + (mempty @a) + & report + "a ~~ mempty" + (a ~~ mempty) + +groupLaw_subtract_self + :: forall a. (Eq a, Show a, Group a) => a -> Property +groupLaw_subtract_self a = + makeProperty + "a ~~ a == mempty" + (a ~~ a == mempty @a) + & report + "mempty @a" + (mempty @a) + & report + "a ~~ a" + (a ~~ a) + +groupLaw_subtract_other + :: (Eq a, Show a, Group a) => a -> a -> Property +groupLaw_subtract_other a b = + makeProperty + "a ~~ b == a <> invert b" + (a ~~ b == a <> invert b) + & report + "a ~~ b" + (a ~~ b) + & report + "invert b" + (invert b) + & report + "a <> invert b" + (a <> invert b) + +groupLaw_pow_zero + :: forall a. (Eq a, Show a, Group a) => a -> Property +groupLaw_pow_zero a = + makeProperty + "pow a 0 == mempty" + (pow a 0 == mempty) + & report + "pow a 0" + (pow a 0) + & report + "mempty @a" + (mempty @a) + +groupLaw_pow_nonNegative + :: (Eq a, Show a, Group a) => a -> Property +groupLaw_pow_nonNegative a = + forAllShrink (arbitrary @(NonNegative Int)) shrink $ \(NonNegative n) -> + makeProperty + "pow a n == mconcat (replicate n a)" + (pow a n == mconcat (replicate n a)) + & report + "pow a n" + (pow a n) + & report + "mconcat (replicate n a)" + (mconcat (replicate n a)) + & cover + "n == 0" + (n == 0) + & cover + "n == 1" + (n == 1) + & cover + "n == 2" + (n == 2) + & cover + "n == 3" + (n == 3) + & cover + "n >= 4" + (n >= 4) + +groupLaw_pow_nonPositive + :: (Eq a, Show a, Group a) => a -> Property +groupLaw_pow_nonPositive a = + forAllShrink (arbitrary @(NonPositive Int)) shrink $ \(NonPositive n) -> + makeProperty + "pow a n == invert (mconcat (replicate (abs n) a))" + (pow a n == invert (mconcat (replicate (abs n) a))) + & report + "pow a n" + (pow a n) + & report + "mconcat (replicate (abs n) a)" + (mconcat (replicate (abs n) a)) + & report + "invert (mconcat (replicate (abs n) a))" + (invert (mconcat (replicate (abs n) a))) + & cover + "n == -0" + (n == -0) + & cover + "n == -1" + (n == -1) + & cover + "n == -2" + (n == -2) + & cover + "n == -3" + (n == -3) + & cover + "n <= -4" + (n <= -4) + +-------------------------------------------------------------------------------- +-- Abelian +-------------------------------------------------------------------------------- + +-- | 'Laws' for instances of 'Abelian'. +-- +-- Includes the following law: +-- +-- __/Commutativity/__ +-- +-- @ +-- a '<>' b '==' b '<>' a +-- @ +-- +-- == Superclass laws +-- +-- Note that the following superclass laws are __not__ included: +-- +-- * 'Test.QuickCheck.Classes.Group.groupLaws' +-- +abelianLaws + :: forall a. (Arbitrary a, Show a, Eq a, Abelian a) + => Proxy a + -> Laws +abelianLaws _ = Laws "Abelian" + [ makeLaw2 @a + "abelianLaw_commutative" + (abelianLaw_commutative) + ] + +abelianLaw_commutative + :: (Eq a, Show a, Abelian a) => a -> a -> Property +abelianLaw_commutative 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)) 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,90 @@ +{-# LANGUAGE DerivingVia #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +-- | +-- Copyright: © 2022–2023 Jonathan Knowles +-- License: Apache-2.0 +-- +module ClassSpec where + +import Data.Bifunctor + ( bimap ) +import Data.Monoid + ( Product (..), Sum (..) ) +import Data.Ratio + ( denominator, numerator, (%) ) +import Test.Hspec + ( Spec ) +import Test.Hspec.Laws + ( testLawsMany ) +import Test.QuickCheck + ( Arbitrary (..), NonZero (..), Property, choose, oneof ) +import Test.QuickCheck.Classes + ( Laws (..) ) +import Test.QuickCheck.Classes.Group + ( abelianLaws, groupLaws ) +import Test.QuickCheck.Property + ( Result (..), mapTotalResult ) + +spec :: Spec +spec = do + testLawsMany @() $ disableCoverageCheck + [ abelianLaws + , groupLaws + ] + testLawsMany @(Sum TestInteger) + [ abelianLaws + , groupLaws + ] + testLawsMany @(Product TestRational) + [ abelianLaws + , groupLaws + ] + testLawsMany @(Sum TestRational) + [ abelianLaws + , groupLaws + ] + +-------------------------------------------------------------------------------- +-- Test types +-------------------------------------------------------------------------------- + +newtype TestInteger = TestInteger Integer + deriving stock (Eq, Show) + deriving newtype Num + +instance Arbitrary TestInteger where + arbitrary = TestInteger <$> choose (-4, 4) + shrink (TestInteger i) = TestInteger <$> shrink i + +newtype TestRational = TestRational Rational + deriving stock (Eq, Show) + deriving newtype (Num, Fractional) + +instance Arbitrary TestRational where + arbitrary = + fmap TestRational $ (%) <$> genSmall <*> genSmall + where + genSmall = oneof [choose (-4, -1), choose (1, 4)] + shrink (TestRational r) = + TestRational . uncurry (%) . bimap getNonZero getNonZero + <$> shrink (NonZero (numerator r), NonZero (denominator r)) + +-------------------------------------------------------------------------------- +-- Coverage checks +-------------------------------------------------------------------------------- + +class HasCoverageCheck p where + disableCoverageCheck :: p -> p + +instance HasCoverageCheck Laws where + disableCoverageCheck (Laws title laws) = + Laws title $ fmap disableCoverageCheck <$> laws + +instance HasCoverageCheck Property where + disableCoverageCheck = + mapTotalResult (\r -> r {maybeCheckCoverage = Nothing}) + +instance (Functor f, HasCoverageCheck p) => HasCoverageCheck (f p) where + disableCoverageCheck = + fmap disableCoverageCheck 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/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–2023 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