quickcheck-groups (empty) → 0.0.0.0
raw patch · 12 files changed
+1277/−0 lines, 12 filesdep +QuickCheckdep +basedep +groups
Dependencies added: QuickCheck, base, groups, hspec, pretty-show, quickcheck-classes, quickcheck-groups, quickcheck-instances, semigroupoids
Files
- CHANGELOG.md +5/−0
- LICENSE +201/−0
- README.md +76/−0
- quickcheck-groups.cabal +124/−0
- src/internal/Internal.hs +136/−0
- src/internal/Internal/Semigroup/Eq.hs +40/−0
- src/internal/Internal/Semigroup/Tuple.hs +175/−0
- src/prelude/Internal/Prelude.hs +18/−0
- src/public/Test/QuickCheck/Classes/Group.hs +350/−0
- src/test/ClassSpec.hs +90/−0
- src/test/Spec.hs +1/−0
- src/test/Test/Hspec/Laws.hs +61/−0
+ CHANGELOG.md view
@@ -0,0 +1,5 @@+# 0.0.0.0++- Provides support for testing instances of classes defined in the following+ modules:+ - `Data.Group`
+ LICENSE view
@@ -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.
+ README.md view
@@ -0,0 +1,76 @@+# `quickcheck-groups`++<a href="http://jonathanknowles.net/quickcheck-groups/"><img src="https://img.shields.io/badge/API-Documentation-green" /></a>++## 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.
+ quickcheck-groups.cabal view
@@ -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
+ src/internal/Internal.hs view
@@ -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
+ src/internal/Internal/Semigroup/Eq.hs view
@@ -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
+ src/internal/Internal/Semigroup/Tuple.hs view
@@ -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]
+ src/prelude/Internal/Prelude.hs view
@@ -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+ ()
+ src/public/Test/QuickCheck/Classes/Group.hs view
@@ -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))
+ src/test/ClassSpec.hs view
@@ -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
+ src/test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
+ src/test/Test/Hspec/Laws.hs view
@@ -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