hedgehog-classes-0.2.5.4/0000755000000000000000000000000007346545000013256 5ustar0000000000000000hedgehog-classes-0.2.5.4/CHANGELOG.md0000644000000000000000000000454507346545000015077 0ustar0000000000000000# Changelog `hedgehog-classes` uses [PVP Versioning][1]. The changelog is available [on GitHub][2]. Unreleased ======= * Make `Hedgehog.Classes.Aeson` module empty when the `aeson` flag is disabled. * Make `Hedgehog.Classes.Prim` module empty when the `primitive` flag is disabled. 0.2.5.3 ======= * Correct bug in which `storablePeekByte` uses the wrong offset values * Update base upper bound. [4.12, 4.15) -> [4.12, 4.17) * Update semirings upper bound. [0.2, 0.7) -> [0.2, 0.8) * Update aeson upper bound. [0.9, 1.6) -> [0.9, 2.1) 0.2.5.2 ======= * Update semirings upper bound. [0.2, 0.6) -> [0.2, 0.7) 0.2.5.1 ======= * Bump upper bound on pretty-show from <1.10 to <1.11 0.2.5 ===== * Add MUVector laws * Update upper bounds on dependencies 0.2.4.1 ======= * Fix error introduced by change of hedgehog's internal API between hedgehog-1.0.1 and hedgehog-1.0.2. * Re-add GHC 8.8.1 to cabal's tested-with field. 0.2.4 ===== * Semirings upper bound increased to 0.6. [0.2, 0.5) -> [0.2, 0.6) * Add `primLaws`. * Remove GHC 8.8.1 from cabal's tested-with field. * Add documentation to `comonadLaws`. 0.2.3 ===== * Semirings upper bound increased to 0.5. Lower bound not touched. [0.2, 0.4) -> [0.2, 0.5) * Add `comonadLaws`. 0.2.2 ===== * fix problem in storable set-get that caused attempt to index into 0-element malloc'd array * Test suite now tests almost all laws sans arrow/category (thanks @ag-eitilt!) * Correct tcName of `MonadPlus`. Was `Monad`, now it's `MonadPlus`. 0.2.1 ===== * fix problem where ordLaws failed for everything. there was some messed up logic used to check that transitivity held. Thanks very much to @ocharles for reporting this. 0.2.0.1 ======= * improve reliability of hedgehog output filtering. 0.2 === * switch to hedgehog-1.0 * add `binaryLaws` * relax cabal-version to 2.2 * use randomly generated, not hard-coded functions, in bifoldable tests * significantly simplify pretty printing using `silently` package, and bad hack. * make several haddock improvements. 0.1.2 ===== * add `semiringLaws`, `ringLaws`, `starLaws` * fix bug in `foldableLaws` that could cause implementations of `foldMap` and `fold` that evaluate in weird orders to pass (rather than fail). 0.1.1 ===== * Initial (stable) hackage release. 0.0.0 ===== * Initially created. [1]: https://pvp.haskell.org [2]: https://github.com/chessai/hedgehog-classes/releases hedgehog-classes-0.2.5.4/LICENSE0000644000000000000000000000274307346545000014271 0ustar0000000000000000BSD 3-Clause License Copyright (c) 2020, chessai All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. * Neither the name of the copyright holder nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. hedgehog-classes-0.2.5.4/README.md0000644000000000000000000001410407346545000014535 0ustar0000000000000000hedgehog-classes [![Hackage][hackage-shield]][hackage] ================ > Hedgehog will eat your typeclass bugs. ## Motivation `hedgehog-classes` is a wrapper around [Hedgehog](http://hedgehog.qa/) that aims to provide a simple, straightforward API for testing common typeclass laws quickly, while providing good error messages to help debug any failing tests. It is inspired by the [quickcheck-classes](http://hackage.haskell.org/package/quickcheck-classes) library. ## API Overview The API of `hedgehog-classes` is dead simple. There are three parts. The first part is a datatype, called 'Laws', which looks like this: ```haskell data Laws = Laws { lawsTypeclass :: String , lawsProperties :: [(String,Property)] } ``` It is a typeclass name along with a list of named property tests. The second part of `hedgehog-classes` are the functions, which follow a simple structure. All functions in `hedgehog-classes` have one of the following three type signatures, based on the kind of the type which the corresponding typeclass parameterises (Nullary, Unary, or Binary). Note that they all return a 'Laws', only the inputs are different. Below, 'Ctx' refers to the typeclass in question: ```haskell -- Typeclasses that have kind 'Type -> Constraint', e.g. 'Eq' tcLaw :: (Ctx a, Eq a, Show a) => Gen a -> Laws -- Typeclasses that have kind '(Type -> Type) -> Constraint', e.g. 'Functor' tcLaw1 :: ( Ctx f , forall x. Eq x => Eq (f x) , forall x. Show x => Show (f x) ) => (forall x. Gen x -> Gen (f x)) -> Laws -- Typeclasses that have kind '(Type -> Type -> Type) -> Constraint', e.g. 'Bifunctor' tcLaw2 :: ( Ctx f , forall x y. (Eq x, Eq y) => Eq (f x y) , forall x y. (Show x, Show y) => Show (f x y) ) => (forall x y. Gen x -> Gen y -> Gen (f x y)) -> Laws ``` The third and last part of `hedgehog-classes` are the three convenience functions used to run your tests. They all return an `IO Bool`, where `True` is returned if all the tests pass, and `False` otherwise. They are as following: ```haskell -- Test a single typeclasses' laws. lawsCheck :: Laws -> IO Bool -- Test multiple typeclass laws for a single type. lawsCheckOne :: Gen a -> [Gen a -> Laws] -> IO Bool -- Test mutliple typeclass laws for multiple types. -- The argument is pairs of type names and their associated laws to test. lawsCheckMany :: [(String, [Laws])] -> IO Bool ``` That is all there is to using `hedgehog-classes` in your test suite. For usage examples, see the [haddocks](http://hackage.haskell.org/package/hedgehog-classes). ## Distributing your own `Laws` `hedgehog-classes` also exports some functions which you may find useful for writing functions that allow users to test the laws of typeclasses you define in your own libraries, along with utilities for providing custom error messages. They can be found [here](http://hackage.haskell.org/package/hedgehog-classes-0.1.0.0/docs/Hedgehog.-Classes.html#g:6). ## Example error messages Below is an example of an error message one might get from a failed test from `hedgehog-classes`: ![alt text](imgs/badlist.png "Here we can see a definition of foldl' that does not accumulate strictly") ![alt text](imgs/badsemigroup.png "Here we can see a semigroup instance which is not associative") ## Similar libraries There are a number of libraries that have similar goals to `hedgehog-classes`: - [hedgehog-checkers](https://github.com/bitemyapp/hedgehog-checkers): - [hedgehog-laws](https://github.com/qfpl/hedgehog-laws): ## Supported Typeclasses - `base` - Alternative - Applicative - Arrow - Bifoldable - Bifunctor - Bitraversable - Bits/FiniteBits - Category - Contravariant - Enum - Eq - Foldable - Functor - Generic - Integral - Monad - MonadIO - MonadPlus - MonadZip - Ord - Semigroup - Show - ShowRead - Storable - Traversable - `aeson` - ToJSON - ToJSON/FromJSON - `comonad` - Comonad - `semirings` - Semiring - Ring - `primitive` - Prim Some typeclasses can have additional laws, which are not part of their sufficient definition. A common example is commutativity of a monoid. In such cases where this is sensible, `hedgehog-classes` provides functions such `commutativeMonoidLaws`, `commutativeSemigroupLaws`, etc. `hedgehog-classes` also tests that `foldl'`/`foldr'` actually accumulate strictly. There are other such cases that are documented on Hackage. Support will be added for the typeclasses from [semigroupoids](http://hackage.haskell.org/package/semigroupoids). Support will be added for the `Semiring`/`Ring` typeclasses from [semirings](http://hackage.haskell.org/package/semirings). ## Building Currently, you need GHC >= 8.5 to build this (because of `-XQuantifiedConstraints`). Some CPP can be used to make this buildable with older GHCs, I just have not done so yet. I would gladly take a PR that does so, but only for GHC 8.2.2 and newer. To use this library for testing, just add it to a test stanza of your cabal file. To use this library to export your own `Laws` functions which you wish to distribute, add it to the library stanza of your cabal file. [hackage]: http://hackage.haskell.org/package/hedgehog-classes [hackage-shield]: https://img.shields.io/badge/hackage-v0.2.4.1-blue.svg ## Improvements There are a number of improvements that can be made to the API of `hedgehog-classes`: - Traversable needs better error messages, without exposing library internals. - Arrow Laws 5/6/7 need names. - Some laws could use better names, as some of them I had to make up. - ixLaws can accidentally be extremely inefficient and I'm not sure how to fix that. - The test suite is incomplete. - There is no 'bad' test suite, for testing error messages. - There could be spelling mistakes/grammatical errors/inconsistencies in the custom error messages. You can help fix any of the above by opening an issue/PR! Thanks. hedgehog-classes-0.2.5.4/hedgehog-classes.cabal0000644000000000000000000001325107346545000017451 0ustar0000000000000000cabal-version: 2.2 name: hedgehog-classes version: 0.2.5.4 synopsis: Hedgehog will eat your typeclass bugs description: This library provides Hedgehog properties to ensure that typeclass instances adhere to the set of laws that they are supposed to. There are other libraries that do similar things, such as `genvalidity-hspec` and `checkers`. This library differs from other solutions by not introducing any new typeclasses that the user needs to learn, and otherwise minimal API overhead. . This library is directly inspired by `quickcheck-classes`. homepage: https://github.com/hedgehogqa/haskell-hedgehog-classes bug-reports: https://github.com/hedgehogqa/haskell-hedgehog-classes/issues license: BSD-3-Clause license-file: LICENSE author: chessai maintainer: chessai1996@gmail.com copyright: 2020 chessai category: Testing build-type: Simple extra-doc-files: README.md , CHANGELOG.md tested-with: GHC == 8.6.5 , GHC == 8.8.3 , GHC == 8.10.1 , GHC == 9.0.1 , GHC == 9.2.4 , GHC == 9.4.2 source-repository head type: git location: https://github.com/hedgehogqa/haskell-hedgehog-classes.git flag aeson description: You can disable the use of the `aeson` package using `-f-aeson`. . This may be useful for accelerating builds in sandboxes for expert users. default: True manual: True -- flag semigroupoids -- description: -- You can disable the use of the `semigroupoids` package using `-f-semigroupoids`. -- . -- This may be useful for accelerating builds in sandboxes for expert users. -- default: True -- manual: True flag comonad description: You can disable the use of the `comonad` package using `-f-comonad`. . This may be useful for accelerating builds in sandboxes for expert users. default: True manual: True flag semirings description: You can disable the use of the `semirings` package using `-f-semirings`. . This may be useful for accelerating builds in sandboxes for expert users. default: True manual: True flag primitive description: You can disable the use of the `primitive` package using `-f-primitive`. . This may be useful for accelerating builds in sandboxes for expert users. default: True manual: True flag vector description: You can disable the use of the `vector` package using `-f-vector`. . This may be useful for accelerating builds in sandboxes for expert users. default: True manual: True library hs-source-dirs: src exposed-modules: Hedgehog.Classes other-modules: Hedgehog.Classes.Alternative Hedgehog.Classes.Applicative Hedgehog.Classes.Arrow Hedgehog.Classes.Bifoldable Hedgehog.Classes.Bifunctor Hedgehog.Classes.Binary Hedgehog.Classes.Bitraversable Hedgehog.Classes.Bits Hedgehog.Classes.Category Hedgehog.Classes.Common Hedgehog.Classes.Common.ApTrans Hedgehog.Classes.Common.Bottom Hedgehog.Classes.Common.Compat Hedgehog.Classes.Common.Equation Hedgehog.Classes.Common.Func Hedgehog.Classes.Common.Gen Hedgehog.Classes.Common.IO Hedgehog.Classes.Common.Laws Hedgehog.Classes.Common.Property Hedgehog.Classes.Common.PP Hedgehog.Classes.Comonad Hedgehog.Classes.Contravariant Hedgehog.Classes.Enum Hedgehog.Classes.Eq Hedgehog.Classes.Foldable Hedgehog.Classes.Functor Hedgehog.Classes.Generic Hedgehog.Classes.Integral -- Hedgehog.Classes.Ix Hedgehog.Classes.Json Hedgehog.Classes.Monad -- Hedgehog.Classes.MonadFix Hedgehog.Classes.MonadIO Hedgehog.Classes.MonadPlus Hedgehog.Classes.MonadZip Hedgehog.Classes.Monoid Hedgehog.Classes.MVector Hedgehog.Classes.Ord Hedgehog.Classes.Prim Hedgehog.Classes.Semigroup Hedgehog.Classes.Semiring Hedgehog.Classes.Show Hedgehog.Classes.ShowRead Hedgehog.Classes.Storable Hedgehog.Classes.Traversable build-depends: , base >= 4.12 && < 4.18 , binary >= 0.8 && < 0.9 , containers >= 0.5 && < 0.7 , hedgehog >= 1 && < 1.3 , pretty-show >= 1.9 && < 1.11 , silently >= 1.2 && < 1.3 , transformers >= 0.5 && < 0.6 , wl-pprint-annotated >= 0.0 && < 0.2 ghc-options: -Wall default-language: Haskell2010 if flag(aeson) build-depends: aeson >= 0.9 && < 2.2 cpp-options: -DHAVE_AESON -- if flag(semigroupoids) -- build-depends: semigroupoids >= 0.5.3.0 && < 0.6.0.0 -- cpp-options: -DHAVE_SEMIGROUPOIDS if flag(semirings) build-depends: semirings >= 0.2 && < 0.8 cpp-options: -DHAVE_SEMIRINGS if flag(comonad) build-depends: comonad >= 5.0 && < 5.1 cpp-options: -DHAVE_COMONAD if flag(vector) build-depends: vector >= 0.12 && < 0.14 cpp-options: -DHAVE_VECTOR if flag(primitive) build-depends: primitive >= 0.6.4 && < 0.8 cpp-options: -DHAVE_PRIMITIVE test-suite spec type: exitcode-stdio-1.0 hs-source-dirs: test main-is: Spec.hs other-modules: Spec.Alternative Spec.Applicative Spec.Arrow Spec.Bifoldable Spec.Bifunctor Spec.Binary Spec.Bitraversable Spec.Bits Spec.Category Spec.Comonad Spec.Contravariant Spec.Enum Spec.Eq Spec.Foldable Spec.Functor Spec.Generic Spec.Integral -- Spec.Ix Spec.Json Spec.Monad Spec.Monoid Spec.MVector Spec.Ord Spec.Prim Spec.Semigroup Spec.Semiring Spec.Show Spec.Storable Spec.Traversable build-depends: , aeson , base , binary , comonad , containers , hedgehog , hedgehog-classes ghc-options: -Wall default-language: Haskell2010 if flag(vector) build-depends: vector cpp-options: -DHAVE_VECTOR hedgehog-classes-0.2.5.4/src/Hedgehog/0000755000000000000000000000000007346545000015557 5ustar0000000000000000hedgehog-classes-0.2.5.4/src/Hedgehog/Classes.hs0000644000000000000000000000706107346545000017514 0ustar0000000000000000{-# language CPP #-} {-| This library provides sets of properties that should hold for common typeclasses. /Note:/ functions that test laws of a subclass never test the laws of a superclass. For example, 'commutativeSemigroupLaws' never tests the laws provided by 'semigroupLaws'. -} module Hedgehog.Classes ( -- * Running lawsCheck , lawsCheckOne , lawsCheckMany -- * Properties -- ** Ground types , binaryLaws , bitsLaws , eqLaws , integralLaws , monoidLaws , commutativeMonoidLaws , ordLaws -- , ixLaws , enumLaws , boundedEnumLaws , semigroupLaws , commutativeSemigroupLaws , exponentialSemigroupLaws , idempotentSemigroupLaws , rectangularBandSemigroupLaws #if HAVE_AESON , jsonLaws #endif , genericLaws #if HAVE_PRIMITIVE , primLaws #endif #if HAVE_SEMIRINGS , semiringLaws , ringLaws , starLaws #endif , showLaws , showReadLaws , storableLaws #if HAVE_VECTOR , muvectorLaws #endif -- ** Unary type constructors , alternativeLaws , applicativeLaws #ifdef HAVE_COMONAD , comonadLaws #endif , contravariantLaws , foldableLaws , functorLaws , monadLaws -- , monadFixLaws , monadIOLaws , monadPlusLaws , monadZipLaws , traversableLaws -- ** Binary type constructors , arrowLaws , bifoldableLaws , bifoldableFunctorLaws , bifunctorLaws , bitraversableLaws , categoryLaws , commutativeCategoryLaws -- * Defining your own 'Laws' , Laws(..) , LawContext(..) , Context(..) , contextualise -- * Hedgehog equality tests sans source information , hLessThan, hGreaterThan , heq, heq1, heq2 , heqCtx, heqCtx1, heqCtx2 , hneq, hneq1, hneq2 , hneqCtx, hneqCtx1, hneqCtx2 ) where import Hedgehog.Classes.Alternative (alternativeLaws) import Hedgehog.Classes.Applicative (applicativeLaws) import Hedgehog.Classes.Arrow (arrowLaws) import Hedgehog.Classes.Bifoldable (bifoldableLaws, bifoldableFunctorLaws) import Hedgehog.Classes.Bifunctor (bifunctorLaws) import Hedgehog.Classes.Binary (binaryLaws) import Hedgehog.Classes.Bitraversable (bitraversableLaws) import Hedgehog.Classes.Bits (bitsLaws) import Hedgehog.Classes.Category (categoryLaws, commutativeCategoryLaws) import Hedgehog.Classes.Common #ifdef HAVE_COMONAD import Hedgehog.Classes.Comonad (comonadLaws) #endif import Hedgehog.Classes.Contravariant (contravariantLaws) import Hedgehog.Classes.Enum (enumLaws, boundedEnumLaws) import Hedgehog.Classes.Eq (eqLaws) import Hedgehog.Classes.Foldable (foldableLaws) import Hedgehog.Classes.Functor (functorLaws) import Hedgehog.Classes.Generic (genericLaws) import Hedgehog.Classes.Integral (integralLaws) --import Hedgehog.Classes.Ix (ixLaws) #if HAVE_AESON import Hedgehog.Classes.Json (jsonLaws) #endif import Hedgehog.Classes.Monad (monadLaws) import Hedgehog.Classes.MonadIO (monadIOLaws) import Hedgehog.Classes.MonadPlus (monadPlusLaws) import Hedgehog.Classes.MonadZip (monadZipLaws) import Hedgehog.Classes.Monoid (monoidLaws, commutativeMonoidLaws) #if HAVE_VECTOR import Hedgehog.Classes.MVector (muvectorLaws) #endif import Hedgehog.Classes.Ord (ordLaws) #if HAVE_PRIMITIVE import Hedgehog.Classes.Prim (primLaws) #endif import Hedgehog.Classes.Semigroup (semigroupLaws, commutativeSemigroupLaws, exponentialSemigroupLaws, idempotentSemigroupLaws, rectangularBandSemigroupLaws) #if HAVE_SEMIRINGS import Hedgehog.Classes.Semiring (semiringLaws, ringLaws, starLaws) #endif import Hedgehog.Classes.Show (showLaws) import Hedgehog.Classes.ShowRead (showReadLaws) import Hedgehog.Classes.Storable (storableLaws) import Hedgehog.Classes.Traversable (traversableLaws) hedgehog-classes-0.2.5.4/src/Hedgehog/Classes/0000755000000000000000000000000007346545000017154 5ustar0000000000000000hedgehog-classes-0.2.5.4/src/Hedgehog/Classes/Alternative.hs0000644000000000000000000000601607346545000021771 0ustar0000000000000000{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE QuantifiedConstraints #-} {-# LANGUAGE RankNTypes #-} module Hedgehog.Classes.Alternative (alternativeLaws) where import Control.Applicative (Alternative(..)) import Hedgehog import Hedgehog.Classes.Common -- | Tests the following 'Alternative' laws: -- -- [__Left Identity__]: @'empty' '<|>' a@ ≡ @a@ -- [__Right Identity__]: @a '<|>' 'empty'@ ≡ @a@ -- [__Associativity__]: @a '<|>' (b '<|>' c)@ ≡ @(a '<|>' b) '<|>' c@ alternativeLaws :: ( Alternative f , forall x. Eq x => Eq (f x), forall x. Show x => Show (f x) ) => (forall x. Gen x -> Gen (f x)) -> Laws alternativeLaws gen = Laws "Alternative" [ ("Left Identity", alternativeLeftIdentity gen) , ("Right Identity", alternativeRightIdentity gen) , ("Associativity", alternativeAssociativity gen) ] type AlternativeProp f = ( Alternative f , forall x. Eq x => Eq (f x), forall x. Show x => Show (f x) ) => (forall x. Gen x -> Gen (f x)) -> Property alternativeLeftIdentity :: forall f. AlternativeProp f alternativeLeftIdentity fgen = property $ do a <- forAll $ fgen genSmallInteger let lhs = empty <|> a let rhs = a let ctx = contextualise $ LawContext { lawContextLawName = "Left Identity", lawContextLawBody = "empty <|> a" `congruency` "a" , lawContextTcName = "Alternative", lawContextTcProp = let showA = show a; in lawWhere [ "empty <|> a" `congruency` "a, where" , "a = " ++ showA ] , lawContextReduced = reduced lhs rhs } heqCtx1 lhs rhs ctx alternativeRightIdentity :: forall f. AlternativeProp f alternativeRightIdentity fgen = property $ do a <- forAll $ fgen genSmallInteger let lhs = a <|> empty let rhs = a let ctx = contextualise $ LawContext { lawContextLawName = "Right Identity", lawContextLawBody = "a <|> empty" `congruency` "a" , lawContextTcName = "Alternative", lawContextTcProp = let showA = show a; in lawWhere [ "a <|> empty" `congruency` "a, where" , "a = " ++ showA ] , lawContextReduced = reduced lhs rhs } heqCtx1 lhs rhs ctx alternativeAssociativity :: forall f. AlternativeProp f alternativeAssociativity fgen = property $ do a <- forAll $ fgen genSmallInteger b <- forAll $ fgen genSmallInteger c <- forAll $ fgen genSmallInteger let lhs = (a <|> (b <|> c)) let rhs = ((a <|> b) <|> c) let ctx = contextualise $ LawContext { lawContextLawName = "Associativity", lawContextLawBody = "a <|> (b <|> c)" `congruency` "(a <|> b) <|> c" , lawContextTcName = "Alternative", lawContextTcProp = let showA = show a; showB = show b; showC = show c; in lawWhere [ "a <|> (b <|> c)" `congruency` "(a <|> b) <|> c), where" , "a = " ++ showA , "b = " ++ showB , "c = " ++ showC ] , lawContextReduced = reduced lhs rhs } heqCtx1 lhs rhs ctx hedgehog-classes-0.2.5.4/src/Hedgehog/Classes/Applicative.hs0000644000000000000000000001364707346545000021764 0ustar0000000000000000{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE QuantifiedConstraints #-} {-# LANGUAGE RankNTypes #-} module Hedgehog.Classes.Applicative (applicativeLaws) where import Control.Applicative (Applicative(..)) import Hedgehog import Hedgehog.Classes.Common -- | Tests the following 'Applicative' laws: -- -- [__Identity__]: @'pure' 'id' '<*>' v@ ≡ @v@ -- [__Composition__]: @'pure' ('.') '<*>' u '<*>' v '<*>' w@ ≡ @u '<*>' (v '<*>' w)@ -- [__Homomorphism__]: @'pure' f '<*>' 'pure'@ x ≡ @'pure' (f x)@ -- [__Interchange__]: @u '<*>' 'pure' y@ ≡ @'pure' ('$' y) '<*>' u@ -- [__LiftA2 1__]: @'liftA2' 'id' f x@ ≡ @f '<*>' x@ -- [__LiftA2 2__]: @'liftA2' f x y@ ≡ @f '<$>' x '<*>' y@ applicativeLaws :: ( Applicative f , forall x. Eq x => Eq (f x), forall x. Show x => Show (f x) ) => (forall x. Gen x -> Gen (f x)) -> Laws applicativeLaws gen = Laws "Applicative" [ ("Identity", applicativeIdentity gen) , ("Composition", applicativeComposition gen) , ("Homomorphism", applicativeHomomorphism gen) , ("Interchange", applicativeInterchange gen) , ("LiftA2 Part 1", applicativeLiftA2_1 gen) , ("LiftA2 Part 2", applicativeLiftA2_2 gen) ] type ApplicativeProp f = ( Applicative f , forall x. Eq x => Eq (f x), forall x. Show x => Show (f x) ) => (forall x. Gen x -> Gen (f x)) -> Property applicativeIdentity :: forall f. ApplicativeProp f applicativeIdentity fgen = property $ do a <- forAll $ fgen genSmallInteger let lhs = pure id <*> a let rhs = a let ctx = contextualise $ LawContext { lawContextLawName = "Identity", lawContextLawBody = "pure id <*> v" `congruency` "v" , lawContextTcName = "Applicative", lawContextTcProp = let showA = show a in lawWhere [ "pure id <*> v" `congruency` "v, where" , "v = " ++ showA ] , lawContextReduced = reduced lhs rhs } heqCtx1 lhs rhs ctx applicativeComposition :: forall f. ApplicativeProp f applicativeComposition fgen = property $ do u' <- forAll $ fgen genQuadraticEquation v' <- forAll $ fgen genQuadraticEquation w' <- forAll genSmallInteger let u = runQuadraticEquation <$> u' v = runQuadraticEquation <$> v' w = pure w' let lhs = pure (.) <*> u <*> v <*> w let rhs = u <*> (v <*> w) let ctx = contextualise $ LawContext { lawContextLawName = "Composition", lawContextLawBody = "pure (.) <*> u <*> v <*> w == u <*> (v <*> w)" , lawContextTcName = "Applicative", lawContextTcProp = let showU = show u'; showV = show v'; showW = show w'; in lawWhere [ "pure (.) <*> u <*> v <*> w", congruent, "u <*> (v <*> w), where" , "u = " ++ showU , "v = " ++ showV , "w = " ++ showW ] , lawContextReduced = reduced lhs rhs } heqCtx1 lhs rhs ctx applicativeHomomorphism :: forall f. ApplicativeProp f applicativeHomomorphism _ = property $ do e <- forAll genQuadraticEquation a <- forAll genSmallInteger let f = runQuadraticEquation e let lhs = pure f <*> pure a let rhs = pure (f a) :: f Integer let ctx = contextualise $ LawContext { lawContextLawName = "Homomorphism", lawContextLawBody = "pure f <*> pure x" `congruency` "pure (f x)" , lawContextTcName = "Applicative", lawContextTcProp = let showF = show e; showX = show a; in lawWhere [ "pure f <*> pure x", congruent, "pure (f x), where" , "f = " ++ showF , "x = " ++ showX ] , lawContextReduced = reduced lhs rhs } heqCtx1 lhs rhs ctx applicativeInterchange :: forall f. ApplicativeProp f applicativeInterchange fgen = property $ do u' <- forAll $ fgen genQuadraticEquation y <- forAll genSmallInteger let u = fmap runQuadraticEquation u' let lhs = (u <*> pure y) let rhs = pure ($ y) <*> u let ctx = contextualise $ LawContext { lawContextLawName = "Interchange", lawContextLawBody = "u <*> pure y" `congruency` "pure ($ y) <*> u" , lawContextTcName = "Applicative", lawContextTcProp = let showU = show u'; showY = show y; in lawWhere [ "u <*> pure y", congruent, "pure ($ y) <*> u, where" , "u = " ++ showU , "y = " ++ showY ] , lawContextReduced = reduced lhs rhs } heqCtx1 lhs rhs ctx applicativeLiftA2_1 :: forall f. ApplicativeProp f applicativeLiftA2_1 fgen = property $ do f' <- forAll $ fgen genQuadraticEquation x <- forAll $ fgen genSmallInteger let f = fmap runQuadraticEquation f' let lhs = liftA2 id f x let rhs = f <*> x let ctx = contextualise $ LawContext { lawContextLawName = "LiftA2 1", lawContextLawBody = "liftA2 id f x" `congruency` "f <*> x" , lawContextTcName = "Applicative", lawContextTcProp = let showF = show f'; showX = show x; in lawWhere [ "liftA2 id f x", congruent, "f <*> x, where" , "f = " ++ showF , "x = " ++ showX ] , lawContextReduced = reduced lhs rhs } heqCtx1 lhs rhs ctx applicativeLiftA2_2 :: forall f. ApplicativeProp f applicativeLiftA2_2 fgen = property $ do x <- forAll $ fgen genSmallInteger y <- forAll $ fgen genSmallInteger f' <- forAll $ genLinearEquationTwo let f = runLinearEquationTwo f' let lhs = liftA2 f x y let rhs = f <$> x <*> y let ctx = contextualise $ LawContext { lawContextLawName = "LiftA2 2", lawContextLawBody = "liftA2 f x y == f <$> x <*> y" , lawContextTcName = "Applicative", lawContextTcProp = let showF = show f'; showX = show x; showY = show y; in lawWhere [ "liftA2 f x y" `congruency` "f <$> x <*> y, where" , "f = " ++ showF , "x = " ++ showX , "y = " ++ showY ] , lawContextReduced = reduced lhs rhs } heqCtx1 lhs rhs ctx hedgehog-classes-0.2.5.4/src/Hedgehog/Classes/Arrow.hs0000644000000000000000000000706707346545000020614 0ustar0000000000000000{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE QuantifiedConstraints #-} module Hedgehog.Classes.Arrow (arrowLaws) where import Hedgehog import Hedgehog.Classes.Common import Control.Arrow(Arrow(..), (>>>)) import Control.Category(Category(..)) import Prelude hiding (id, (.)) import qualified Prelude -- | Tests the following 'Arrow' laws: -- -- [__Arr Identity__]: @'arr' 'id'@ ≡ @'id'@ -- [__Arr Composition__]: @'arr' (f '>>>' g)@ ≡ @'arr' f '>>>' 'arr' g@ -- [__Arr-First inverse__]: @'first' ('arr' f)@ ≡ @'arr' ('first' f)@ -- [__First Composition__]: @'first' (f '>>>' g)@ ≡ @'first' f '>>>' 'first' g@ -- [__Arrow Law 5__]: @'first' f '>>>' 'arr' 'fst'@ ≡ @'arr' 'fst' '>>>' f@ -- [__Arrow Law 6__]: @'first' f '>>>' 'arr' ('id' '***' g)@ ≡ @'arr' ('id' '***' g) '>>>' 'first' f@ -- [__Arrow Law 7__]: @'first' ('first' f) '>>>' 'arr' assoc@ ≡ @'arr' assoc '>>>' 'first' f, where assoc ((a,b),c) = (a,(b,c))@ arrowLaws :: forall f. ( Arrow f , forall x y. (Eq x, Eq y) => Eq (f x y) , forall x y. (Show x, Show y) => Show (f x y) ) => (forall x y. Gen x -> Gen y -> Gen (f x y)) -> Laws arrowLaws gen = Laws "Arrow" [ ("Arr Identity", arrowLaw1 gen) , ("Arr Composition", arrowLaw2 gen) , ("Arr . First == First . Arr", arrowLaw3 gen) , ("First Composition", arrowLaw4 gen) , ("Arrow Law 5", arrowLaw5 gen) , ("Arrow Law 6", arrowLaw6 gen) , ("Arrow Law 7", arrowLaw7 gen) ] type ArrowProp f = ( Arrow f , forall x y. (Eq x, Eq y) => Eq (f x y) , forall x y. (Show x, Show y) => Show (f x y) ) => (forall x y. Gen x -> Gen y -> Gen (f x y)) -> Property arrowLaw1 :: forall f. ArrowProp f arrowLaw1 _ = property $ do arr Prelude.id `heq2` (id :: f Integer Integer) arrowLaw2 :: forall f. ArrowProp f arrowLaw2 _ = property $ do f' <- forAll genQuadraticEquation g' <- forAll genQuadraticEquation let f = runQuadraticEquation f' g = runQuadraticEquation g' (arr (f >>> g) :: f Integer Integer) `heq2` (arr f >>> arr g) arrowLaw3 :: forall f. ArrowProp f arrowLaw3 _ = property $ do f' <- forAll genQuadraticEquation let f = runQuadraticEquation f' let x = first (arr f) :: f (Integer, Integer) (Integer, Integer) let y = arr (first f) :: f (Integer, Integer) (Integer, Integer) x `heq2` y arrowLaw4 :: forall f. ArrowProp f arrowLaw4 fgen = property $ do f <- forAll $ fgen genSmallInteger genSmallInteger g <- forAll $ fgen genSmallInteger genSmallInteger let x = first (f >>> g) :: f (Integer, Integer) (Integer, Integer) let y = first f >>> first g :: f (Integer, Integer) (Integer, Integer) x `heq2` y arrowLaw5 :: forall f. ArrowProp f arrowLaw5 fgen = property $ do f <- forAll $ fgen genSmallInteger genSmallInteger let x = first f >>> arr fst :: f (Integer, Integer) Integer let y = arr fst >>> f :: f (Integer, Integer) Integer x `heq2` y arrowLaw6 :: forall f. ArrowProp f arrowLaw6 fgen = property $ do f <- forAll $ fgen genSmallInteger genSmallInteger g' <- forAll genQuadraticEquation let g = runQuadraticEquation g' let x = ((first f) >>> (arr (Prelude.id *** g))) :: f (Integer, Integer) (Integer, Integer) let y = arr (id *** g) >>> first f :: f (Integer, Integer) (Integer, Integer) x `heq2` y arrowLaw7 :: forall f. ArrowProp f arrowLaw7 fgen = property $ do let assoc ((a,b),c) = (a,(b,c)) f <- forAll $ fgen genSmallInteger genSmallInteger let x = first (first f) >>> arr assoc :: f ((Integer, Integer), Integer) (Integer, (Integer, Integer)) let y = arr assoc >>> first f :: f ((Integer, Integer), Integer) (Integer, (Integer, Integer)) x `heq2` y hedgehog-classes-0.2.5.4/src/Hedgehog/Classes/Bifoldable.hs0000644000000000000000000001504007346545000021533 0ustar0000000000000000{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE QuantifiedConstraints #-} module Hedgehog.Classes.Bifoldable (bifoldableLaws, bifoldableFunctorLaws) where import Hedgehog import Hedgehog.Classes.Common import Data.Bifoldable (Bifoldable(..)) import Data.Bifunctor (Bifunctor(..)) import Data.Monoid (Endo(..), Sum(..), Product(..)) -- | Tests the following 'Bifoldable' laws: -- -- [__Identity__]: @'bifold'@ ≡ @'bifoldMap' 'id' 'id'@ -- [__FoldMap__]: @'bifoldMap' f g@ ≡ @'bifoldr' ('mappend' '.' f) ('mappend' '.' g) 'mempty'@ -- [__Foldr__]: @'bifoldr' f g z t@ ≡ @'appEndo' ('bifoldMap' ('Endo' '.' f) ('Endo' '.' g) t) z@ bifoldableLaws :: forall f. ( Bifoldable f , forall x y. (Eq x, Eq y) => Eq (f x y) , forall x y. (Show x, Show y) => Show (f x y) ) => (forall x y. Gen x -> Gen y -> Gen (f x y)) -> Laws bifoldableLaws gen = Laws "Bifoldable" [ ("Identity", bifoldableIdentity gen) , ("FoldMap", bifoldableFoldMap gen) , ("Foldr", bifoldableFoldr gen) ] -- | Tests the following 'Bifoldable' / 'Bifunctor' laws: -- -- [__Composition__]: @'bifoldMap' f g@ ≡ @'bifold' '.' 'bimap' f g@ -- [__FoldMap__]: @'bifoldMap' f g '.' 'bimap' h i@ ≡ @'bifoldMap' (f '.' h) (g '.' i)@ bifoldableFunctorLaws :: forall f. ( Bifoldable f, Bifunctor f , forall x y. (Eq x, Eq y) => Eq (f x y) , forall x y. (Show x, Show y) => Show (f x y) ) => (forall x y. Gen x -> Gen y -> Gen (f x y)) -> Laws bifoldableFunctorLaws gen = Laws "Bifoldable/Bifunctor" [ ("Composition", bifoldableFunctorComposition gen) , ("FoldMap", bifoldableFunctorFoldMap gen) ] type BifoldableProp f = ( Bifoldable f , forall x y. (Eq x, Eq y) => Eq (f x y) , forall x y. (Show x, Show y) => Show (f x y) ) => (forall x y. Gen x -> Gen y -> Gen (f x y)) -> Property bifoldableIdentity :: forall f. BifoldableProp f bifoldableIdentity fgen = property $ do x <- forAll $ fgen genSmallSum genSmallSum let lhs = bifold x let rhs = bifoldMap id id x let ctx = contextualise $ LawContext { lawContextLawName = "Identity", lawContextLawBody = "bifold" `congruency` "bifoldMap id id" , lawContextTcName = "Bifoldable", lawContextTcProp = let showX = show x; in lawWhere [ "bimap id id x" `congruency` "x, where" , "x = " ++ showX ] , lawContextReduced = reduced lhs rhs } heqCtx lhs rhs ctx bifoldableFoldMap :: forall f. BifoldableProp f bifoldableFoldMap fgen = property $ do x <- forAll $ fgen genSmallInteger genSmallInteger f' <- forAll genQuadraticEquation g' <- forAll genQuadraticEquation let f = Sum . runQuadraticEquation f' let g = Sum . runQuadraticEquation g' let lhs = (bifoldMap f g x) let rhs = (bifoldr (mappend . f) (mappend . g) mempty x) let ctx = contextualise $ LawContext { lawContextLawName = "FoldMap", lawContextLawBody = "bifoldMap f g" `congruency` "bifoldr (mappend . f) (mappend . g) mempty" , lawContextTcName = "Bifoldable", lawContextTcProp = let showX = show x; showF = show f'; showG = show g'; in lawWhere [ "bifoldMap f g x" `congruency` "bifoldr (mappend . f) (mappend . g) mempty x, where" , "f = " ++ showF , "g = " ++ showG , "x = " ++ showX ] , lawContextReduced = reduced lhs rhs } heqCtx lhs rhs ctx bifoldableFoldr :: forall f. BifoldableProp f bifoldableFoldr fgen = property $ do x <- forAll $ fgen genSmallInteger genSmallInteger f' <- forAll genLinearEquationTwo g' <- forAll genLinearEquationTwo let f = runLinearEquationTwo f' let g = runLinearEquationTwo g' let z0 = 0 let lhs = (bifoldr f g z0 x) let rhs = (appEndo (bifoldMap (Endo . f) (Endo . g) x) z0) let ctx = contextualise $ LawContext { lawContextLawName = "Foldr", lawContextLawBody = "bifoldr f g z t" `congruency` "appEndo (bifoldMap (Endo . f) (Endo . g) t) z" , lawContextTcName = "Bifoldable", lawContextTcProp = let showX = show x; showF = show f'; showG = show g'; showZ = show z0; in lawWhere [ "bifoldr f g z t" `congruency` "appEndo (bifoldMap (Endo . f) (Endo . g) t z, where" , "f = " ++ showF , "g = " ++ showG , "t = " ++ showX , "z = " ++ showZ ] , lawContextReduced = reduced lhs rhs } heqCtx lhs rhs ctx type BifoldableFunctorProp f = ( Bifoldable f, Bifunctor f , forall x y. (Eq x, Eq y) => Eq (f x y) , forall x y. (Show x, Show y) => Show (f x y) ) => (forall x y. Gen x -> Gen y -> Gen (f x y)) -> Property bifoldableFunctorComposition :: forall f. BifoldableFunctorProp f bifoldableFunctorComposition fgen = property $ do x <- forAll $ fgen genSmallSum genSmallSum let f = Product; g = Product . (+1) let lhs = bifoldMap f g x let rhs = bifold (bimap f g x) let ctx = contextualise $ LawContext { lawContextLawName = "Composition", lawContextLawBody = "bifoldMap f g" `congruency` "bifold . bimap f g" , lawContextTcName = "Bifoldable/Bifunctor", lawContextTcProp = let showX = show x; in lawWhere [ "bifoldMap f g x" `congruency` "bifold . bimap f g $ x" , "f = \\x -> Product x" , "g = \\x -> Product (x + 1)" , "x = " ++ showX ] , lawContextReduced = reduced lhs rhs } heqCtx lhs rhs ctx bifoldableFunctorFoldMap :: forall f. BifoldableFunctorProp f bifoldableFunctorFoldMap fgen = property $ do x <- forAll $ fgen genSmallSum genSmallSum let h (Sum s) = s * s + 3; showH = "\\(Sum s) -> s * s + 3" let i (Sum s) = s + s - 7; showI = "\\(Sum s) -> s + s - 7" let f = Sum; showF = "\\x -> Sum x"; g = Sum . (+1); showG = "\\x -> Sum (x + 1)" let lhs = bifoldMap f g (bimap h i x) let rhs = bifoldMap (f . h) (g . i) x let ctx = contextualise $ LawContext { lawContextLawName = "FoldMap", lawContextLawBody = "bifoldMap f g . bimap h i" `congruency` "bifoldMap (f . h) (g . i)" , lawContextTcName = "Bifoldable/Bifunctor", lawContextTcProp = let showX = show x; in lawWhere [ "bifoldMap f g . bimap h i $ x" `congruency` "bifoldMap (f . h) (g . i) $ x, where" , "f = " ++ showF , "g = " ++ showG , "h = " ++ showH , "i = " ++ showI , "x = " ++ showX ] , lawContextReduced = reduced lhs rhs } heqCtx lhs rhs ctx hedgehog-classes-0.2.5.4/src/Hedgehog/Classes/Bifunctor.hs0000644000000000000000000000720207346545000021444 0ustar0000000000000000{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE QuantifiedConstraints #-} module Hedgehog.Classes.Bifunctor (bifunctorLaws) where import Hedgehog import Hedgehog.Classes.Common import Data.Bifunctor (Bifunctor(..)) -- | Tests the following 'Bifunctor' laws: -- -- [__Identity__]: @'bimap' 'id' 'id'@ ≡ @'id'@ -- [__First Identity__]: @'first' 'id'@ ≡ @'id'@ -- [__Second Identity__]: @'second' 'id'@ ≡ @'id'@ -- [__Composition__]: @'bimap' 'id' 'id'@ ≡ @'first' 'id' '.' 'second' 'id'@ bifunctorLaws :: forall f. ( Bifunctor f , forall x y. (Eq x, Eq y) => Eq (f x y) , forall x y. (Show x, Show y) => Show (f x y) ) => (forall x y. Gen x -> Gen y -> Gen (f x y)) -> Laws bifunctorLaws gen = Laws "Bifunctor" [ ("Identity", bifunctorIdentity gen) , ("First Identity", bifunctorFirstIdentity gen) , ("Second Identity", bifunctorSecondIdentity gen) , ("Composition", bifunctorComposition gen) ] type BifunctorProp f = ( Bifunctor f , forall x y. (Eq x, Eq y) => Eq (f x y) , forall x y. (Show x, Show y) => Show (f x y) ) => (forall x y. Gen x -> Gen y -> Gen (f x y)) -> Property bifunctorIdentity :: forall f. BifunctorProp f bifunctorIdentity fgen = property $ do x <- forAll $ fgen genSmallInteger genSmallInteger let lhs = bimap id id x let rhs = x let ctx = contextualise $ LawContext { lawContextLawName = "Identity", lawContextLawBody = "bimap id id" `congruency` "id" , lawContextTcName = "Bifunctor", lawContextTcProp = let showX = show x; in lawWhere [ "bimap id id x" `congruency` "x, where" , "x = " ++ showX ] , lawContextReduced = reduced lhs rhs } heqCtx2 lhs rhs ctx bifunctorFirstIdentity :: forall f. BifunctorProp f bifunctorFirstIdentity fgen = property $ do x <- forAll $ fgen genSmallInteger genSmallInteger let lhs = first id x let rhs = x let ctx = contextualise $ LawContext { lawContextLawName = "First Identity", lawContextLawBody = "first id" `congruency` "id" , lawContextTcName = "Bifunctor", lawContextTcProp = let showX = show x; in lawWhere [ "first id x" `congruency` "x, where" , "x = " ++ showX ] , lawContextReduced = reduced lhs rhs } heqCtx2 lhs rhs ctx bifunctorSecondIdentity :: forall f. BifunctorProp f bifunctorSecondIdentity fgen = property $ do x <- forAll $ fgen genSmallInteger genSmallInteger let lhs = second id x let rhs = x let ctx = contextualise $ LawContext { lawContextLawName = "Second Identity", lawContextLawBody = "second id" `congruency` "id" , lawContextTcName = "Bifunctor", lawContextTcProp = let showX = show x; in lawWhere [ "second id x" `congruency` "x, where" , "x = " ++ showX ] , lawContextReduced = reduced lhs rhs } heqCtx2 lhs rhs ctx bifunctorComposition :: forall f. BifunctorProp f bifunctorComposition fgen = property $ do z <- forAll $ fgen genSmallInteger genSmallInteger let lhs = bimap id id z let rhs = (first id . second id) z let ctx = contextualise $ LawContext { lawContextLawName = "Composition", lawContextLawBody = "bimap id id" `congruency` "first id . second id" , lawContextTcName = "Bifunctor", lawContextTcProp = let showX = show z; in lawWhere [ "bimap id id x" `congruency` "first id . second id $ x, where" , "x = " ++ showX ] , lawContextReduced = reduced lhs rhs } heqCtx2 lhs rhs ctx hedgehog-classes-0.2.5.4/src/Hedgehog/Classes/Binary.hs0000644000000000000000000000241607346545000020737 0ustar0000000000000000{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} module Hedgehog.Classes.Binary (binaryLaws) where import Hedgehog import Hedgehog.Classes.Common import Data.Binary (Binary) import qualified Data.Binary as Binary -- | Tests the following 'Binary' laws: -- -- [__Encoding Partial Isomorphism__]: @'Binary.decode' '.' 'Binary.encode'@ ≡ @'id'@ binaryLaws :: (Binary a, Eq a, Show a) => Gen a -> Laws binaryLaws gen = Laws "Binary" [ ("Partial Isomorphism", binaryPartialIsomorphism gen) ] binaryPartialIsomorphism :: forall a. (Binary a, Show a, Eq a) => Gen a -> Property binaryPartialIsomorphism gen = property $ do x <- forAll gen let encoded = Binary.encode x let lhs = Binary.decode @a encoded let rhs = x let ctx = contextualise $ LawContext { lawContextLawName = "Partial Isomorphism", lawContextTcName = "Binary" , lawContextLawBody = "decode . encode" `congruency` "id" , lawContextTcProp = let showX = show x showEncoded = show encoded in lawWhere [ "decode . encode $ x" `congruency` "x, where" , "x = " ++ showX , "encode x = " ++ showEncoded ] , lawContextReduced = reduced lhs rhs } heqCtx lhs rhs ctx hedgehog-classes-0.2.5.4/src/Hedgehog/Classes/Bitraversable.hs0000644000000000000000000001022707346545000022277 0ustar0000000000000000{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE QuantifiedConstraints #-} module Hedgehog.Classes.Bitraversable (bitraversableLaws) where import Hedgehog import Hedgehog.Classes.Common import Data.Bitraversable (Bitraversable(..)) import Data.Functor.Compose (Compose(..)) import Data.Functor.Identity (Identity(..)) import qualified Data.Set as S import qualified Control.Monad.Trans.Writer.Lazy as WL -- | Tests the following 'Bitraversable' laws: -- -- [__Naturality__]: @'bitraverse' (t '.' f) (t '.' g)@ ≡ @t '.' 'bitraverse' f g, for every applicative transformation t@ -- [__Identity__]: @'bitraverse' 'Identity' 'Identity'@ ≡ @'Identity'@ -- [__Composition__]: @'Compose' '.' 'fmap' ('bitraverse' g1 g2) '.' 'bitraverse' f1 f2@ ≡ @'bitraverse' ('Compose' '.' 'fmap' g1 '.' f1) ('Compose' '.' 'fmap' g2 '.' f2)@ bitraversableLaws :: forall f. ( Bitraversable f , forall x y. (Eq x, Eq y) => Eq (f x y) , forall x y. (Show x, Show y) => Show (f x y) ) => (forall x y. Gen x -> Gen y -> Gen (f x y)) -> Laws bitraversableLaws gen = Laws "Bitraversable" [ ("Naturality", bitraversableNaturality gen) , ("Identity", bitraversableIdentity gen) , ("Composition", bitraversableComposition gen) ] type BitraversableProp f = ( Bitraversable f , forall x y. (Eq x, Eq y) => Eq (f x y) , forall x y. (Show x, Show y) => Show (f x y) ) => (forall x y. Gen x -> Gen y -> Gen (f x y)) -> Property bitraversableNaturality :: forall f. BitraversableProp f bitraversableNaturality fgen = property $ do x <- forAll $ fgen genSmallInteger genSmallInteger let t = apTrans; f = func4; g = func4 let lhs = bitraverse (t . f) (t . g) x let rhs = t (bitraverse f g x) let ctx = contextualise $ LawContext { lawContextLawName = "Naturality", lawContextLawBody = "bitraverse (t . f) (t . g)" `congruency` "t . bitraverse f g, for every applicative transformation t" , lawContextTcName = "Bitraversable", lawContextTcProp = let showX = show x; in lawWhere [ "bitraverse (t . f) (t . g) $ x" `congruency` "t . bitraverse f g $ x, for every applicative transformation t, where" , "x = " ++ showX ] , lawContextReduced = reduced lhs rhs } heqCtx1 lhs rhs ctx bitraversableIdentity :: forall f. BitraversableProp f bitraversableIdentity fgen = property $ do x <- forAll $ fgen genSmallInteger genSmallInteger let lhs = bitraverse Identity Identity x let rhs = Identity x let ctx = contextualise $ LawContext { lawContextLawName = "Identity", lawContextLawBody = "bitraverse Identity Identity" `congruency` "Identity" , lawContextTcName = "Bitraversable", lawContextTcProp = let showX = show x; in lawWhere [ "bitraverse Identity Identity x" `congruency` "Identity x, where" , "x = " ++ showX ] , lawContextReduced = reduced lhs rhs } heqCtx1 lhs rhs ctx bitraversableComposition :: forall f. BitraversableProp f bitraversableComposition fgen = property $ do x <- forAll $ fgen genSmallInteger genSmallInteger let f1 = func6; f2 = func5; g1 = func4; g2 = func4 let lhs :: Compose Triple (Compose Triple (WL.Writer (S.Set Integer))) (f Integer Integer) lhs = Compose . fmap (bitraverse g1 g2) . bitraverse f1 f2 $ x let rhs :: Compose Triple (Compose Triple (WL.Writer (S.Set Integer))) (f Integer Integer) rhs = bitraverse (Compose . fmap g1 . f1) (Compose . fmap g2 . f2) x let ctx = contextualise $ LawContext { lawContextLawName = "Composition", lawContextLawBody = "Compose . fmap (bitraverse g1 g2) . bitraverse f1 f2" `congruency` "bitraverse (Compose . fmap g1 . f1) (Compose . fmap g2 . f2)" , lawContextTcName = "Bitraversable", lawContextTcProp = let showX = show x; in lawWhere [ "Compose . fmap (bitraverse g1 g2) . bitraverse f1 f2 $ x" `congruency` "bitraverse (Compose . fmap g1 . f1) (Compose . fmap g2 . f2) $ x, where" , "x = " ++ showX ] , lawContextReduced = reduced lhs rhs } heqCtx1 lhs rhs ctx hedgehog-classes-0.2.5.4/src/Hedgehog/Classes/Bits.hs0000644000000000000000000002477007346545000020423 0ustar0000000000000000{-# LANGUAGE ScopedTypeVariables #-} module Hedgehog.Classes.Bits (bitsLaws) where import Data.Bits import Hedgehog import Hedgehog.Classes.Common import qualified Hedgehog.Gen as Gen import qualified Hedgehog.Range as Range -- | Tests the following 'Bits' laws: -- -- [__Conjunction Idempotence__]: @n '.&.' n@ ≡ @n@ -- [__Disjunction Idempotence__]: @n '.|.' n@ ≡ @n@ -- [__Double Complement__]: @'complement' '.' 'complement'@ ≡ @id@ -- [__Set Bit__]: @'setBit' n i ≡ n '.|.' 'bit' i@ -- [__Clear Bit__]: @'clearBit' n i@ ≡ @n '.&.' 'complement' ('bit' i)@ -- [__Complement Bit__]: @'complement' n i@ ≡ @'xor' n ('bit' i)@ -- [__Clear Zero__]: @'clearBit' 'zeroBits' i@ ≡ @'zeroBits'@ -- [__Set Zero__]: @'setBit' 'zeroBits' i@ ≡ @'zeroBits'@ -- [__Test Zero__]: @'testBit' 'zeroBits' i@ ≡ @'False'@ -- [__Pop Zero__]: @'popCount' 'zeroBits'@ ≡ @0@ -- [__Count Leading Zeros of Zero__]: @'countLeadingZeros' 'zeroBits'@ ≡ @'finiteBitSize' ('undefined' :: a)@ -- [__Count Trailing Zeros of Zero__]: @'countTrailingZeros' 'zeroBits'@ ≡ @'finiteBitSize' ('undefined' :: a)@ bitsLaws :: (FiniteBits a, Show a) => Gen a -> Laws bitsLaws gen = Laws "Bits" [ ("Conjunction Idempotence", bitsConjunctionIdempotence gen) , ("Disjunction Idempotence", bitsDisjunctionIdempotence gen) , ("Double Complement", bitsDoubleComplement gen) , ("Set Bit", bitsSetBit gen) , ("Clear Bit", bitsClearBit gen) , ("Complement Bit", bitsComplementBit gen) , ("Clear Zero", bitsClearZero gen) , ("Set Zero", bitsSetZero gen) , ("Test Zero", bitsTestZero gen) , ("Pop Zero", bitsPopZero gen) , ("Count Leading Zeros of Zero", bitsCountLeadingZeros gen) , ("Count Trailing Zeros of Zero", bitsCountTrailingZeros gen) ] newtype BitIndex a = BitIndex Int deriving (Show) genBitIndex :: forall a. FiniteBits a => Gen (BitIndex a) genBitIndex = let n = finiteBitSize (undefined :: a) in if n > 0 then fmap BitIndex (Gen.integral $ Range.linear 0 (n - 1)) else pure (BitIndex 0) bitsConjunctionIdempotence :: forall a. (Bits a, Show a) => Gen a -> Property bitsConjunctionIdempotence gen = property $ do n <- forAll gen let lhs = n .&. n; rhs = n; let ctx = contextualise $ LawContext { lawContextLawName = "Conjunction Idempotence" , lawContextLawBody = "n .&. n" `congruency` "n" , lawContextTcName = "Bits" , lawContextTcProp = let showN = show n; in lawWhere [ "n .&. n" `congruency` "n, where", "n = " ++ showN ] , lawContextReduced = reduced lhs rhs } heqCtx lhs rhs ctx bitsDisjunctionIdempotence :: forall a. (Bits a, Show a) => Gen a -> Property bitsDisjunctionIdempotence gen = property $ do n <- forAll gen let lhs = n .|. n; rhs = n; let ctx = contextualise $ LawContext { lawContextLawName = "Disjunction Idempotence" , lawContextLawBody = "n .|. n" `congruency` "n" , lawContextTcName = "Bits" , lawContextTcProp = let showN = show n in lawWhere [ "n .|. n" `congruency` "n, where", "n = " ++ showN ] , lawContextReduced = reduced lhs rhs } heqCtx lhs rhs ctx bitsDoubleComplement :: forall a. (Bits a, Show a) => Gen a -> Property bitsDoubleComplement gen = property $ do n <- forAll gen let lhs = complement (complement n); rhs = n; let ctx = contextualise $ LawContext { lawContextLawName = "Double Complement" , lawContextLawBody = "complement . complement" `congruency` "id" , lawContextTcName = "Bits" , lawContextTcProp = let showN = show n in lawWhere [ "complement . complement $ n" `congruency` "id n, where", "n = " ++ showN ] , lawContextReduced = reduced lhs rhs } heqCtx lhs rhs ctx bitsSetBit :: forall a. (FiniteBits a, Show a) => Gen a -> Property bitsSetBit gen = property $ do n <- forAll gen (BitIndex i) :: BitIndex a <- forAll genBitIndex let lhs = setBit n i; rhs = n .|. bit i; let ctx = contextualise $ LawContext { lawContextLawName = "Set Bit" , lawContextLawBody = "setBit n i" `congruency` "n .|. bit i" , lawContextTcName = "Bits" , lawContextTcProp = let showN = show n showI = show i in lawWhere [ "setBit n i" `congruency` "n .|. bit i, where" , "n = " ++ showN , "i = " ++ showI ] , lawContextReduced = reduced lhs rhs } heqCtx lhs rhs ctx bitsClearBit :: forall a. (FiniteBits a, Show a) => Gen a -> Property bitsClearBit gen = property $ do n <- forAll gen (BitIndex i) :: BitIndex a <- forAll genBitIndex let lhs = clearBit n i; rhs = n .&. complement (bit i) let ctx = contextualise $ LawContext { lawContextLawName = "Clear Bit" , lawContextLawBody = "clearBit n i" `congruency` "n .&. complement (bit i)" , lawContextTcName = "Bits" , lawContextTcProp = let showN = show n showI = show i in lawWhere [ "clearBit n i" `congruency` "n .&. complement (bit i), where" , "n = " ++ showN , "i = " ++ showI ] , lawContextReduced = reduced lhs rhs } heqCtx lhs rhs ctx bitsComplementBit :: forall a. (FiniteBits a, Show a) => Gen a -> Property bitsComplementBit gen = property $ do n <- forAll gen (BitIndex i) :: BitIndex a <- forAll genBitIndex let lhs = complementBit n i; rhs = xor n (bit i); let ctx = contextualise $ LawContext { lawContextLawName = "Complement Bit" , lawContextLawBody = "complement n i" `congruency` "xor n (bit i)" , lawContextTcName = "Bits" , lawContextTcProp = let showN = show n showI = show i in lawWhere [ "complement n i" `congruency` "xor n (bit i), where" , "n = " ++ showN , "i = " ++ showI ] , lawContextReduced = reduced lhs rhs } heqCtx lhs rhs ctx bitsClearZero :: forall a. (FiniteBits a, Show a) => Gen a -> Property bitsClearZero _ = property $ do (BitIndex i) :: BitIndex a <- forAll genBitIndex let z = zeroBits :: a let lhs = clearBit z i; rhs = z let ctx = contextualise $ LawContext { lawContextLawName = "Clear Zero" , lawContextLawBody = "clearBit zeroBits i" `congruency` "zeroBits" , lawContextTcName = "Bits" , lawContextTcProp = let showZ = show z showI = show i in lawWhere [ "clearBit zeroBits i" `congruency` "zeroBits, where" , "zerBits = " ++ showZ , "i = " ++ showI ] , lawContextReduced = reduced lhs rhs } heqCtx lhs rhs ctx bitsSetZero :: forall a. (FiniteBits a, Show a) => Gen a -> Property bitsSetZero _ = property $ do (BitIndex i) :: BitIndex a <- forAll genBitIndex let z = zeroBits :: a let lhs = setBit z i; rhs = bit i; let ctx = contextualise $ LawContext { lawContextLawName = "Set Zero" , lawContextLawBody = "setBit zeroBits i" `congruency` "zeroBits" , lawContextTcName = "Bits" , lawContextTcProp = let showZ = show z showI = show i in lawWhere [ "setBit zeroBits i" `congruency` "zeroBits, where" , "zeroBits = " ++ showZ , "i = " ++ showI ] , lawContextReduced = reduced lhs rhs } heqCtx lhs rhs ctx bitsTestZero :: forall a. (FiniteBits a, Show a) => Gen a -> Property bitsTestZero _ = property $ do (BitIndex i) :: BitIndex a <- forAll genBitIndex let z = zeroBits :: a let lhs = testBit z i; rhs = False; let ctx = contextualise $ LawContext { lawContextLawName = "Test Zero" , lawContextLawBody = "testBit zeroBits i" `congruency` "False" , lawContextTcName = "Bits" , lawContextTcProp = let showZ = show z showI = show i in lawWhere [ "testBit zeroBits i" `congruency` "False, where" , "zeroBits = " ++ showZ , "i = " ++ showI ] , lawContextReduced = reduced lhs rhs } heqCtx lhs rhs ctx bitsPopZero :: forall a. (FiniteBits a, Show a) => Gen a -> Property bitsPopZero _ = property $ do let z = zeroBits :: a let lhs = popCount z; rhs = 0; let ctx = contextualise $ LawContext { lawContextLawName = "Pop Zero" , lawContextLawBody = "popCount zeroBits" `congruency` "0" , lawContextTcName = "Bits" , lawContextTcProp = let showZ = show z in lawWhere [ "popCount zeroBits" `congruency` "0, where" , "zeroBits = " ++ showZ ] , lawContextReduced = reduced lhs rhs } heqCtx lhs rhs ctx bitsCountLeadingZeros :: forall a. (FiniteBits a, Show a) => Gen a -> Property bitsCountLeadingZeros _ = property $ do let z = zeroBits :: a let f = finiteBitSize (undefined :: a) let lhs = countLeadingZeros z; rhs = f; let ctx = contextualise $ LawContext { lawContextLawName = "Count Leading Zeros of Zero" , lawContextLawBody = "countLeadingZeros zeroBits" `congruency` "finiteBitSize (undefined :: a)" , lawContextTcName = "Bits" , lawContextTcProp = let showZ = show z showF = show f in lawWhere [ "countLeadingZeros zeroBits" `congruency` "finiteBitSize (undefined :: a), where" , "zeroBits = " ++ showZ , "finiteBitSize = " ++ showF ] , lawContextReduced = reduced lhs rhs } heqCtx lhs rhs ctx bitsCountTrailingZeros :: forall a. (FiniteBits a, Show a) => Gen a -> Property bitsCountTrailingZeros _ = property $ do let z = zeroBits :: a let f = finiteBitSize (undefined :: a) let lhs = countTrailingZeros z; rhs = f; let ctx = contextualise $ LawContext { lawContextLawName = "Count Trailing Zeros of Zero" , lawContextLawBody = "countTrailingZeros zeroBits" `congruency` "finiteBitSize (undefined :: a)" , lawContextTcName = "Bits" , lawContextTcProp = let showZ = show z showF = show f in lawWhere [ "countTrailingZeros zeroBits" `congruency` "finiteBitSize (undefined :: a), where" , "zeroBits = " ++ showZ , "finiteBitSize = " ++ showF ] , lawContextReduced = reduced lhs rhs } heqCtx lhs rhs ctx hedgehog-classes-0.2.5.4/src/Hedgehog/Classes/Category.hs0000644000000000000000000000530707346545000021272 0ustar0000000000000000{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE QuantifiedConstraints #-} module Hedgehog.Classes.Category (categoryLaws, commutativeCategoryLaws) where import Hedgehog import Hedgehog.Classes.Common import Control.Category(Category(..)) import Prelude hiding (id, (.)) -- | Tests the following 'Category' laws: -- -- [__Left Identity__]: @'id' '.' f@ ≡ @f@ -- [__Right Identity__]: @f '.' 'id'@ ≡ @f@ -- [__Associativity__]: @f '.' (g '.' h)@ ≡ @(f '.' g) '.' h@ categoryLaws :: forall f. ( Category f , forall x y. (Eq x, Eq y) => Eq (f x y) , forall x y. (Show x, Show y) => Show (f x y) ) => (forall x y. Gen x -> Gen y -> Gen (f x y)) -> Laws categoryLaws gen = Laws "Category" [ ("Left Identity", categoryLeftIdentity gen) , ("Right Identity", categoryRightIdentity gen) , ("Associativity", categoryAssociativity gen) ] -- | Tests the following 'Category' laws: -- -- [__Commutativity__]: @f '.' g@ ≡ @g '.' f@ commutativeCategoryLaws :: forall f. ( Category f , forall x y. (Eq x, Eq y) => Eq (f x y) , forall x y. (Show x, Show y) => Show (f x y) ) => (forall x y. Gen x -> Gen y -> Gen (f x y)) -> Laws commutativeCategoryLaws gen = Laws "Commutative Category" [ ("Commutativity", categoryCommutativity gen) ] categoryRightIdentity :: forall f. ( Category f , forall x y. (Eq x, Eq y) => Eq (f x y) , forall x y. (Show x, Show y) => Show (f x y) ) => (forall x y. Gen x -> Gen y -> Gen (f x y)) -> Property categoryRightIdentity fgen = property $ do x <- forAll $ fgen genSmallInteger genSmallInteger (x . id) `heq2` x categoryLeftIdentity :: forall f. ( Category f , forall x y. (Eq x, Eq y) => Eq (f x y) , forall x y. (Show x, Show y) => Show (f x y) ) => (forall x y. Gen x -> Gen y -> Gen (f x y)) -> Property categoryLeftIdentity fgen = property $ do x <- forAll $ fgen genSmallInteger genSmallInteger (id . x) `heq2` x categoryAssociativity :: forall f. ( Category f , forall x y. (Eq x, Eq y) => Eq (f x y) , forall x y. (Show x, Show y) => Show (f x y) ) => (forall x y. Gen x -> Gen y -> Gen (f x y)) -> Property categoryAssociativity fgen = property $ do f <- forAll $ fgen genSmallInteger genSmallInteger g <- forAll $ fgen genSmallInteger genSmallInteger h <- forAll $ fgen genSmallInteger genSmallInteger (f . (g . h)) `heq2` ((f . g) . h) categoryCommutativity :: forall f. ( Category f , forall x y. (Eq x, Eq y) => Eq (f x y) , forall x y. (Show x, Show y) => Show (f x y) ) => (forall x y. Gen x -> Gen y -> Gen (f x y)) -> Property categoryCommutativity fgen = property $ do f <- forAll $ fgen genSmallInteger genSmallInteger g <- forAll $ fgen genSmallInteger genSmallInteger (f . g) `heq2` (g . f) hedgehog-classes-0.2.5.4/src/Hedgehog/Classes/Common.hs0000644000000000000000000000077607346545000020752 0ustar0000000000000000module Hedgehog.Classes.Common ( module Common ) where import Hedgehog.Classes.Common.ApTrans as Common import Hedgehog.Classes.Common.Bottom as Common import Hedgehog.Classes.Common.Compat as Common import Hedgehog.Classes.Common.Equation as Common import Hedgehog.Classes.Common.Func as Common import Hedgehog.Classes.Common.Gen as Common import Hedgehog.Classes.Common.IO as Common import Hedgehog.Classes.Common.Laws as Common import Hedgehog.Classes.Common.Property as Common hedgehog-classes-0.2.5.4/src/Hedgehog/Classes/Common/0000755000000000000000000000000007346545000020404 5ustar0000000000000000hedgehog-classes-0.2.5.4/src/Hedgehog/Classes/Common/ApTrans.hs0000644000000000000000000000151607346545000022313 0ustar0000000000000000module Hedgehog.Classes.Common.ApTrans ( apTrans , toSpecialApplicative ) where import Data.Tuple (swap) import Data.Functor.Compose import qualified Data.Set as S import qualified Control.Monad.Trans.Writer.Lazy as WL import Hedgehog.Classes.Common.Func -- Reverse the list and accumulate the writers. We -- cannot use Sum or Product or else it won't actually -- be a valid applicative transformation. apTrans :: Compose Triple (WL.Writer (S.Set Integer)) a -> Compose (WL.Writer (S.Set Integer)) Triple a apTrans (Compose xs) = Compose (sequenceA (reverseTriple xs)) toSpecialApplicative :: Compose Triple ((,) (S.Set Integer)) Integer -> Compose Triple (WL.Writer (S.Set Integer)) Integer toSpecialApplicative (Compose (Triple a b c)) = Compose (Triple (WL.writer (swap a)) (WL.writer (swap b)) (WL.writer (swap c))) hedgehog-classes-0.2.5.4/src/Hedgehog/Classes/Common/Bottom.hs0000644000000000000000000000103607346545000022204 0ustar0000000000000000{-# LANGUAGE LambdaCase #-} module Hedgehog.Classes.Common.Bottom ( Bottom(..), genBottom ) where import Hedgehog import qualified Hedgehog.Gen as Gen data Bottom a = BottomUndefined | BottomValue a deriving (Eq) instance Show a => Show (Bottom a) where show = \case BottomUndefined -> "undefined" BottomValue a -> show a genBottom :: Gen a -> Gen (Bottom a) genBottom = fmap maybeToBottom . Gen.maybe maybeToBottom :: Maybe a -> Bottom a maybeToBottom = \case { Nothing -> BottomUndefined; Just a -> BottomValue a } hedgehog-classes-0.2.5.4/src/Hedgehog/Classes/Common/Compat.hs0000644000000000000000000000151107346545000022161 0ustar0000000000000000{-# LANGUAGE QuantifiedConstraints #-} module Hedgehog.Classes.Common.Compat ( readMaybe , eq , eq1 , eq2 , show1 , show2 , neq , neq1 , neq2 ) where import Text.Read (readMaybe) eq :: Eq a => a -> a -> Bool eq = (==) neq :: Eq a => a -> a -> Bool neq = (/=) eq1 :: (Eq a, forall x. Eq x => Eq (f x)) => f a -> f a -> Bool eq1 = (==) neq1 :: (Eq a, forall x. Eq x => Eq (f x)) => f a -> f a -> Bool neq1 = (/=) eq2 :: (Eq a, Eq b, forall x y. (Eq x, Eq y) => Eq (f x y)) => f a b -> f a b -> Bool eq2 = (==) neq2 :: (Eq a, Eq b, forall x y. (Eq x, Eq y) => Eq (f x y)) => f a b -> f a b -> Bool neq2 = (/=) show1 :: (Show a, forall x. (Show x) => Show (f x)) => f a -> String show1 = Prelude.show show2 :: (Show a, Show b, forall x y. (Show x, Show y) => Show (f x y)) => f a b -> String show2 = Prelude.show hedgehog-classes-0.2.5.4/src/Hedgehog/Classes/Common/Equation.hs0000644000000000000000000001225207346545000022527 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE QuantifiedConstraints #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE ViewPatterns #-} module Hedgehog.Classes.Common.Equation ( LinearEquation(..), runLinearEquation, genLinearEquation , LinearEquationTwo(..), runLinearEquationTwo, genLinearEquationTwo , LinearEquationM(..), runLinearEquationM, genLinearEquationM , QuadraticEquation(..), runQuadraticEquation, genQuadraticEquation , CubicEquation(..), runCubicEquation, genCubicEquation #ifdef HAVE_COMONAD , LinearEquationW(..), runLinearEquationW, genLinearEquationW #endif ) where import Hedgehog import Hedgehog.Classes.Common.Gen import qualified Hedgehog.Gen as Gen import qualified Hedgehog.Range as Range import qualified Data.List as List import Data.Monoid (Endo(..)) #ifdef HAVE_COMONAD import Control.Comonad #endif data QuadraticEquation = QuadraticEquation { _quadraticEquationQuadratic :: Integer , _quadraticEquationLinear :: Integer , _quadraticEquationConstant :: Integer } deriving (Eq) -- This show instance does not actually provide a way -- to create an equation. Instead, it makes it look -- like a lambda. instance Show QuadraticEquation where show (QuadraticEquation a b c) = "\\x -> " ++ show a ++ " * x ^ 2 + " ++ show b ++ " * x + " ++ show c genQuadraticEquation :: Gen QuadraticEquation genQuadraticEquation = do a <- Gen.integral (Range.linear 0 15) b <- Gen.integral (Range.linear 0 15) c <- Gen.integral (Range.linear 0 15) pure (QuadraticEquation a b c) runQuadraticEquation :: QuadraticEquation -> Integer -> Integer runQuadraticEquation (QuadraticEquation a b c) x = a * x ^ (2 :: Integer) + b * x + c data LinearEquation = LinearEquation { _linearEquationLinear :: Integer , _linearEquationConstant :: Integer } deriving (Eq) instance Show LinearEquation where showsPrec _ (LinearEquation a b) = shows a . showString " * x + " . shows b showList xs = appEndo $ mconcat $ [Endo (showChar '[')] ++ List.intersperse (Endo (showChar ',')) (map (Endo . showsPrec 0) xs) ++ [Endo (showChar ']')] runLinearEquation :: LinearEquation -> Integer -> Integer runLinearEquation (LinearEquation a b) x = a * x + b genLinearEquation :: Gen LinearEquation genLinearEquation = LinearEquation <$> genSmallInteger <*> genSmallInteger #ifdef HAVE_COMONAD data LinearEquationW w = LinearEquationW (w LinearEquation) (w LinearEquation) deriving instance (forall x. Eq x => Eq (w x)) => Eq (LinearEquationW w) instance (forall x. Show x => Show (w x)) => Show (LinearEquationW w) where show (LinearEquationW a b) = (\f -> f "") $ showString "\\x -> if odd x then " . showsPrec 0 a . showString " else " . showsPrec 0 b runLinearEquationW :: Comonad w => LinearEquationW w -> w Integer -> Integer runLinearEquationW (LinearEquationW e1 e2) (extract -> i) = if odd i then runLinearEquation (extract e1) i else runLinearEquation (extract e2) i genLinearEquationW :: Comonad w => (forall x. Gen x -> Gen (w x)) -> Gen (LinearEquationW w) genLinearEquationW fgen = LinearEquationW <$> fgen genLinearEquation <*> fgen genLinearEquation #endif data LinearEquationM m = LinearEquationM (m LinearEquation) (m LinearEquation) deriving instance (forall x. Eq x => Eq (m x)) => Eq (LinearEquationM m) instance (forall x. Show x => Show (m x)) => Show (LinearEquationM m) where show (LinearEquationM a b) = (\f -> f "") $ showString "\\x -> if odd x then " . showsPrec 0 a . showString " else " . showsPrec 0 b runLinearEquationM :: Functor m => LinearEquationM m -> Integer -> m Integer runLinearEquationM (LinearEquationM e1 e2) i = if odd i then fmap (flip runLinearEquation i) e1 else fmap (flip runLinearEquation i) e2 genLinearEquationM :: Applicative m => Gen (LinearEquationM m) genLinearEquationM = LinearEquationM <$> (pure <$> genLinearEquation) <*> (pure <$> genLinearEquation) data LinearEquationTwo = LinearEquationTwo { _linearEquationTwoX :: Integer , _linearEquationTwoY :: Integer , _linearEquationTwoConstant :: Integer } instance Show LinearEquationTwo where show (LinearEquationTwo x y c) = "\\x y -> " ++ show x ++ " * x + " ++ show y ++ " * y + " ++ show c genLinearEquationTwo :: Gen LinearEquationTwo genLinearEquationTwo = LinearEquationTwo <$> absGenInteger <*> absGenInteger <*> absGenInteger where absGenInteger = abs <$> genSmallInteger runLinearEquationTwo :: LinearEquationTwo -> Integer -> Integer -> Integer runLinearEquationTwo (LinearEquationTwo a b c) x y = a * x + b * y + c data CubicEquation = CubicEquation { _cubicEquationCubic :: Integer , _cubicEquationQuadratic :: Integer , _cubicEquationLinear :: Integer , _cubicEquationConstant :: Integer } instance Show CubicEquation where show (CubicEquation x y z c) = "\\x -> " ++ show x ++ " * x ^ 3 + " ++ show y ++ " * x ^ 2 + " ++ show z ++ " * x + " ++ show c genCubicEquation :: Gen CubicEquation genCubicEquation = CubicEquation <$> genSmallInteger <*> genSmallInteger <*> genSmallInteger <*> genSmallInteger runCubicEquation :: CubicEquation -> Integer -> Integer -> Integer -> Integer runCubicEquation (CubicEquation a b c d) x y z = a * x + b * y + c * z + d hedgehog-classes-0.2.5.4/src/Hedgehog/Classes/Common/Func.hs0000644000000000000000000000423407346545000021636 0ustar0000000000000000module Hedgehog.Classes.Common.Func ( func1 , func2 , func3 , func4 , func5 , func6 , Triple(..), reverseTriple, genTriple ) where import Hedgehog import Data.Functor.Classes (Eq1(..), Show1(..)) import Data.Functor.Compose import qualified Data.Set as S import qualified Control.Monad.Trans.Writer.Lazy as WL import Data.Semigroup func1 :: Integer -> (Integer, Integer) func1 i = (div (i + 5) 3, i * i - 2 * i + 1) func2 :: (Integer, Integer) -> (Bool, Either Ordering Integer) func2 (a,b) = (odd a, if even a then Left (compare a b) else Right (b + 2)) func3 :: Integer -> Sum Integer func3 i = Sum (3 * i * i - 7 * i + 4) func4 :: Integer -> Compose Triple (WL.Writer (S.Set Integer)) Integer func4 i = Compose $ Triple (WL.writer (i * i, S.singleton (i * 7 + 5))) (WL.writer (i + 2, S.singleton (i * i + 3))) (WL.writer (i * 7, S.singleton 4)) func5 :: Integer -> Triple Integer func5 i = Triple (i + 2) (i * 3) (i * i) func6 :: Integer -> Triple Integer func6 i = Triple (i * i * i) (4 * i - 7) (i * i * i) reverseTriple :: Triple a -> Triple a reverseTriple (Triple a b c) = Triple c b a data Triple a = Triple a a a deriving (Show, Eq) instance Functor Triple where fmap f (Triple a b c) = Triple (f a) (f b) (f c) instance Applicative Triple where pure a = Triple a a a Triple f g h <*> Triple a b c = Triple (f a) (g b) (h c) instance Foldable Triple where foldMap f (Triple a b c) = f a <> f b <> f c instance Traversable Triple where traverse f (Triple a b c) = Triple <$> f a <*> f b <*> f c tripleLiftEq :: (a -> b -> Bool) -> Triple a -> Triple b -> Bool tripleLiftEq p (Triple a1 b1 c1) (Triple a2 b2 c2) = p a1 a2 && p b1 b2 && p c1 c2 tripleLiftShowsPrec :: (Int -> a -> ShowS) -> ([a] -> ShowS) -> Int -> Triple a -> ShowS tripleLiftShowsPrec elemShowsPrec _ p (Triple a b c) = showParen (p > 10) $ showString "Triple " . elemShowsPrec 11 a . showString " " . elemShowsPrec 11 b . showString " " . elemShowsPrec 11 c instance Eq1 Triple where liftEq = tripleLiftEq instance Show1 Triple where liftShowsPrec = tripleLiftShowsPrec genTriple :: Gen a -> Gen (Triple a) genTriple gen = Triple <$> gen <*> gen <*> gen hedgehog-classes-0.2.5.4/src/Hedgehog/Classes/Common/Gen.hs0000644000000000000000000000440107346545000021450 0ustar0000000000000000{-# LANGUAGE RankNTypes #-} module Hedgehog.Classes.Common.Gen ( genSmallList , genVerySmallList , genSmallNonEmptyList , genShowReadPrecedence , genSmallString , genSmallInteger , genSmallSum , genCompose , genSetInteger -- * Used for 'Hedgehog.Classes.ixLaws' , genTuple , genTuple3 , genInRange , genValidRange ) where import Data.Ix (Ix(..)) import Hedgehog import Data.Functor.Compose import qualified Data.Set as S import Data.Semigroup import qualified Hedgehog.Gen as Gen import qualified Hedgehog.Range as Range genSmallSum :: Gen (Sum Integer) genSmallSum = fmap Sum genSmallInteger genSmallInteger :: Gen Integer genSmallInteger = Gen.integral (Range.linear 0 20) genSmallNonEmptyList :: Gen a -> Gen [a] genSmallNonEmptyList gen = Gen.list (Range.linear 1 7) gen genSmallList :: Gen a -> Gen [a] genSmallList gen = Gen.list (Range.linear 0 6) gen genVerySmallList :: Gen a -> Gen [a] genVerySmallList gen = Gen.list (Range.linear 0 2) gen genSmallString :: Gen String genSmallString = Gen.string (Range.linear 0 6) Gen.ascii -- Haskell uses the operator precedences 0..9, the special function application -- precedence 10 and the precedence 11 for function arguments. Both show and -- read instances have to accept this range. According to the Haskell Language -- Report, the output of derived show instances in precedence context 11 has to -- be an atomic expression. genShowReadPrecedence :: Gen Int genShowReadPrecedence = Gen.element [0..11] genCompose :: forall f g a. Gen a -> (forall x. Gen x -> Gen (f x)) -> (forall x. Gen x -> Gen (g x)) -> Gen (Compose f g a) genCompose gen fgen ggen = Compose <$> fgen (ggen gen) genTuple :: Gen a -> Gen b -> Gen (a,b) genTuple a b = (,) <$> a <*> b genTuple3 :: Gen a -> Gen b -> Gen c -> Gen (a, b, c) genTuple3 gena genb genc = do a <- gena b <- genb c <- genc pure (a, b, c) genValidRange :: Ix a => Gen a -> Gen (a, a) genValidRange gen = do Gen.filter (\(l,u) -> l <= u) (genTuple gen gen) genInRange :: (Ix a) => Gen a -> Gen (a, a, a) genInRange gen = do Gen.filter (\(l,u,i) -> inRange (l,u) i) (genTuple3 gen gen gen) genSetInteger :: Gen (S.Set Integer) genSetInteger = do xs <- sequence $ fmap (const genSmallInteger) [1..10 :: Integer] pure $ foldMap S.singleton xs hedgehog-classes-0.2.5.4/src/Hedgehog/Classes/Common/IO.hs0000644000000000000000000000045307346545000021251 0ustar0000000000000000module Hedgehog.Classes.Common.IO ( genIO , showIO ) where import Hedgehog import System.IO.Unsafe (unsafePerformIO) genIO :: Gen a -> Gen (IO a) genIO gen = fmap pure gen showIO :: Show a => IO a -> String showIO io = unsafePerformIO $ do x <- fmap show io let y = "IO " ++ x pure y hedgehog-classes-0.2.5.4/src/Hedgehog/Classes/Common/Laws.hs0000644000000000000000000002527707346545000021663 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeApplications #-} module Hedgehog.Classes.Common.Laws ( Laws(..) , LawContext(..) , lawsCheck , lawsCheckOne , lawsCheckMany , contextualise , reduced , lawWhere , congruency , implies , congruent , implication , newline , tab , tab2 ) where import Control.Monad.IO.Class (MonadIO(liftIO)) import Data.Char (isSpace) import Data.Monoid (All(..), Ap(..)) import Hedgehog (Gen) import Hedgehog.Classes.Common.Property (Context(..)) import Hedgehog.Internal.Config (UseColor(..)) import Hedgehog.Internal.Property (Property(..)) import Hedgehog.Internal.Region (Region) import Hedgehog.Internal.Report (Report, Result(..), Progress(..), renderProgress, reportStatus) import Hedgehog.Internal.Runner (checkReport) import System.Exit (exitFailure) import qualified Hedgehog.Classes.Common.PP as PP import qualified Hedgehog.Internal.Region as Region import qualified Hedgehog.Internal.Seed as Seed import qualified System.IO.Silently as S congruent :: String congruent = " ≡ " implication :: String implication = " ==> " congruency :: String -> String -> String congruency x y = x ++ congruent ++ y implies :: String -> String -> String implies x y = x ++ implication ++ y newline, tab, tab2 :: String newline = "\n" tab = " " tab2 = " " -- | For footnotes dagger :: String dagger = "†" lawWhere :: [String] -> String lawWhere [] = [] lawWhere (l:ls) = l ++ newline ++ tab2 ++ lawWhere ls -- | A 'Laws' is the name of the typeclass and the set of named properties associated with that typeclass. data Laws = Laws { lawsTypeClass :: String , lawsProperties :: [(String, Property)] } -- | The context surrounding the property test of a law. Use 'contextualise' to turn this into a 'Context'. data LawContext = LawContext { lawContextLawName :: String -- ^ law name , lawContextLawBody :: String -- ^ law body , lawContextTcName :: String -- ^ typeclass name , lawContextTcProp :: String -- ^ how to show the specific property test , lawContextReduced :: String -- ^ reduced equation, eg "LHS = RHS" where neither LHS nor RHS are reducible } reduced :: Show a => a -> a -> String reduced lhs rhs = show lhs ++ congruent ++ show rhs -- | Turn a 'LawContext' into a 'Context'. contextualise :: LawContext -> Context contextualise LawContext{..} = Context $ unlines [ "When testing the " ++ lawContextLawName ++ " law(" ++ dagger ++"), for the " ++ lawContextTcName ++ " typeclass, the following test failed: " , newline ++ lawContextTcProp , newline ++ "The reduced test is: " , tab2 ++ lawContextReduced , newline ++ "The law in question: " , tab2 ++ "(" ++ dagger ++ ") " ++ lawContextLawName ++ " Law: " ++ lawContextLawBody ] -- | A convenience function for testing the properties of a typeclass. -- For example, in GHCi: -- -- >>> genOrdering :: Gen Ordering; genOrdering = frequency [(1,pure EQ),(1,pure LT),(1,pure GT)] -- >>> lawsCheck (monoidLaws genOrdering) -- Monoid: Left Identity ✓ passed 100 tests. -- Monoid: Right Identity ✓ passed 100 tests. -- Monoid: Associativity ✓ passed 100 tests. -- Monoid: Concatenation ✓ passed 100 tests. -- True lawsCheck :: Laws -- ^ The 'Laws' you would like to check. -> IO Bool -- ^ 'True' if your tests pass, 'False' otherwise. lawsCheck = fmap getAll . lawsCheckInternal -- | A convenience function for testing many typeclass instances of -- a single type. -- -- >>> lawsCheckOne (word8 constantBounded) [jsonLaws, showReadLaws] -- ToJSON/FromJSON: Partial Isomorphism ✓ passed 100 tests. -- ToJSON/FromJSON: Encoding equals value ✓ passed 100 tests. -- Show/Read: Partial Isomorphism: show/read ✓ passed 100 tests. -- Show/Read: Partial Isomorphism: show/read with initial space ✓ passed 100 tests. -- Show/Read: Partial Isomorphism: showsPrec/readsPrec ✓ passed 100 tests. -- Show/Read: Partial Isomorphism: showList/readList ✓ passed 100 tests. -- Show/Read: Partial Isomorphism: showListWith shows/readListDefault ✓ passed 100 tests. -- True lawsCheckOne :: Gen a -- ^ The generator for your type. -> [Gen a -> Laws] -- ^ Functions that take a generator and output 'Laws'. -> IO Bool -- ^ 'True' if your tests pass. 'False' otherwise. lawsCheckOne g = fmap getAll . lawsCheckOneInternal g -- | A convenience function for checking many typeclass instances of -- multiple types. -- -- @ -- import Control.Applicative (liftA2) -- -- import Data.Map (Map) -- import Data.Set (Set) -- -- import qualified Data.List as List -- import qualified Data.Set as Set -- import qualified Data.Map as Map -- -- import qualified Hedgehog.Gen as Gen -- import qualified Hedgehog.Range as Range -- -- import Hedgehog (Gen) -- import Hedgehog.Classes -- -- -- Generate a small @Set Int@ -- genSet :: Gen (Set Int) -- genSet = Set.fromList \<$\> (Gen.list (Range.linear 2 10) (Gen.int Range.constantBounded)) -- -- -- Generate a small @Map String Int@ -- genMap :: Gen (Map String Int) -- genMap = Map.fromList \<$\> (liftA2 List.zip genStrings genInts) -- where -- rng = Range.linear 2 6 -- genStrings = Gen.list rng (Gen.string rng Gen.lower) -- genInts = Gen.list rng (Gen.int Range.constantBounded) -- -- commonLaws :: (Eq a, Monoid a, Show a) => Gen a -> [Laws] -- commonLaws p = [eqLaws p, monoidLaws p] -- -- tests :: [(String, [Laws])] -- tests = -- [ ("Set Int", commonLaws genSet) -- , ("Map String Int", commonLaws genMap) -- ] -- @ -- -- Now, in GHCi: -- -- >>> lawsCheckMany tests -- -- @ -- Testing properties for common typeclasses... -- -- ------------- -- -- Set Int -- -- ------------- -- -- Eq: Transitive ✓ passed 100 tests. -- Eq: Symmetric ✓ passed 100 tests. -- Eq: Reflexive ✓ passed 100 tests. -- Eq: Negation ✓ passed 100 tests. -- Monoid: Left Identity ✓ passed 100 tests. -- Monoid: Right Identity ✓ passed 100 tests. -- Monoid: Associativity ✓ passed 100 tests. -- Monoid: Concatenation ✓ passed 100 tests. -- -- -------------------- -- -- Map String Int -- -- -------------------- -- -- Eq: Transitive ✓ passed 100 tests. -- Eq: Symmetric ✓ passed 100 tests. -- Eq: Reflexive ✓ passed 100 tests. -- Eq: Negation ✓ passed 100 tests. -- Monoid: Left Identity ✓ passed 100 tests. -- Monoid: Right Identity ✓ passed 100 tests. -- Monoid: Associativity ✓ passed 100 tests. -- Monoid: Concatenation ✓ passed 100 tests. -- -- All tests succeeded -- True -- @ lawsCheckMany :: [(String, [Laws])] -- ^ Pairs of type names and their associated laws to test. -> IO Bool -- ^ 'True' if your tests pass. 'False' otherwise. lawsCheckMany = fmap getAll . lawsCheckManyInternal lawsCheckInternal :: Laws -> IO All lawsCheckInternal (Laws className properties) = flip foldMapA properties $ \(name,p) -> do putStr (className ++ ": " ++ name ++ " ") (out,b) <- S.capture $ check p if b then putStr " ✓ passed 100 tests.\n" else putStr $ (removeBadOutput out) <> "\n" pure (All b) lawsCheckOneInternal :: Gen a -> [Gen a -> Laws] -> IO All lawsCheckOneInternal p ls = foldMap (lawsCheckInternal . ($ p)) ls lawsCheckManyInternal :: [(String, [Laws])] -> IO All lawsCheckManyInternal xs = do putStrLn "" putStrLn "Testing properties for common typeclasses..." putStrLn "" r <- flip foldMapA xs $ \(typeName, laws) -> do putStrLn $ prettyHeader typeName r <- flip foldMapA laws $ \(Laws typeclassName properties) -> do flip foldMapA properties $ \(name,p) -> do putStr (typeclassName ++ ": " ++ name) (out,b) <- S.capture $ check p if b then putStr " ✓ passed 100 tests.\n" else putStr $ (removeBadOutput out) <> "\n" pure (boolToStatus b) putStrLn "" pure r putStrLn "" case r of Good -> putStrLn "All tests succeeded" *> pure mempty Bad -> do putStrLn "One or more tests failed" exitFailure foldMapA :: (Foldable t, Monoid m, Applicative f) => (a -> f m) -> t a -> f m foldMapA f = getAp . foldMap (Ap . f) prettyHeader :: String -> String prettyHeader s = unlines [topLine, middleLine, bottomLine] where line = replicate (length s + 6) '-' topLine = line bottomLine = line middleLine = "-- " ++ s ++ " --" data Status = Bad | Good instance Semigroup Status where Good <> x = x Bad <> _ = Bad instance Monoid Status where mempty = Good boolToStatus :: Bool -> Status boolToStatus = \case { False -> Bad; True -> Good; } checkRegion :: MonadIO m => Region -> Property -> m (Report Result) checkRegion region prop = liftIO $ do seed <- liftIO Seed.random result <- checkReport (propertyConfig prop) 0 seed (propertyTest prop) $ \progress -> do #if MIN_VERSION_hedgehog(1,0,2) let u = EnableColor #else let u = Just EnableColor #endif ppprogress <- renderProgress u Nothing progress case reportStatus progress of Running -> Region.setRegion region ppprogress Shrinking _ -> Region.openRegion region ppprogress ppresult <- PP.renderResult result case reportStatus result of Failed _ -> Region.openRegion region ppresult GaveUp -> Region.openRegion region ppresult OK -> Region.setRegion region ppresult pure result check :: MonadIO m => Property -> m Bool check prop = liftIO . Region.displayRegion $ \region -> (== OK) . reportStatus <$> checkRegion region prop -- HACK! -- BAD! -- ALERT! stripLeading :: String -> String stripLeading = \case [] -> [] s@(x:xs) -> if isSpace x then stripLeading xs else s -- | Like 'Data.Functor.Contravariant.Predicate', but its -- Semigroup/Monoid instances are disjunctive instead of -- conjunctive. newtype DPredicate a = DPredicate { getDPredicate :: a -> Bool } instance Semigroup (DPredicate a) where DPredicate p <> DPredicate q = DPredicate $ \a -> p a || q a instance Monoid (DPredicate a) where mempty = DPredicate $ const False startsWithCorner :: DPredicate String startsWithCorner = DPredicate $ \case [] -> False (x:_) -> x == '┏' containsBar :: DPredicate String containsBar = DPredicate $ \s -> any (== '┃') s isBad :: String -> Bool isBad = getDPredicate $ mconcat [ startsWithCorner , containsBar ] removeBadOutput :: String -> String removeBadOutput = unlines . go . lines where go [] = [] go (x:xs) = if isBad (stripLeading x) then go xs else x : go xs hedgehog-classes-0.2.5.4/src/Hedgehog/Classes/Common/PP.hs0000644000000000000000000000324507346545000021263 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE ImplicitParams #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} #if HAVE_QUANTIFIED_CONSTRAINTS {-# LANGUAGE QuantifiedConstraints #-} #endif -- | Reverse-engineered hedgehog internals that don't print out source locations. module Hedgehog.Classes.Common.PP ( ppResult , renderResult ) where import Control.Monad.IO.Class (MonadIO(..)) import Hedgehog.Internal.Report hiding (ppResult, renderResult) import Text.PrettyPrint.Annotated.WL (Doc) import qualified Hedgehog.Internal.Report as R import Hedgehog.Internal.Config (UseColor(..)) renderResult :: MonadIO m => Report Result -> m String renderResult x = renderDoc u =<< ppResult x where #if MIN_VERSION_hedgehog(1,0,2) u = EnableColor #else u = Just EnableColor #endif ppResult :: MonadIO m => Report Result -> m (Doc Markup) #if MIN_VERSION_hedgehog(1,2,0) ppResult r@(Report tests discards coverage seed status) = case status of Failed (FailureReport shrinks shrinkPath _mcoverage annots _mspan msg _mdiff footnotes) -> let failure = Failed $ FailureReport shrinks shrinkPath Nothing annots Nothing msg Nothing footnotes in R.ppResult Nothing (Report tests discards coverage seed failure) _ -> R.ppResult Nothing r #else ppResult r@(Report tests discards coverage status) = case status of Failed (FailureReport size seed shrinks _mcoverage annots _mspan msg _mdiff footnotes) -> let failure = Failed $ FailureReport size seed shrinks Nothing annots Nothing msg Nothing footnotes in R.ppResult Nothing (Report tests discards coverage failure) _ -> R.ppResult Nothing r #endifhedgehog-classes-0.2.5.4/src/Hedgehog/Classes/Common/Property.hs0000644000000000000000000002072107346545000022566 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE ImplicitParams #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE QuantifiedConstraints #-} -- | This module exports hedgehog comparison tests -- that don't contain CallStack information, since this would -- expose library internals in error messages. module Hedgehog.Classes.Common.Property ( heq, heq1, heq2 , heqCtx, heqCtx1, heqCtx2 , hneq, hneq1, hneq2 , hneqCtx, hneqCtx1, hneqCtx2 , himplCtx , hLessThan, hGreaterThan , hLessThanCtx, hGreaterThanCtx , bar , Context(..) ) where import Control.Exception (SomeException(..), displayException) import Data.Typeable (typeOf) import GHC.Stack import Hedgehog.Classes.Common.Compat import Hedgehog.Internal.Exception (tryEvaluate) import Hedgehog.Internal.Property (MonadTest, liftTest, mkTest, success, discard, Failure(..), PropertyT) import Text.Show.Pretty (ppShow) import qualified Data.Char as Char import qualified Data.List as List bar :: String bar = "━━━" bar5 :: String bar5 = "━━━━━━━━━━━━━━━" evalNoSrc :: (MonadTest m, HasCallStack) => a -> m a evalNoSrc x = either (withFrozenCallStack failExceptionNoSrc) pure (tryEvaluate x) failWithNoSrc :: (MonadTest m, HasCallStack) => String -> m a failWithNoSrc msg = do liftTest $ mkTest (Left $ Failure Nothing msg Nothing, mempty) failExceptionNoSrc :: (MonadTest m, HasCallStack) => SomeException -> m a failExceptionNoSrc (SomeException x) = withFrozenCallStack $ failWithNoSrc $ unlines [ bar ++ " Exception: " ++ show (typeOf x) ++ " " ++ bar , List.dropWhileEnd Char.isSpace (displayException x) ] -- | You can provide a 'Context' to 'heqCtx','heqCtx1','heqCtx2','hneqCtx','hneqCtx1',or 'hneqCtx2'. The 'Context' is used to provide useful error messages in the event of a failure. data Context = NoContext | Context String contextToString :: Context -> String contextToString = \case NoContext -> "No Context provided." Context ctx -> bar ++ " Context " ++ bar ++ "\n" ++ ctx ++ "\n" ++ bar5 failContext:: ( MonadTest m, HasCallStack ) => Context -> m () failContext ctx = withFrozenCallStack $ failWithNoSrc $ contextToString ctx -- | Fails the test with the given context if the right argument is -- less than or equal to the left. hLessThanCtx :: ( MonadTest m , Ord a , Show a , HasCallStack ) => a -> a -> Context -> m () hLessThanCtx x y ctx = do ok <- withFrozenCallStack $ evalNoSrc (x < y) if ok then success else withFrozenCallStack $ failContext ctx -- | Fails the test with the given context if the right argument is -- greater than or equal to the left. hGreaterThanCtx :: ( MonadTest m , Ord a , Show a , HasCallStack ) => a -> a -> Context -> m () hGreaterThanCtx x y ctx = do ok <- withFrozenCallStack $ evalNoSrc (x > y) if ok then success else withFrozenCallStack $ failContext ctx -- | Fails the test if the right argument is less than or equal to the left. -- see https://github.com/hedgehogqa/haskell-hedgehog/pull/196 hLessThan :: (MonadTest m, Ord a, Show a, HasCallStack) => a -> a -> m () hLessThan x y = do ok <- withFrozenCallStack $ evalNoSrc (x < y) if ok then success else withFrozenCallStack $ failWithNoSrc $ unlines [ bar ++ "Not Less Than " ++ bar , ppShow x ++ " is not less than " ++ ppShow y ] -- | Fails the test if the right argument is greater than or equal to the left. -- see https://github.com/hedgehogqa/haskell-hedgehog/pull/196 hGreaterThan :: (MonadTest m, Ord a, Show a, HasCallStack) => a -> a -> m () hGreaterThan x y = do ok <- withFrozenCallStack $ evalNoSrc (x > y) if ok then success else withFrozenCallStack $ failWithNoSrc $ unlines [ bar ++ "Not Greater Than " ++ bar , ppShow x ++ " is not greater than " ++ ppShow y ] infix 4 `hneq` -- | Passes the test if the given arguments are not equal. Otherwise fails -- with the given 'Context'. hneqCtx :: ( MonadTest m , HasCallStack , Eq a , Show a ) => a -> a -> Context -> m () hneqCtx x y ctx = do ok <- withFrozenCallStack $ evalNoSrc (x `neq` y) if ok then success else withFrozenCallStack $ failContext ctx -- | Passes the test if the given arguments are not equal. Otherwise fails -- with 'NoContext'. hneq :: ( MonadTest m , HasCallStack , Eq a , Show a ) => a -> a -> m () hneq x y = hneqCtx x y NoContext infix 4 `heq` -- | Passes the test if the given arguments are equal. Otherwise fails -- with the given 'Context'. heqCtx :: ( MonadTest m , HasCallStack , Eq a , Show a ) => a -> a -> Context -> m () heqCtx x y ctx = do ok <- withFrozenCallStack $ evalNoSrc (x `eq` y) if ok then success else withFrozenCallStack $ failContext ctx -- | Passes the test if the given arguments are equal. Otherwise fails -- with 'NoContext'. heq :: ( MonadTest m , HasCallStack , Eq a , Show a ) => a -> a -> m () heq x y = heqCtx x y NoContext infix 4 `heq1` -- | Passes the test if the given arguments are not equal. Otherwise fails -- with the given 'Context'. hneqCtx1 :: ( MonadTest m , HasCallStack , Eq a , Show a , forall x. Eq x => Eq (f x) , forall x. Show x => Show (f x) ) => f a -> f a -> Context -> m () hneqCtx1 x y ctx = do ok <- withFrozenCallStack $ evalNoSrc (x `neq1` y) if ok then success else withFrozenCallStack $ failContext ctx -- | Passes the test if the given arguments are not equal. Otherwise fails -- with 'NoContext'. hneq1 :: ( MonadTest m , HasCallStack , Eq a , Show a , forall x. Eq x => Eq (f x) , forall x. Show x => Show (f x) ) => f a -> f a -> m () hneq1 x y = hneqCtx1 x y NoContext -- | Passes the test if the given arguments are equal. Otherwise fails -- with the given 'Context'. heqCtx1 :: ( MonadTest m , HasCallStack , Eq a , Show a , forall x. Eq x => Eq (f x) , forall x. Show x => Show (f x) ) => f a -> f a -> Context -> m () heqCtx1 x y ctx = do ok <- withFrozenCallStack $ evalNoSrc (x `eq1` y) if ok then success else withFrozenCallStack $ failContext ctx -- | Passes the test if the given arguments are equal. Otherwise fails -- with 'NoContext'. heq1 :: ( MonadTest m , HasCallStack , Eq a , Show a , forall x. Eq x => Eq (f x) , forall x. Show x => Show (f x) ) => f a -> f a -> m () heq1 x y = heqCtx1 x y NoContext infix 4 `heq2` -- | Passes the test if the given arguments are equal. Otherwise fails -- with the given 'Context'. heqCtx2 :: ( MonadTest m , HasCallStack , Eq a , Eq b , Show a , Show b , forall x y. (Eq x, Eq y) => Eq (f x y) , forall x y. (Show x, Show y) => Show (f x y) ) => f a b -> f a b -> Context -> m () heqCtx2 x y ctx = do ok <- withFrozenCallStack $ evalNoSrc (x `eq2` y) if ok then success else withFrozenCallStack $ failContext ctx -- | Passes the test if the given arguments are equal. Otherwise fails -- with 'NoContext'. heq2 :: ( MonadTest m , HasCallStack , Eq a , Eq b , Show a , Show b , forall x y. (Eq x, Eq y) => Eq (f x y) , forall x y. (Show x, Show y) => Show (f x y) ) => f a b -> f a b -> m () heq2 x y = heqCtx2 x y NoContext infix 4 `hneq2` -- | Passes the test if the given arguments are not equal. Otherwise fails -- with the given 'Context'. hneqCtx2 :: ( MonadTest m , HasCallStack , Eq a , Eq b , Show a , Show b , forall x y. (Eq x, Eq y) => Eq (f x y) , forall x y. (Show x, Show y) => Show (f x y) ) => f a b -> f a b -> Context -> m () hneqCtx2 x y ctx = do ok <- withFrozenCallStack $ evalNoSrc (x `neq2` y) if ok then success else withFrozenCallStack $ failContext ctx -- | Passes the test if the given arguments are not equal. Otherwise fails -- with 'NoContext'. hneq2 :: ( MonadTest m , HasCallStack , Eq a , Eq b , Show a , Show b , forall x y. (Eq x, Eq y) => Eq (f x y) , forall x y. (Show x, Show y) => Show (f x y) ) => f a b -> f a b -> m () hneq2 x y = hneqCtx2 x y NoContext -- | Passes the test if the LHS implies the RHS. Otherwise fails with -- the given 'Context'. himplCtx :: ( Monad m , HasCallStack ) => Bool -> Bool -> Context -> PropertyT m () himplCtx False _ _ = discard himplCtx True b ctx = if b then success else withFrozenCallStack $ failContext ctx hedgehog-classes-0.2.5.4/src/Hedgehog/Classes/Comonad.hs0000644000000000000000000002611407346545000021074 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE QuantifiedConstraints #-} {-# LANGUAGE RankNTypes #-} #ifndef HAVE_COMONAD module Hedgehog.Classes.Comonad () where #else module Hedgehog.Classes.Comonad (comonadLaws) where import Control.Comonad import Hedgehog import Hedgehog.Classes.Common -- | Tests the following 'Comonad' laws: -- -- [__Extend/Extract Identity__]: @'extend' 'extract' ≡ 'id'@ -- [__Extract/Extend__]: @'extract' '.' 'extend' f ≡ f@ -- [__Extend/Extend__]: @'extend' f '.' 'extend' g ≡ 'extend' (f '.' 'extend' g)@ -- [__Extract Right Identity__]: @f '=>=' 'extract' ≡ f@ -- [__Extract Left Identity__]: @'extract' '=>=' f ≡ f@ -- [__Cokleisli Associativity__]: @(f '=>=' g) '=>=' h ≡ f '=>=' (g '=>=' h)@ -- [__Extract/Duplicate Identity__]: @'extract' '.' 'duplicate' ≡ 'id'@ -- [__Fmap Extract/Duplicate Identity__]: @'fmap' 'extract' '.' 'duplicate' ≡ 'id'@ -- [__Double Duplication__]: @'duplicate' '.' 'duplicate' ≡ 'fmap' 'duplicate' '.' 'duplicate'@ -- [__Extend/Fmap . Duplicate Identity__]: @'extend' f ≡ 'fmap' f '.' 'duplicate'@ -- [__Duplicate/Extend id Identity__]: @'duplicate' ≡ 'extend' 'id'@ -- [__Fmap/Extend Extract__]: @'fmap' f ≡ 'extend' (f '.' 'extract')@ -- [__Fmap/LiftW Isomorphism__]: @'fmap' ≡ 'liftW'@ comonadLaws :: ( Comonad f , forall x. Eq x => Eq (f x), forall x. Show x => Show (f x) ) => (forall x. Gen x -> Gen (f x)) -> Laws comonadLaws gen = Laws "Comonad" [ ("Extend/Extract Identity", extendExtractIdentity gen) , ("Extract/Extend", extractExtend gen) , ("Extend/Extend", extendExtend gen) , ("Extract Right Identity", extractRightIdentity gen) , ("Extract Left Identity", extractLeftIdentity gen) , ("Cokleisli Associativity", cokleisliAssociativity gen) , ("Extract/Duplicate Identity", extractDuplicateIdentity gen) , ("Fmap Extract/Duplicate Identity", fmapExtractDuplicateIdentity gen) , ("Double Duplication", doubleDup gen) , ("Extend/Fmap . Duplicate Identity", extendDuplicate gen) , ("Duplicate/Extend id Identity", duplicateExtendId gen) , ("Fmap/Extend Extract", fmapExtendExtract gen) , ("Fmap/LiftW Isomorphism", fmapLiftW gen) ] type ComonadProp f = ( Comonad f , forall x. Eq x => Eq (f x), forall x. Show x => Show (f x) ) => (forall x. Gen x -> Gen (f x)) -> Property extendExtractIdentity :: forall f. ComonadProp f extendExtractIdentity fgen = property $ do x <- forAll $ fgen genSmallInteger let lhs = extend extract x let rhs = x let ctx = contextualise $ LawContext { lawContextLawName = "Extend/Extract Identity", lawContextTcName = "Comonad" , lawContextLawBody = "extend extract" `congruency` "id" , lawContextReduced = reduced lhs rhs , lawContextTcProp = lawWhere [ "extend extract x" `congruency` "x, where" , "x = " ++ show x ] } heqCtx lhs rhs ctx extractExtend :: forall f. ComonadProp f extractExtend fgen = property $ do x <- forAll $ fgen genSmallInteger k <- forAll $ genLinearEquationW fgen let k' = runLinearEquationW k let lhs = extract . extend k' $ x let rhs = k' x let ctx = contextualise $ LawContext { lawContextLawName = "Extract/Extend", lawContextTcName = "Comonad" , lawContextLawBody = "extract . extend f" `congruency` "f" , lawContextReduced = reduced lhs rhs , lawContextTcProp = lawWhere [ "extract . extend f $ x" `congruency` "f x, where" , "f = " ++ show k , "x = " ++ show x ] } heqCtx lhs rhs ctx extendExtend :: forall f. ComonadProp f extendExtend fgen = property $ do x <- forAll $ fgen genSmallInteger f' <- forAll $ genLinearEquationW fgen g' <- forAll $ genLinearEquationW fgen let f = runLinearEquationW f' let g = runLinearEquationW g' let lhs = extend f . extend g $ x let rhs = extend (f . extend g) x let ctx = contextualise $ LawContext { lawContextLawName = "Extend/Extend", lawContextTcName = "Comonad" , lawContextLawBody = "extend f . extend g" `congruency` "extend (f . extend g)" , lawContextReduced = reduced lhs rhs , lawContextTcProp = lawWhere [ "extend f . extend g $ x" `congruency` "extend (f . extend g) $ x, where" , "f = " ++ show f' , "g = " ++ show g' , "x = " ++ show x ] } heqCtx lhs rhs ctx extractRightIdentity :: forall f. ComonadProp f extractRightIdentity fgen = property $ do x <- forAll $ fgen genSmallInteger f' <- forAll $ genLinearEquationW fgen let f = runLinearEquationW f' let lhs = f =>= extract $ x let rhs = f x let ctx = contextualise $ LawContext { lawContextLawName = "Extract Cokleisli Right Identity", lawContextTcName = "Comonad" , lawContextLawBody = "f =>= extract" `congruency` "f" , lawContextReduced = reduced lhs rhs , lawContextTcProp = lawWhere [ "f =>= extract $ x" `congruency` "f x, where" , "f = " ++ show f' , "x = " ++ show x ] } heqCtx lhs rhs ctx extractLeftIdentity :: forall f. ComonadProp f extractLeftIdentity fgen = property $ do x <- forAll $ fgen genSmallInteger f' <- forAll $ genLinearEquationW fgen let f = runLinearEquationW f' let lhs = extract =>= f $ x let rhs = f x let ctx = contextualise $ LawContext { lawContextLawName = "Extract Cokleisli Left Identity", lawContextTcName = "Comonad" , lawContextLawBody = "extract =>= f" `congruency` "f" , lawContextReduced = reduced lhs rhs , lawContextTcProp = lawWhere [ "extract =>= f $ x" `congruency` "f x, where" , "f = " ++ show f' , "x = " ++ show x ] } heqCtx lhs rhs ctx cokleisliAssociativity :: forall f. ComonadProp f cokleisliAssociativity fgen = property $ do x <- forAll $ fgen genSmallInteger f' <- forAll $ genLinearEquationW fgen g' <- forAll $ genLinearEquationW fgen h' <- forAll $ genLinearEquationW fgen let f = runLinearEquationW f' let g = runLinearEquationW g' let h = runLinearEquationW h' let lhs = (f =>= g) =>= h $ x let rhs = f =>= (g =>= h) $ x let ctx = contextualise $ LawContext { lawContextLawName = "Cokleisli Associativity", lawContextTcName = "Comonad" , lawContextLawBody = "(f =>= g) =>= h" `congruency` "f =>= (g =>= h)" , lawContextReduced = reduced lhs rhs , lawContextTcProp = lawWhere [ "(f =>= g) =>= h $ x" `congruency` "f =>= (g =>= h) $ x, where" , "f = " ++ show f' , "g = " ++ show g' , "h = " ++ show h' , "x = " ++ show x ] } heqCtx lhs rhs ctx extractDuplicateIdentity :: forall f. ComonadProp f extractDuplicateIdentity fgen = property $ do x <- forAll $ fgen genSmallInteger let lhs = extract . duplicate $ x let rhs = x let ctx = contextualise $ LawContext { lawContextLawName = "Extract/Duplicate Identity", lawContextTcName = "Comonad" , lawContextLawBody = "extract . duplicate" `congruency` "id" , lawContextReduced = reduced lhs rhs , lawContextTcProp = lawWhere [ "extract . duplicate $ x" `congruency` "x, where" , "x = " ++ show x ] } heqCtx lhs rhs ctx fmapExtractDuplicateIdentity :: forall f. ComonadProp f fmapExtractDuplicateIdentity fgen = property $ do x <- forAll $ fgen genSmallInteger let lhs = fmap extract . duplicate $ x let rhs = x let ctx = contextualise $ LawContext { lawContextLawName = "Fmap Extract/Duplicate Identity", lawContextTcName = "Comonad" , lawContextLawBody = "fmap extract . duplicate" `congruency` "id" , lawContextReduced = reduced lhs rhs , lawContextTcProp = lawWhere [ "fmap extract . duplicate $ x" `congruency` "x, where" , "x = " ++ show x ] } heqCtx lhs rhs ctx doubleDup :: forall f. ComonadProp f doubleDup fgen = property $ do x <- forAll $ fgen genSmallInteger let lhs = duplicate . duplicate $ x let rhs = fmap duplicate . duplicate $ x let ctx = contextualise $ LawContext { lawContextLawName = "Double Duplicate", lawContextTcName = "Comonad" , lawContextLawBody = "duplicate . duplicate" `congruency` "fmap duplicate . duplicate" , lawContextReduced = reduced lhs rhs , lawContextTcProp = lawWhere [ "duplicate . duplicate $ x" `congruency` "fmap duplicate . duplicate $ x, where" , "x = " ++ show x ] } heqCtx lhs rhs ctx extendDuplicate :: forall f. ComonadProp f extendDuplicate fgen = property $ do x <- forAll $ fgen genSmallInteger f' <- forAll $ genLinearEquationW fgen let f = runLinearEquationW f' let lhs = extend f $ x let rhs = fmap f . duplicate $ x let ctx = contextualise $ LawContext { lawContextLawName = "Extend/Fmap Duplicate", lawContextTcName = "Comonad" , lawContextLawBody = "extend f" `congruency` "fmap f . duplicate" , lawContextReduced = reduced lhs rhs , lawContextTcProp = lawWhere [ "extend f x" `congruency` "fmap f . duplicate $ x, where" , "f = " ++ show f' , "x = " ++ show x ] } heqCtx lhs rhs ctx duplicateExtendId :: forall f. ComonadProp f duplicateExtendId fgen = property $ do x <- forAll $ fgen genSmallInteger let lhs = duplicate x let rhs = extend id x let ctx = contextualise $ LawContext { lawContextLawName = "Duplicate/Extend Id", lawContextTcName = "Comonad" , lawContextLawBody = "duplicate" `congruency` "extend id" , lawContextReduced = reduced lhs rhs , lawContextTcProp = lawWhere [ "duplicate x" `congruency` "extend id x, where" , "x = " ++ show x ] } heqCtx lhs rhs ctx fmapExtendExtract :: forall f. ComonadProp f fmapExtendExtract fgen = property $ do x :: f Integer <- forAll $ fgen genSmallInteger f' <- forAll genLinearEquation let f = runLinearEquation f' let lhs = fmap f x let rhs = extend (f . extract) x let ctx = contextualise $ LawContext { lawContextLawName = "Fmap/Extend Extract", lawContextTcName = "Comonad" , lawContextLawBody = "fmap f" `congruency` "extend (f . extract)" , lawContextReduced = reduced lhs rhs , lawContextTcProp = lawWhere [ "fmap f x" `congruency` "extend (f . extract) x, where" , "f = " ++ show f' , "x = " ++ show x ] } heqCtx lhs rhs ctx fmapLiftW :: forall f. ComonadProp f fmapLiftW fgen = property $ do x <- forAll $ fgen genSmallInteger f' <- forAll genLinearEquation let f = runLinearEquation f' let lhs = fmap f x let rhs = liftW f x let ctx = contextualise $ LawContext { lawContextLawName = "Fmap/LiftW", lawContextTcName = "Comonad" , lawContextLawBody = "fmap" `congruency` "liftW" , lawContextReduced = reduced lhs rhs , lawContextTcProp = lawWhere [ "fmap f x" `congruency` "liftW f x, where" , "f = " ++ show f' , "x = " ++ show x ] } heqCtx lhs rhs ctx #endif hedgehog-classes-0.2.5.4/src/Hedgehog/Classes/Contravariant.hs0000644000000000000000000000476107346545000022333 0ustar0000000000000000{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE QuantifiedConstraints #-} {-# LANGUAGE RankNTypes #-} module Hedgehog.Classes.Contravariant (contravariantLaws) where import Data.Functor.Contravariant (Contravariant(..)) import Hedgehog import Hedgehog.Classes.Common -- | Tests the following 'Contravariant' laws: -- -- [__Identity__]: @'contramap' 'id'@ ≡ @'id'@ -- [__Composition__]: @'contramap' f '.' 'contramap' g@ ≡ @'contramap' (g '.' f)@ contravariantLaws :: ( Contravariant f , forall x. Eq x => Eq (f x), forall x. Show x => Show (f x) ) => (forall x. Gen x -> Gen (f x)) -> Laws contravariantLaws gen = Laws "Contravariant" [ ("Identity", contravariantIdentity gen) , ("Composition", contravariantComposition gen) ] contravariantIdentity :: ( Contravariant f , forall x. Eq x => Eq (f x), forall x. Show x => Show (f x) ) => (forall x. Gen x -> Gen (f x)) -> Property contravariantIdentity fgen = property $ do a <- forAll $ fgen genSmallInteger let lhs = contramap id a let rhs = id a let ctx = contextualise $ LawContext { lawContextLawName = "Identity", lawContextLawBody = "contramap id" `congruency` "id" , lawContextTcName = "Contravariant", lawContextTcProp = let showA = show a in lawWhere [ "contramap id x" `congruency` "id x, where" , "x = " ++ showA ] , lawContextReduced = reduced lhs rhs } heqCtx1 lhs rhs ctx contravariantComposition :: ( Contravariant f , forall x. Eq x => Eq (f x), forall x. Show x => Show (f x) ) => (forall x. Gen x -> Gen (f x)) -> Property contravariantComposition fgen = property $ do a <- forAll $ fgen genSmallInteger f' <- forAll genQuadraticEquation g' <- forAll genQuadraticEquation let f = runQuadraticEquation f' let g = runQuadraticEquation g' let lhs = contramap f (contramap g a) let rhs = contramap (g . f) a let ctx = contextualise $ LawContext { lawContextLawName = "Composition", lawContextLawBody = "contramap f . contramap g" `congruency` "contramap (g . f)" , lawContextTcName = "Contravariant", lawContextTcProp = let showF = show f'; showG = show g'; showA = show a; in lawWhere [ "contramap f . contramap g $ a" `congruency` "contramap (g . f) a, where" , "f = " ++ showF , "g = " ++ showG , "a = " ++ showA ] , lawContextReduced = reduced lhs rhs } heqCtx1 lhs rhs ctx hedgehog-classes-0.2.5.4/src/Hedgehog/Classes/Enum.hs0000644000000000000000000000700407346545000020415 0ustar0000000000000000{-# LANGUAGE ScopedTypeVariables #-} module Hedgehog.Classes.Enum (enumLaws, boundedEnumLaws) where import Hedgehog import Hedgehog.Classes.Common import qualified Hedgehog.Gen as Gen -- | Tests the following 'Enum' laws: -- -- [__Succ-Pred Identity__]: @'succ' '.' 'pred'@ ≡ @'id'@ -- [__Pred-Succ Identity__]: @'pred' '.' 'succ'@ ≡ @'id'@ enumLaws :: (Enum a, Eq a, Show a) => Gen a -> Laws enumLaws gen = Laws "Enum" [ ("Succ Pred Identity", succPredIdentity gen) , ("Pred Succ Identity", predSuccIdentity gen) ] -- | Tests the same laws as 'enumLaws', but uses the 'Bounded' -- constraint to ensure that 'succ' and 'pred' behave as though -- they are total. This should always be preferred if your type -- has a 'Bounded' instance. boundedEnumLaws :: (Bounded a, Enum a, Eq a, Show a) => Gen a -> Laws boundedEnumLaws gen = Laws "Bounded Enum" [ ("Succ Pred Identity", succPredBoundedIdentity gen) , ("Pred Succ Identity", predSuccBoundedIdentity gen) ] succPredIdentity :: forall a. (Enum a, Eq a, Show a) => Gen a -> Property succPredIdentity gen = property $ do x <- forAll gen let lhs = succ (pred x); rhs = x; let ctx = contextualise $ LawContext { lawContextLawName = "Succ-Pred Identity" , lawContextLawBody = "succ . pred" `congruency` "id" , lawContextTcName = "Enum" , lawContextTcProp = let showX = show x in lawWhere [ "succ . pred $ x" `congruency` "id x, where" , "x = " ++ showX ] , lawContextReduced = reduced lhs rhs } heqCtx lhs rhs ctx predSuccIdentity :: forall a. (Enum a, Eq a, Show a) => Gen a -> Property predSuccIdentity gen = property $ do x <- forAll gen let lhs = pred (succ x); rhs = x; let ctx = contextualise $ LawContext { lawContextLawName = "Pred-Succ Identity" , lawContextLawBody = "pred . succ" `congruency` "id" , lawContextTcName = "Enum" , lawContextTcProp = let showX = show x in lawWhere [ "pred . succ $ x" `congruency` "id x, where" , "x = " ++ showX ] , lawContextReduced = reduced lhs rhs } heqCtx lhs rhs ctx succPredBoundedIdentity :: forall a. (Bounded a, Enum a, Eq a, Show a) => Gen a -> Property succPredBoundedIdentity gen = property $ do x <- forAll $ Gen.filter (/= minBound) gen let lhs = succ (pred x); rhs = x; let ctx = contextualise $ LawContext { lawContextLawName = "Succ-Pred Identity" , lawContextLawBody = "succ . pred" `congruency` "id" , lawContextTcName = "Enum" , lawContextTcProp = let showX = show x in lawWhere [ "succ . pred $ x" `congruency` "id x, where" , "x = " ++ showX ] , lawContextReduced = reduced lhs rhs } heqCtx lhs rhs ctx predSuccBoundedIdentity :: forall a. (Bounded a, Enum a, Eq a, Show a) => Gen a -> Property predSuccBoundedIdentity gen = property $ do x <- forAll $ Gen.filter (/= maxBound) gen let lhs = pred (succ x); rhs = x; let ctx = contextualise $ LawContext { lawContextLawName = "Pred-Succ Identity" , lawContextLawBody = "pred . succ" `congruency` "id" , lawContextTcName = "Enum" , lawContextTcProp = let showX = show x in lawWhere [ "pred . succ $ x" `congruency` "id x, where" , "x = " ++ showX ] , lawContextReduced = reduced lhs rhs } heqCtx lhs rhs ctx hedgehog-classes-0.2.5.4/src/Hedgehog/Classes/Eq.hs0000644000000000000000000000626107346545000020062 0ustar0000000000000000{-# LANGUAGE ScopedTypeVariables #-} module Hedgehog.Classes.Eq (eqLaws) where import Hedgehog import Hedgehog.Classes.Common -- | Tests the following 'Eq' laws: -- -- [__Reflexivity__]: @x '==' x@ ≡ @'True'@ -- [__Symmetry__]: @x '==' y@ ≡ @y '==' x@ -- [__Transitivity__]: @x '==' y '&&' y '==' z@ ≡ @x '==' z@ -- [__Negation__]: @x '/=' y@ ≡ @'not' (x '==' y)@ eqLaws :: (Eq a, Show a) => Gen a -> Laws eqLaws gen = Laws "Eq" [ ("Transitive", eqTransitive gen) , ("Symmetric", eqSymmetric gen) , ("Reflexive", eqReflexive gen) , ("Negation", eqNegation gen) ] eqTransitive :: forall a. (Eq a, Show a) => Gen a -> Property eqTransitive gen = property $ do a <- forAll gen b <- forAll gen c <- forAll gen let lhs = a == b && b == c; rhs = a == c let ctx = contextualise $ LawContext { lawContextLawName = "Transitivity", lawContextLawBody = "a == b ∧ b == c" `congruency` "a == c" , lawContextTcName = "Eq", lawContextTcProp = let showA = show a; showB = show b; showC = show c; in lawWhere [ "a == b ∧ b == c" `congruency` "a == c, where" , "a = " ++ showA , "b = " ++ showB , "c = " ++ showC ] , lawContextReduced = reduced lhs rhs } case a == b of True -> case b == c of { True -> heqCtx a c ctx; False -> hneqCtx a c ctx } False -> case b == c of { True -> hneqCtx a c ctx; False -> success } eqSymmetric :: forall a. (Eq a, Show a) => Gen a -> Property eqSymmetric gen = property $ do a <- forAll gen b <- forAll gen let lhs = a == b; rhs = b == a let ctx = contextualise $ LawContext { lawContextLawName = "Symmetry", lawContextLawBody = "a == b" `congruency` "b == a" , lawContextTcName = "Eq", lawContextTcProp = let showA = show a; showB = show b; in lawWhere [ "a == b" `congruency` "b == a, where" , "a = " ++ showA , "b = " ++ showB ] , lawContextReduced = reduced lhs rhs } heqCtx lhs rhs ctx eqReflexive :: forall a. (Eq a, Show a) => Gen a -> Property eqReflexive gen = property $ do a <- forAll gen let lhs = a let rhs = a let ctx = contextualise $ LawContext { lawContextLawName = "Reflexivity", lawContextLawBody = "a" `congruency` "a" , lawContextTcName = "Eq" , lawContextTcProp = let showA = show a in lawWhere [ "a" `congruency` "a, where", "a = " ++ showA ] , lawContextReduced = reduced a a } heqCtx lhs rhs ctx eqNegation :: forall a. (Eq a, Show a) => Gen a -> Property eqNegation gen = property $ do x <- forAll gen y <- forAll gen let lhs = x /= y let rhs = not (x == y) let ctx = contextualise $ LawContext { lawContextLawName = "Negation", lawContextLawBody = "x /= y" `congruency` "not (x == y)" , lawContextTcName = "Eq" , lawContextReduced = reduced lhs rhs , lawContextTcProp = let showX = show x; showY = show y; in lawWhere [ "x /= y" `congruency` "not (x == y), where" , "x = " ++ showX , "y = " ++ showY ] } heqCtx lhs rhs ctx hedgehog-classes-0.2.5.4/src/Hedgehog/Classes/Foldable.hs0000644000000000000000000003501007346545000021217 0ustar0000000000000000{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE QuantifiedConstraints #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE LambdaCase #-} module Hedgehog.Classes.Foldable (foldableLaws) where import Hedgehog import Hedgehog.Classes.Common import Control.Monad.IO.Class (MonadIO(..)) import Control.Exception (ErrorCall(..), try, evaluate) import Data.Monoid (Sum(..), Endo(..), Dual(..)) import qualified Data.Foldable as Foldable -- | Tests the following 'Foldable' laws: -- -- [__Fold__]: @'Foldable.fold' ≡ 'Foldable.foldMap' 'id'@ -- [__FoldMap__]: @'Foldable.foldMap' f ≡ 'Foldable.foldr' ('mappend' '.' f) 'mempty'@ -- [__Foldr__]: @'Foldable.foldr' f z t ≡ 'appEndo' ('Foldable.foldMap' ('Endo' '.' f) t) z@ -- [__Foldr'__]: @'Foldable.foldr'' f z0 t ≡ 'Foldable.foldl' f' 'id' t z0, where f' k x z = k '$!' f x z@ -- [__Foldl__]: @'Foldable.foldl' f z t ≡ 'appEndo' ('getDual' ('Foldable.foldMap' ('Dual' '.' 'Endo' '.' 'flip' f) t)) z@ -- [__Foldl'__]: @'Foldable.foldl'' f z0 xs ≡ 'Foldable.foldr' f' 'id' xs z0, where f' x k z = k '$!' f z x@ -- [__Foldl1__]: @'Foldable.foldl1' f t ≡ let (x:xs) = 'Foldable.toList' t in 'foldl' f x xs@ -- [__Foldr1__]: @'Foldable.foldr1' f t ≡ let (xs,x)@ = @unsnoc ('Foldable.toList' t) in 'foldr' f x xs@ -- [__ToList__]: @'Foldable.toList' ≡ 'Foldable.foldr' (:) []@ -- [__Null__]: @'Foldable.null' ≡ 'Foldable.foldr' ('const' ('const' 'False')) 'True'@ -- [__Length__]: @'Foldable.length' ≡ 'getSum' '.' 'Foldable.foldMap' ('const' ('Sum' 1))@ -- -- This additionally tests that the user's implementations of 'Foldable.foldr'' and 'Foldable.foldl'' are strict in their accumulators. foldableLaws :: ( Foldable f , forall x. Eq x => Eq (f x), forall x. Show x => Show (f x) ) => (forall x. Gen x -> Gen (f x)) -> Laws foldableLaws gen = Laws "Foldable" [ ("fold", foldableFold gen) , ("foldMap", foldableFoldMap gen) , ("foldr", foldableFoldr gen) , ("foldr'", foldableFoldr' gen) , ("foldl", foldableFoldl gen) , ("foldl'", foldableFoldl' gen) , ("foldl1", foldableFoldl1 gen) , ("foldr1", foldableFoldr1 gen) , ("toList", foldableToList gen) , ("null", foldableNull gen) , ("length", foldableLength gen) ] foldableFold :: ( Foldable f , forall x. Eq x => Eq (f x), forall x. Show x => Show (f x) ) => (forall x. Gen x -> Gen (f x)) -> Property foldableFold fgen = property $ do a <- forAll $ fgen $ genVerySmallList genSmallInteger let lhs = Foldable.fold a let rhs = Foldable.foldMap id a let ctx = contextualise $ LawContext { lawContextLawName = "Fold" , lawContextLawBody = "fold" `congruency` "foldMap id" , lawContextTcName = "Foldable" , lawContextTcProp = let showA = show a in lawWhere [ "fold a" `congruency` "foldMap id a, where" , "a = " ++ showA ] , lawContextReduced = reduced lhs rhs } heqCtx lhs rhs ctx foldableFoldMap :: ( Foldable f , forall x. Eq x => Eq (f x), forall x. Show x => Show (f x) ) => (forall x. Gen x -> Gen (f x)) -> Property foldableFoldMap fgen = property $ do a <- forAll $ fgen genSmallInteger e <- forAll genQuadraticEquation let f = (:[]) . runQuadraticEquation e let lhs = Foldable.foldMap f a let rhs = Foldable.foldr (mappend . f) mempty a let ctx = contextualise $ LawContext { lawContextLawName = "FoldMap" , lawContextLawBody = "foldMap f" `congruency` "foldr (mappend . f) mempty" , lawContextTcName = "Foldable" , lawContextTcProp = let showA = show a showF = "(:[]) $ " ++ show e in lawWhere [ "foldMap f a" `congruency` "foldr (mappend . f) mempty a, where" , "f = " ++ showF , "a = " ++ showA ] , lawContextReduced = reduced lhs rhs } heqCtx lhs rhs ctx foldableFoldr :: ( Foldable f , forall x. Eq x => Eq (f x), forall x. Show x => Show (f x) ) => (forall x. Gen x -> Gen (f x)) -> Property foldableFoldr fgen = property $ do e <- forAll genLinearEquationTwo z <- forAll genSmallInteger t <- forAll $ fgen genSmallInteger let f = runLinearEquationTwo e let lhs = Foldable.foldr f z t let rhs = appEndo (Foldable.foldMap (Endo . f) t) z let ctx = contextualise $ LawContext { lawContextLawName = "Foldr" , lawContextLawBody = "foldr f z t" `congruency` "appEndo (foldMap (Endo . f) t) z" , lawContextTcName = "Foldable" , lawContextTcProp = let showT = show t showF = show e showZ = show z in lawWhere [ "foldr f z t" `congruency` "appEndo (foldMap (Endo . f) t) z" , "f = " ++ showF , "z = " ++ showZ , "t = " ++ showT ] , lawContextReduced = reduced lhs rhs } heqCtx lhs rhs ctx foldableFoldl :: ( Foldable f , forall x. Eq x => Eq (f x), forall x. Show x => Show (f x) ) => (forall x. Gen x -> Gen (f x)) -> Property foldableFoldl fgen = property $ do e <- forAll genLinearEquationTwo z <- forAll genSmallInteger t <- forAll $ fgen genSmallInteger let f = runLinearEquationTwo e let lhs = Foldable.foldl f z t let rhs = appEndo (getDual (Foldable.foldMap (Dual . Endo . flip f) t)) z let ctx = contextualise $ LawContext { lawContextLawName = "Foldl" , lawContextLawBody = "foldl f z t" `congruency` "appEndo (getDual (foldMap (Dual . Endo . flip f) t)) z" , lawContextTcName = "Foldable" , lawContextTcProp = let showT = show t showF = show e showZ = show z in lawWhere [ "foldl f z t" `congruency` "appEndo (getDual (foldMap (Dual . Endo . flip f) t)) z" , "f = " ++ showF , "z = " ++ showZ , "t = " ++ showT ] , lawContextReduced = reduced lhs rhs } heqCtx lhs rhs ctx ctxNotStrict :: String -> Context ctxNotStrict str = Context $ "Your implementation of " ++ str ++ " is not strict." foldableFoldr' :: ( Foldable f , forall x. Eq x => Eq (f x), forall x. Show x => Show (f x) ) => (forall x. Gen x -> Gen (f x)) -> Property foldableFoldr' fgen = property $ do xs <- forAll $ fgen (genBottom genSmallInteger) let f :: Bottom Integer -> Integer -> Integer f a b = case a of BottomUndefined -> error "foldableFoldr': your foldr' is not strict!" BottomValue v -> if even v then v else b z0 <- forAll genSmallInteger (rhs, ctx1) <- liftIO $ do let f' k x z = k $! f x z e <- try (evaluate (Foldable.foldl f' id xs z0)) case e of Left (_ :: ErrorCall) -> pure (Nothing, ctxNotStrict "foldr'") Right i -> pure (Just i, NoContext) (lhs, ctx2) <- liftIO $ do e <- try (evaluate (Foldable.foldr' f z0 xs)) case e of Left (_ :: ErrorCall) -> pure (Nothing, ctxNotStrict "foldr'") Right i -> pure (Just i, NoContext) let ctx = case ctx1 of NoContext -> case ctx2 of NoContext -> contextualise $ LawContext { lawContextLawName = "Foldr'" , lawContextLawBody = "foldr' f z0 t" `congruency` "foldl f' id t z0, where f' k x z = k $! f x z" , lawContextTcName = "Foldable" , lawContextTcProp = let showT = show xs showF = "\\a b -> case a of\n BottomUndefined -> error \"foldableFoldr': not strict\"\n BottomValue v -> if even v then v else b" showZ = show z0 in lawWhere [ "foldr' f z0 t" `congruency` "foldl f' id t z0, where f' k x z = k $! f x z" , "f = " ++ showF , "z0 = " ++ showZ , "t = " ++ showT ] , lawContextReduced = reduced lhs rhs } c2 -> c2 c1 -> c1 heqCtx lhs rhs ctx foldableFoldl' :: ( Foldable f , forall x. Eq x => Eq (f x), forall x. Show x => Show (f x) ) => (forall x. Gen x -> Gen (f x)) -> Property foldableFoldl' fgen = property $ do xs <- forAll $ fgen (genBottom genSmallInteger) let f :: Integer -> Bottom Integer -> Integer f a b = case b of BottomUndefined -> error "foldableFoldl': your foldl' is not strict!" BottomValue v -> if even v then a else v let z0 = 0 (rhs,ctx1) <- liftIO $ do let f' x k z = k $! f z x e <- try (evaluate (Foldable.foldr f' id xs z0)) case e of Left (_ :: ErrorCall) -> pure (Nothing, ctxNotStrict "foldl'") Right i -> pure (Just i, NoContext) (lhs,ctx2) <- liftIO $ do e <- try (evaluate (Foldable.foldl' f z0 xs)) case e of Left (_ :: ErrorCall) -> pure (Nothing, ctxNotStrict "foldl'") Right i -> pure (Just i, NoContext) let ctx = case ctx1 of NoContext -> case ctx2 of NoContext -> contextualise $ LawContext { lawContextLawName = "Foldl'" , lawContextLawBody = "foldl' f z0 xs" `congruency` "foldr f' id xs z0, where f' x k z = k $! f z x" , lawContextTcName = "Foldable" , lawContextTcProp = let showT = show xs showF = "\\a b -> case a of\n BottomUndefined -> error \"foldableFoldr': not strict\"\n BottomValue v -> if even v then v else b" showZ = show z0 in lawWhere [ "foldl' f z0 xs" `congruency` "foldr f' id xs z0, where f' x k z = k $! f z x" , "f = " ++ showF , "z0 = " ++ showZ , "t = " ++ showT ] , lawContextReduced = reduced lhs rhs } c2 -> c2 c1 -> c1 heqCtx lhs rhs ctx foldableFoldl1 :: ( Foldable f , forall x. Eq x => Eq (f x), forall x. Show x => Show (f x) ) => (forall x. Gen x -> Gen (f x)) -> Property foldableFoldl1 fgen = property $ do e <- forAll genLinearEquationTwo t <- forAll $ fgen genSmallInteger case compatToList t of [] -> success (x:xs) -> let f = runLinearEquationTwo e lhs = Foldable.foldl1 f t rhs = Foldable.foldl f x xs ctx = contextualise $ LawContext { lawContextLawName = "Foldl1" , lawContextLawBody = "foldl1 f t" `congruency` "let (x:xs) = toList t in foldl f x xs" , lawContextTcName = "Foldable" , lawContextTcProp = let showF = show e showT = show t showX = show x showXS = show xs in lawWhere [ "foldl1 f t" `congruency` "let (x:xs) = toList t in foldl f x xs, where" , "f = " ++ showF , "t = " ++ showT , "x = " ++ showX , "xs = " ++ showXS ] , lawContextReduced = reduced lhs rhs } in heqCtx lhs rhs ctx foldableFoldr1 :: ( Foldable f , forall x. Eq x => Eq (f x), forall x. Show x => Show (f x) ) => (forall x. Gen x -> Gen (f x)) -> Property foldableFoldr1 fgen = property $ do e <- forAll genLinearEquationTwo t <- forAll $ fgen genSmallInteger case unsnoc (compatToList t) of Nothing -> success Just (xs, x) -> let f = runLinearEquationTwo e lhs = Foldable.foldr1 f t rhs = Foldable.foldr f x xs ctx = contextualise $ LawContext { lawContextLawName = "Foldr1" , lawContextLawBody = "foldr1 f t" `congruency` "let (xs, x) = unsnoc (toList t) in foldr f x xs" , lawContextTcName = "Foldable" , lawContextTcProp = let showF = show e showT = show t showX = show x showXS = show xs in lawWhere [ "foldr1 f t" `congruency` "let (xs, x) = unsnoc (toList t) in foldr f x xs, where" , "f = " ++ showF , "t = " ++ showT , "x = " ++ showX , "xs = " ++ showXS ] , lawContextReduced = reduced lhs rhs } in heqCtx lhs rhs ctx foldableToList :: ( Foldable f , forall x. Eq x => Eq (f x), forall x. Show x => Show (f x) ) => (forall x. Gen x -> Gen (f x)) -> Property foldableToList fgen = property $ do t <- forAll $ fgen genSmallInteger let lhs = Foldable.toList t let rhs = Foldable.foldr (:) [] t let ctx = contextualise $ LawContext { lawContextLawName = "ToList" , lawContextLawBody = "toList" `congruency` "foldr (:) []" , lawContextTcName = "Foldable" , lawContextTcProp = let showT = show t in lawWhere [ "toList t" `congruency` "foldr (:) [] t, where" , "t = " ++ showT ] , lawContextReduced = reduced lhs rhs } heqCtx lhs rhs ctx foldableNull :: ( Foldable f , forall x. Eq x => Eq (f x), forall x. Show x => Show (f x) ) => (forall x. Gen x -> Gen (f x)) -> Property foldableNull fgen = property $ do t <- forAll $ fgen genSmallInteger let lhs = Foldable.null t let rhs = Foldable.foldr (const (const False)) True t let ctx = contextualise $ LawContext { lawContextLawName = "Null" , lawContextLawBody = "null" `congruency` "foldr (const (const False)) True" , lawContextTcName = "Foldable" , lawContextTcProp = let showT = show t in lawWhere [ "null t" `congruency` "foldr (const (const False)) True t, where" , "t = " ++ showT ] , lawContextReduced = reduced lhs rhs } heqCtx lhs rhs ctx foldableLength :: ( Foldable f , forall x. Eq x => Eq (f x), forall x. Show x => Show (f x) ) => (forall x. Gen x -> Gen (f x)) -> Property foldableLength fgen = property $ do t <- forAll $ fgen genSmallInteger let lhs = Foldable.length t let rhs = getSum (Foldable.foldMap (const (Sum 1)) t) let ctx = contextualise $ LawContext { lawContextLawName = "Length" , lawContextLawBody = "length" `congruency` "getSum . foldMap (const (Sum 1))" , lawContextTcName = "Foldable" , lawContextTcProp = let showT = show t in lawWhere [ "length t" `congruency` "getSum . foldMap (const (Sum 1)) $ t, where" , "t = " ++ showT ] , lawContextReduced = reduced lhs rhs } heqCtx lhs rhs ctx unsnoc :: [a] -> Maybe ([a], a) unsnoc = \case [] -> Nothing [x] -> Just ([], x) (x:y:xs) -> fmap (\(bs,b) -> (x:bs,b)) (unsnoc (y : xs)) compatToList :: Foldable f => f a -> [a] compatToList = Foldable.foldMap (\x -> [x]) hedgehog-classes-0.2.5.4/src/Hedgehog/Classes/Functor.hs0000644000000000000000000000617507346545000021141 0ustar0000000000000000{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE QuantifiedConstraints #-} {-# LANGUAGE RankNTypes #-} module Hedgehog.Classes.Functor (functorLaws) where import Hedgehog import Hedgehog.Classes.Common -- | Tests the following 'Functor' laws: -- -- [__Identity__]: @'fmap' 'id'@ ≡ @'id'@ -- [__Composition__]: @'fmap' f '.' 'fmap' g@ ≡ @'fmap' (f '.' g)@ -- [__Const__]: @'fmap' ('const' x)@ ≡ @x '<$'@ functorLaws :: ( Functor f , forall x. Eq x => Eq (f x), forall x. Show x => Show (f x) ) => (forall x. Gen x -> Gen (f x)) -> Laws functorLaws gen = Laws "Functor" [ ("Identity", functorIdentity gen) , ("Composition", functorComposition gen) , ("Const", functorConst gen) ] functorIdentity :: ( Functor f , forall x. Eq x => Eq (f x), forall x. Show x => Show (f x) ) => (forall x. Gen x -> Gen (f x)) -> Property functorIdentity fgen = property $ do a <- forAll $ fgen genSmallInteger let lhs = fmap id a let rhs = id a let ctx = contextualise $ LawContext { lawContextLawName = "Identity", lawContextTcName = "Functor" , lawContextLawBody = "fmap id" `congruency` "id" , lawContextTcProp = let showA = show a in lawWhere [ "fmap id a" `congruency` "id a, where" , "a = " ++ showA ] , lawContextReduced = reduced lhs rhs } heqCtx lhs rhs ctx functorComposition :: ( Functor f , forall x. Eq x => Eq (f x), forall x. Show x => Show (f x) ) => (forall x. Gen x -> Gen (f x)) -> Property functorComposition fgen = property $ do a <- forAll $ fgen genSmallInteger let f = func2; g = func1 let lhs = fmap f (fmap g a) let rhs = fmap (f . g) a let ctx = contextualise $ LawContext { lawContextLawName = "Composition", lawContextTcName = "Functor" , lawContextLawBody = "fmap f . fmap g" `congruency` "fmap (f . g)" , lawContextTcProp = let showA = show a showF = "\\(a,b) -> (odd a, if even a then Left (compare a b) else Right (b + 2)" showG = "\\i -> (div (i + 5) 3, i * i - 2 * i + 1)" in lawWhere [ "fmap f . fmap g $ a" `congruency` "fmap (f . g) a, where" , "f = " ++ showF , "g = " ++ showG , "a = " ++ showA ] , lawContextReduced = reduced lhs rhs } heqCtx lhs rhs ctx functorConst :: ( Functor f , forall x. Eq x => Eq (f x), forall x. Show x => Show (f x) ) => (forall x. Gen x -> Gen (f x)) -> Property functorConst fgen = property $ do a <- forAll $ fgen genSmallInteger let x = 'X' let lhs = fmap (const x) a let rhs = x <$ a let ctx = contextualise $ LawContext { lawContextLawName = "Const", lawContextTcName = "Functor" , lawContextLawBody = "fmap (const x)" `congruency` "x <$" , lawContextTcProp = let showA = show a showX = show x in lawWhere [ "fmap (const x) a" `congruency` "x <$ a, where" , "x = " ++ showX , "a = " ++ showA ] , lawContextReduced = reduced lhs rhs } heqCtx lhs rhs ctx hedgehog-classes-0.2.5.4/src/Hedgehog/Classes/Generic.hs0000644000000000000000000000577707346545000021104 0ustar0000000000000000{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE QuantifiedConstraints #-} module Hedgehog.Classes.Generic (genericLaws) where import Hedgehog import Hedgehog.Classes.Common import GHC.Generics (Generic(..)) -- | Tests the following 'Generic' laws: -- -- [__From-To Inverse__]: @'from' '.' 'to'@ ≡ @'id'@ -- [__To-From Inverse__]: @'to' '.' 'from'@ ≡ @'id'@ genericLaws :: ( Generic a, Eq a, Show a , Eq (Rep a x), Show (Rep a x) ) => Gen a -> Gen (Rep a x) -> Laws genericLaws gena genr = Laws "Generic" [ ("From-To inverse", fromToInverse gena genr) , ("To-From inverse", toFromInverse gena genr) ] fromToInverse :: forall a x. ( Generic a , Eq (Rep a x) , Show (Rep a x) ) => Gen a -> Gen (Rep a x) -> Property fromToInverse _gena genr = property $ do r <- forAll genr let lhs = r let rhs = from (to r :: a) let ctx = contextualise $ LawContext { lawContextLawName = "From-To inverse", lawContextTcName = "Generic" , lawContextLawBody = "from . to" `congruency` "id" , lawContextTcProp = let showR = show r in lawWhere [ "from . to $ r" `congruency` "id r, where" , "r = " ++ showR ] , lawContextReduced = reduced lhs rhs } heqCtx lhs rhs ctx toFromInverse :: forall a x. ( Generic a , Eq a , Show a ) => Gen a -> Gen (Rep a x) -> Property toFromInverse gena _genr = property $ do v <- forAll gena let lhs = to (from v) let rhs = v let ctx = contextualise $ LawContext { lawContextLawName = "To-From inverse", lawContextTcName = "Generic" , lawContextLawBody = "to . from" `congruency` "id" , lawContextTcProp = let showV = show v in lawWhere [ "to . from $ v" `congruency` "id v, where" , "v = " ++ showV ] , lawContextReduced = reduced lhs rhs } heqCtx lhs rhs ctx {- type Generic1Prop f = ( Generic1 f , forall x. Eq x => Eq (f x) , forall x. Show x => Show (f x) , forall x. Eq x => Eq (Rep1 f x) , forall x. Show x => Show (Rep1 f x) ) => (forall x. Gen x -> Gen (f x)) -> (forall x. Gen x -> Gen (Rep1 f x)) -> Property fromToInverse1 :: forall f. Generic1Prop f fromToInverse1 _genf genr = property $ do r <- forAll $ genr genSmallInteger r === (from1 (to1 r :: f Integer)) toFromInverse1 :: forall f. Generic1Prop f toFromInverse1 genf _genr = property $ do v <- forAll $ genf genSmallInteger v === (to1 . from1 $ v) -} {- generic1Laws :: ( Generic1 f , forall x. Eq x => Eq (f x) , forall x. Show x => Show (f x) , forall x. Eq x => Eq (Rep1 f x) , forall x. Show x => Show (Rep1 f x) ) => (forall x. Gen x -> Gen (f x)) -> (forall x. Gen x -> Gen (Rep1 f x)) -> Laws generic1Laws genf genr = Laws "Generic1" [ ("From1-To1 inverse", fromToInverse1 genf genr) , ("To1-From1 inverse", toFromInverse1 genf genr) ] -} hedgehog-classes-0.2.5.4/src/Hedgehog/Classes/Integral.hs0000644000000000000000000000537007346545000021262 0ustar0000000000000000{-# LANGUAGE ScopedTypeVariables #-} module Hedgehog.Classes.Integral (integralLaws) where import Hedgehog import Hedgehog.Classes.Common -- | Tests the following 'Integral' laws: -- -- [__Quotient Remainder__]: @'quot' x y '*' y '+' ('rem' x y)@ ≡ @x@ -- [__Division Modulus__]: @('div' x y) '*' y '+' ('mod' x y)@ ≡ @x@ -- [__Integer Roundtrip__]: @'fromInteger' '.' 'toInteger'@ ≡ @'id'@ integralLaws :: (Integral a, Show a) => Gen a -> Laws integralLaws gen = Laws "Integral" [ ("Quotient Remainder", integralQuotientRemainder gen) , ("Division Modulus", integralDivisionModulus gen) , ("Integer Roundtrip", integralIntegerRoundtrip gen) ] integralQuotientRemainder :: forall a. (Integral a, Show a) => Gen a -> Property integralQuotientRemainder gen = property $ do x <- forAll gen y <- forAll gen let lhs = (quot x y) * y + (rem x y) let rhs = x let ctx = contextualise $ LawContext { lawContextLawName = "Quotient Remainder", lawContextTcName = "Integral" , lawContextLawBody = "quot x y * y + (rem x y)" `congruency` "x" , lawContextTcProp = let showX = show x; showY = show y; in lawWhere [ "quot x y * y + (rem x y)" `congruency` "x, where" , "x = " ++ showX , "y = " ++ showY ] , lawContextReduced = reduced lhs rhs } heqCtx lhs rhs ctx integralDivisionModulus :: forall a. (Integral a, Show a) => Gen a -> Property integralDivisionModulus gen = property $ do x <- forAll gen y <- forAll gen let lhs = (div x y) * y + (mod x y) let rhs = x let ctx = contextualise $ LawContext { lawContextLawName = "Division Modulus", lawContextTcName = "Integral" , lawContextLawBody = "(div x y) * y + (mod x y)" `congruency` "x" , lawContextTcProp = let showX = show x; showY = show y; in lawWhere [ "(div x y) * y + (mod x y)" `congruency` "x, where" , "x = " ++ showX , "y = " ++ showY ] , lawContextReduced = reduced lhs rhs } heqCtx lhs rhs ctx integralIntegerRoundtrip :: forall a. (Integral a, Show a) => Gen a -> Property integralIntegerRoundtrip gen = property $ do x <- forAll gen let lhs = fromInteger (toInteger x) let rhs = x let ctx = contextualise $ LawContext { lawContextLawName = "Integer Roundtrip", lawContextTcName = "Integral" , lawContextLawBody = "fromInteger . toInteger" `congruency` "id" , lawContextTcProp = let showX = show x; in lawWhere [ "fromInteger . toInteger $ x" `congruency` "id x, where" , "x = " ++ showX ] , lawContextReduced = reduced lhs rhs } heqCtx lhs rhs ctx hedgehog-classes-0.2.5.4/src/Hedgehog/Classes/Json.hs0000644000000000000000000000474607346545000020434 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE ScopedTypeVariables #-} #ifndef HAVE_AESON module Hedgehog.Classes.Json () where #else module Hedgehog.Classes.Json (jsonLaws) where import Hedgehog import Hedgehog.Classes.Common import Data.Aeson (FromJSON, ToJSON(toJSON)) import qualified Data.Aeson as Aeson -- | Tests the following 'ToJSON' / 'FromJSON' laws: -- -- [__Encoding Partial Isomorphism__]: @'Aeson.decode' '.' 'Aeson.encode'@ ≡ @'Just'@ -- [__Encoding Equals Value__]: @'Aeson.decode' '.' 'Aeson.encode'@ ≡ @'Just' '.' 'Aeson.toJSON'@ jsonLaws :: (FromJSON a, ToJSON a, Eq a, Show a) => Gen a -> Laws jsonLaws gen = Laws "ToJSON/FromJSON" [ ("Partial Isomorphism", jsonEncodingPartialIsomorphism gen) , ("Encoding equals value", jsonEncodingEqualsValue gen) ] jsonEncodingPartialIsomorphism :: forall a. (ToJSON a, FromJSON a, Show a, Eq a) => Gen a -> Property jsonEncodingPartialIsomorphism gen = property $ do x <- forAll gen let encoded = Aeson.encode x let lhs = Aeson.decode encoded let rhs = Just x let ctx = contextualise $ LawContext { lawContextLawName = "Partial Isomorphism", lawContextTcName = "ToJSON/FromJSON" , lawContextLawBody = "decode . encode" `congruency` "Just" , lawContextTcProp = let showX = show x showEncoded = show encoded in lawWhere [ "decode . encode $ x" `congruency` "Just x, where" , "x = " ++ showX , "encode x = " ++ showEncoded ] , lawContextReduced = reduced lhs rhs } heqCtx lhs rhs ctx jsonEncodingEqualsValue :: forall a. (ToJSON a, Show a) => Gen a -> Property jsonEncodingEqualsValue gen = property $ do x <- forAll gen let encoded = Aeson.encode x let decoded = Aeson.decode encoded :: Maybe Aeson.Value let lhs = decoded let rhs = Just (toJSON x) let ctx = contextualise $ LawContext { lawContextLawName = "Encoding equals value", lawContextTcName = "ToJSON" , lawContextLawBody = "decode . encode" `congruency` "Just . toJSON" , lawContextTcProp = let showX = show x showEncoded = show encoded showDecoded = show decoded in lawWhere [ "decode . encode $ x" `congruency` "Just . toJSON, where" , "x = " ++ showX , "encoded = " ++ showEncoded , "decoded = " ++ showDecoded ] , lawContextReduced = reduced lhs rhs } heqCtx lhs rhs ctx #endif hedgehog-classes-0.2.5.4/src/Hedgehog/Classes/MVector.hs0000644000000000000000000003603007346545000021071 0ustar0000000000000000-- | -- Module: Hedgehog.Classes.MVector -- Copyright: (c) 2019-2020 Andrew Lelechenko -- Licence: BSD3 -- {-# LANGUAGE CPP #-} {-# LANGUAGE ScopedTypeVariables #-} #if !HAVE_VECTOR module Hedgehog.Classes.MVector () where #else module Hedgehog.Classes.MVector ( muvectorLaws ) where import Control.Monad (when) import Control.Monad.ST import qualified Data.Vector.Generic.Mutable as MU (basicInitialize) import qualified Data.Vector.Unboxed.Mutable as MU import Hedgehog import Hedgehog.Classes.Common import qualified Hedgehog.Gen as Gen import qualified Hedgehog.Range as Range -- | Test that a 'Vector.Unboxed.MVector' instance obey several laws. muvectorLaws :: (Eq a, MU.Unbox a, Show a) => Gen a -> Laws muvectorLaws gen = Laws "Vector.Unboxed.MVector" [ ("New-Length", newLength gen) , ("Replicate-Length", replicateLength gen) , ("Slice-Length", sliceLength gen) , ("Grow-Length", growLength gen) , ("Write-Read", writeRead gen) , ("Set-Read", setRead gen) , ("Sliced-Set-Read", slicedSetRead gen) , ("Replicate-Read", replicateRead gen) , ("Slice-Overlaps", sliceOverlaps gen) , ("Slice-Copy", sliceCopy gen) , ("Slice-Move", sliceMove gen) , ("Write-Copy-Read", writeCopyRead gen) , ("Write-Move-Read", writeMoveRead gen) , ("Write-Grow-Read", writeGrowRead gen) , ("Sliced-Write-Copy-Read", slicedWriteCopyRead gen) , ("Sliced-Write-Move-Read", slicedWriteMoveRead gen) , ("Sliced-Write-Grow-Read", slicedWriteGrowRead gen) , ("Write-InitializeAround-Read", writeInitializeAroundRead gen) , ("Write-ClearAround-Read", writeClearAroundRead gen) , ("Write-SetAround-Read", writeSetAroundRead gen) , ("Write-WriteAround-Read", writeWriteAroundRead gen) , ("Write-CopyAround-Read", writeCopyAroundRead gen) , ("Write-MoveAround-Read", writeMoveAroundRead gen) , ("Write-InitializeBetween-Read", writeInitializeBetweenRead gen) , ("Write-ClearBetween-Read", writeClearBetweenRead gen) , ("Write-SetBetween-Read", writeSetBetweenRead gen) , ("Write-CopyBetween-Read", writeCopyBetweenRead gen) , ("Write-MoveBetween-Read", writeMoveBetweenRead gen) ] genNonNegative :: Gen Int genNonNegative = Gen.integral (Range.linear 0 1000) genPositive :: Gen Int genPositive = Gen.integral (Range.linear 1 1000) ------------------------------------------------------------------------------- -- Length newLength :: forall a. (Eq a, MU.Unbox a, Show a) => Gen a -> Property newLength _ = property $ do len <- forAll genNonNegative (=== len) (runST $ MU.length <$> (MU.new len :: ST s (MU.MVector s a))) replicateLength :: forall a. (Eq a, MU.Unbox a, Show a) => Gen a -> Property replicateLength gen = property $ do a <- forAll gen len <- forAll genNonNegative (=== len) (runST $ MU.length <$> MU.replicate len a) sliceLength :: forall a. (Eq a, MU.Unbox a, Show a) => Gen a -> Property sliceLength _ = property $ do ix <- forAll genNonNegative subLen <- forAll genNonNegative excess <- forAll genPositive (=== subLen) (runST $ MU.length . MU.slice ix subLen <$> (MU.new (ix + subLen + excess) :: ST s (MU.MVector s a))) growLength :: forall a. (Eq a, MU.Unbox a, Show a) => Gen a -> Property growLength _ = property $ do len <- forAll genPositive by <- forAll genPositive (=== len + by) $ runST $ do arr <- MU.new len :: ST s (MU.MVector s a) MU.length <$> MU.grow arr by ------------------------------------------------------------------------------- -- Read writeRead :: forall a. (Eq a, MU.Unbox a, Show a) => Gen a -> Property writeRead gen = property $ do a <- forAll gen ix <- forAll genNonNegative excess <- forAll genPositive (=== a) $ runST $ do arr <- MU.new (ix + excess) MU.write arr ix a MU.read arr ix setRead :: forall a. (Eq a, MU.Unbox a, Show a) => Gen a -> Property setRead gen = property $ do a <- forAll gen ix <- forAll genNonNegative excess <- forAll genPositive (=== a) $ runST $ do arr <- MU.new (ix + excess) MU.set arr a MU.read arr ix slicedSetRead :: forall a. (Eq a, MU.Unbox a, Show a) => Gen a -> Property slicedSetRead gen = property $ do a <- forAll gen ix <- forAll genNonNegative excess <- forAll genPositive before <- forAll genNonNegative after <- forAll genNonNegative (=== a) $ runST $ do arr <- newSlice before after (ix + excess) MU.set arr a MU.read arr ix replicateRead :: forall a. (Eq a, MU.Unbox a, Show a) => Gen a -> Property replicateRead gen = property $ do a <- forAll gen ix <- forAll genNonNegative excess <- forAll genPositive (=== a) $ runST $ do arr <- MU.replicate (ix + excess) a MU.read arr ix ------------------------------------------------------------------------------- -- Overlaps sliceOverlaps :: forall a. (Eq a, MU.Unbox a, Show a) => Gen a -> Property sliceOverlaps _ = property $ do i <- forAll genNonNegative ij <- forAll genNonNegative jk <- forAll genNonNegative kl <- forAll genNonNegative lm <- forAll genNonNegative let j = i + ij k = j + jk l = k + kl m = l + lm runST $ do arr <- MU.new (m + 1) :: ST s (MU.MVector s a) let slice1 = MU.slice i (k - i + 1) arr slice2 = MU.slice j (l - j + 1) arr pure $ assert $ MU.overlaps slice1 slice2 sliceCopy :: forall a. (Eq a, MU.Unbox a, Show a) => Gen a -> Property sliceCopy gen = property $ do a <- forAll gen i <- forAll genNonNegative ix <- forAll genNonNegative excess <- forAll genPositive ij <- forAll genNonNegative jk <- forAll genNonNegative let j = i + ix + excess + ij k = j + ix + excess + jk runST $ do arr <- MU.new k :: ST s (MU.MVector s a) let src = MU.slice i (ix + excess) arr dst = MU.slice j (ix + excess) arr if MU.overlaps src dst then pure success else do MU.write src ix a MU.copy dst src valSrc <- MU.read src ix valDst <- MU.read dst ix pure $ (valSrc, valDst) === (a, a) sliceMove :: forall a. (Eq a, MU.Unbox a, Show a) => Gen a -> Property sliceMove gen = property $ do a <- forAll gen i <- forAll genNonNegative ix <- forAll genNonNegative excess <- forAll genPositive ij <- forAll genNonNegative jk <- forAll genNonNegative let j = i + ix + excess + ij k = j + ix + excess + jk (=== a) $ runST $ do arr <- MU.new k :: ST s (MU.MVector s a) let src = MU.slice i (ix + excess) arr dst = MU.slice j (ix + excess) arr MU.write src ix a MU.move dst src MU.read dst ix ------------------------------------------------------------------------------- -- Write + copy/move/grow writeCopyRead :: forall a. (Eq a, MU.Unbox a, Show a) => Gen a -> Property writeCopyRead gen = property $ do a <- forAll gen ix <- forAll genNonNegative excess <- forAll genPositive (=== a) $ runST $ do src <- MU.new (ix + excess) MU.write src ix a dst <- MU.new (ix + excess) MU.copy dst src MU.clear src MU.read dst ix writeMoveRead :: forall a. (Eq a, MU.Unbox a, Show a) => Gen a -> Property writeMoveRead gen = property $ do a <- forAll gen ix <- forAll genNonNegative excess <- forAll genPositive (=== a) $ runST $ do src <- MU.new (ix + excess) MU.write src ix a dst <- MU.new (ix + excess) MU.move dst src MU.clear src MU.read dst ix writeGrowRead :: forall a. (Eq a, MU.Unbox a, Show a) => Gen a -> Property writeGrowRead gen = property $ do a <- forAll gen ix <- forAll genNonNegative excess <- forAll genPositive by <- forAll genPositive (=== a) $ runST $ do src <- MU.new (ix + excess) MU.write src ix a dst <- MU.grow src by MU.clear src MU.read dst ix slicedWriteCopyRead :: forall a. (Eq a, MU.Unbox a, Show a) => Gen a -> Property slicedWriteCopyRead gen = property $ do a <- forAll gen ix <- forAll genNonNegative excess <- forAll genPositive beforeSrc <- forAll genNonNegative afterSrc <- forAll genNonNegative beforeDst <- forAll genNonNegative afterDst <- forAll genNonNegative (=== a) $ runST $ do src <- newSlice beforeSrc afterSrc (ix + excess) MU.write src ix a dst <- newSlice beforeDst afterDst (ix + excess) MU.copy dst src MU.clear src MU.read dst ix slicedWriteMoveRead :: forall a. (Eq a, MU.Unbox a, Show a) => Gen a -> Property slicedWriteMoveRead gen = property $ do a <- forAll gen ix <- forAll genNonNegative excess <- forAll genPositive beforeSrc <- forAll genNonNegative afterSrc <- forAll genNonNegative beforeDst <- forAll genNonNegative afterDst <- forAll genNonNegative (=== a) $ runST $ do src <- newSlice beforeSrc afterSrc (ix + excess) MU.write src ix a dst <- newSlice beforeDst afterDst (ix + excess) MU.move dst src MU.clear src MU.read dst ix slicedWriteGrowRead :: forall a. (Eq a, MU.Unbox a, Show a) => Gen a -> Property slicedWriteGrowRead gen = property $ do a <- forAll gen ix <- forAll genNonNegative excess <- forAll genPositive by <- forAll genPositive beforeSrc <- forAll genNonNegative afterSrc <- forAll genNonNegative (=== a) $ runST $ do src <- newSlice beforeSrc afterSrc (ix + excess) MU.write src ix a dst <- MU.grow src by MU.clear src MU.read dst ix ------------------------------------------------------------------------------- -- Write + overwrite around writeInitializeAroundRead :: forall a. (Eq a, MU.Unbox a, Show a) => Gen a -> Property writeInitializeAroundRead gen = property $ do a <- forAll gen ix <- forAll genNonNegative excess <- forAll genPositive (=== a) $ runST $ do arr <- MU.new (ix + excess) MU.write arr ix a when (ix > 0) $ MU.basicInitialize (MU.slice 0 ix arr) when (excess > 1) $ MU.basicInitialize (MU.slice (ix + 1) (excess - 1) arr) MU.read arr ix writeClearAroundRead :: forall a. (Eq a, MU.Unbox a, Show a) => Gen a -> Property writeClearAroundRead gen = property $ do a <- forAll gen ix <- forAll genNonNegative excess <- forAll genPositive (=== a) $ runST $ do arr <- MU.new (ix + excess) MU.write arr ix a when (ix > 0) $ MU.clear (MU.slice 0 ix arr) when (excess > 1) $ MU.clear (MU.slice (ix + 1) (excess - 1) arr) MU.read arr ix writeSetAroundRead :: forall a. (Eq a, MU.Unbox a, Show a) => Gen a -> Property writeSetAroundRead gen = property $ do a <- forAll gen b <- forAll gen ix <- forAll genNonNegative excess <- forAll genPositive (=== a) $ runST $ do arr <- MU.new (ix + excess) MU.write arr ix a when (ix > 0) $ MU.set (MU.slice 0 ix arr) b when (excess > 1) $ MU.set (MU.slice (ix + 1) (excess - 1) arr) b MU.read arr ix writeWriteAroundRead :: forall a. (Eq a, MU.Unbox a, Show a) => Gen a -> Property writeWriteAroundRead gen = property $ do a <- forAll gen b <- forAll gen ix <- forAll genNonNegative excess <- forAll genPositive (=== a) $ runST $ do arr <- MU.new (ix + excess) MU.write arr ix a when (ix > 0) $ MU.write arr (ix - 1) b when (excess > 1) $ MU.write arr (ix + 1) b MU.read arr ix writeCopyAroundRead :: forall a. (Eq a, MU.Unbox a, Show a) => Gen a -> Property writeCopyAroundRead gen = property $ do a <- forAll gen ix <- forAll genNonNegative excess <- forAll genPositive (=== a) $ runST $ do src <- MU.new (ix + excess) dst <- MU.new (ix + excess) MU.write dst ix a when (ix > 0) $ MU.copy (MU.slice 0 ix dst) (MU.slice 0 ix src) when (excess > 1) $ MU.copy (MU.slice (ix + 1) (excess - 1) dst) (MU.slice (ix + 1) (excess - 1) src) MU.read dst ix writeMoveAroundRead :: forall a. (Eq a, MU.Unbox a, Show a) => Gen a -> Property writeMoveAroundRead gen = property $ do a <- forAll gen ix <- forAll genNonNegative excess <- forAll genPositive (=== a) $ runST $ do src <- MU.new (ix + excess) dst <- MU.new (ix + excess) MU.write dst ix a when (ix > 0) $ MU.move (MU.slice 0 ix dst) (MU.slice 0 ix src) when (excess > 1) $ MU.move (MU.slice (ix + 1) (excess - 1) dst) (MU.slice (ix + 1) (excess - 1) src) MU.read dst ix ------------------------------------------------------------------------------- -- Two writes + overwrite in between writeInitializeBetweenRead :: forall a. (Eq a, MU.Unbox a, Show a) => Gen a -> Property writeInitializeBetweenRead gen = property $ do a <- forAll gen b <- forAll gen ix <- forAll genNonNegative dix <- forAll genPositive excess <- forAll genPositive (=== (a, b)) $ runST $ do arr <- MU.new (ix + dix + excess) MU.write arr ix a MU.write arr (ix + dix) b MU.basicInitialize (MU.slice (ix + 1) (dix - 1) arr) (,) <$> MU.read arr ix <*> MU.read arr (ix + dix) writeClearBetweenRead :: forall a. (Eq a, MU.Unbox a, Show a) => Gen a -> Property writeClearBetweenRead gen = property $ do a <- forAll gen b <- forAll gen ix <- forAll genNonNegative dix <- forAll genPositive excess <- forAll genPositive (=== (a, b)) $ runST $ do arr <- MU.new (ix + dix + excess) MU.write arr ix a MU.write arr (ix + dix) b MU.clear (MU.slice (ix + 1) (dix - 1) arr) (,) <$> MU.read arr ix <*> MU.read arr (ix + dix) writeSetBetweenRead :: forall a. (Eq a, MU.Unbox a, Show a) => Gen a -> Property writeSetBetweenRead gen = property $ do a <- forAll gen b <- forAll gen c <- forAll gen ix <- forAll genNonNegative dix <- forAll genPositive excess <- forAll genPositive (=== (a, b)) $ runST $ do arr <- MU.new (ix + dix + excess) MU.write arr ix a MU.write arr (ix + dix) b MU.set (MU.slice (ix + 1) (dix - 1) arr) c (,) <$> MU.read arr ix <*> MU.read arr (ix + dix) writeCopyBetweenRead :: forall a. (Eq a, MU.Unbox a, Show a) => Gen a -> Property writeCopyBetweenRead gen = property $ do a <- forAll gen b <- forAll gen ix <- forAll genNonNegative dix <- forAll genPositive excess <- forAll genPositive (=== (a, b)) $ runST $ do src <- MU.new (ix + dix + excess) dst <- MU.new (ix + dix + excess) MU.write dst ix a MU.write dst (ix + dix) b MU.copy (MU.slice (ix + 1) (dix - 1) dst) (MU.slice (ix + 1) (dix - 1) src) (,) <$> MU.read dst ix <*> MU.read dst (ix + dix) writeMoveBetweenRead :: forall a. (Eq a, MU.Unbox a, Show a) => Gen a -> Property writeMoveBetweenRead gen = property $ do a <- forAll gen b <- forAll gen ix <- forAll genNonNegative dix <- forAll genPositive excess <- forAll genPositive (=== (a, b)) $ runST $ do src <- MU.new (ix + dix + excess) dst <- MU.new (ix + dix + excess) MU.write dst ix a MU.write dst (ix + dix) b MU.move (MU.slice (ix + 1) (dix - 1) dst) (MU.slice (ix + 1) (dix - 1) src) (,) <$> MU.read dst ix <*> MU.read dst (ix + dix) ------------------------------------------------------------------------------- -- Utils newSlice :: MU.Unbox a => Int -> Int -> Int -> ST s (MU.MVector s a) newSlice before after len = do arr <- MU.new (before + len + after) pure $ MU.slice before len arr #endif hedgehog-classes-0.2.5.4/src/Hedgehog/Classes/Monad.hs0000644000000000000000000001115607346545000020552 0ustar0000000000000000{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE QuantifiedConstraints #-} {-# LANGUAGE RankNTypes #-} module Hedgehog.Classes.Monad (monadLaws) where import Control.Monad (ap) import Hedgehog import Hedgehog.Classes.Common -- | Tests the following 'Monad' laws: -- -- [__Left Identity__]: @'return' a '>>=' k@ ≡ @k a@ -- [__Right Identity__]: @m '>>=' 'return'@ ≡ @m@ -- [__Associativity__]: @m '>>=' (\\x -> k x '>>=' h)@ ≡ @(m '>>=' k) '>>=' h@ -- [__Return__]: @'return'@ ≡ @'pure'@ -- [__Ap__]: @'ap' f x@ ≡ @f '<*>' x@ monadLaws :: ( Monad f , forall x. Eq x => Eq (f x), forall x. Show x => Show (f x) ) => (forall x. Gen x -> Gen (f x)) -> Laws monadLaws gen = Laws "Monad" [ ("Left Identity", monadLeftIdentity gen) , ("Right Identity", monadRightIdentity gen) , ("Associativity", monadAssociativity gen) , ("Return", monadReturn gen) , ("Ap", monadAp gen) ] type MonadProp f = ( Monad f , forall x. Eq x => Eq (f x), forall x. Show x => Show (f x) ) => (forall x. Gen x -> Gen (f x)) -> Property monadLeftIdentity :: forall f. MonadProp f monadLeftIdentity _ = property $ do k' :: LinearEquationM f <- forAll genLinearEquationM a <- forAll $ genSmallInteger let k = runLinearEquationM k' let lhs = return a >>= k let rhs = k a let ctx = contextualise $ LawContext { lawContextLawName = "Left Identity", lawContextTcName = "Monad" , lawContextLawBody = "return a >>= k" `congruency` "k a" , lawContextReduced = reduced lhs rhs , lawContextTcProp = let showK = show k' showA = show a in lawWhere [ "return a >>= k" `congruency` "k a, where" , "k = " ++ showK , "a = " ++ showA ] } heqCtx1 lhs rhs ctx monadRightIdentity :: forall f. MonadProp f monadRightIdentity fgen = property $ do m <- forAll $ fgen genSmallInteger let lhs = m >>= return let rhs = m let ctx = contextualise $ LawContext { lawContextLawName = "Right Identity", lawContextTcName = "Monad" , lawContextLawBody = "m >>= return" `congruency` "m" , lawContextReduced = reduced lhs rhs , lawContextTcProp = let showM = show m in lawWhere [ "m >>= return" `congruency` "m, where" , "m = " ++ showM ] } heqCtx1 lhs rhs ctx monadAssociativity :: forall f. MonadProp f monadAssociativity fgen = property $ do m <- forAll $ fgen genSmallInteger k' :: LinearEquationM f <- forAll genLinearEquationM h' :: LinearEquationM f <- forAll genLinearEquationM let k = runLinearEquationM k' h = runLinearEquationM h' let lhs = m >>= (\x -> k x >>= h) let rhs = (m >>= k) >>= h let ctx = contextualise $ LawContext { lawContextLawName = "Associativity", lawContextTcName = "Monad" , lawContextLawBody = "m >>= (\\x -> k x >>= h)" `congruency` "(m >>= k) >>= h" , lawContextReduced = reduced lhs rhs , lawContextTcProp = let showM = show m showK = show k' showH = show h' in lawWhere [ "m >>= (\\x -> k x >>= h)" `congruency` "(m >>= k) >>= h, where" , "m = " ++ showM , "k = " ++ showK , "h = " ++ showH ] } heqCtx1 lhs rhs ctx monadReturn :: forall f. MonadProp f monadReturn _ = property $ do x <- forAll genSmallInteger let lhs = return x let rhs = pure x :: f Integer let ctx = contextualise $ LawContext { lawContextLawName = "Return", lawContextTcName = "Monad" , lawContextLawBody = "return" `congruency` "pure" , lawContextReduced = reduced lhs rhs , lawContextTcProp = let showX = show x in lawWhere [ "return x" `congruency` "pure x, where" , "x = " ++ showX ] } heqCtx1 lhs rhs ctx monadAp :: forall f. MonadProp f monadAp _ = property $ do f' :: f QuadraticEquation <- forAll $ pure <$> genQuadraticEquation x :: f Integer <- forAll $ pure <$> genSmallInteger let f = fmap runQuadraticEquation f' let lhs = ap f x let rhs = f <*> x let ctx = contextualise $ LawContext { lawContextLawName = "Ap", lawContextTcName = "Monad" , lawContextLawBody = "ap f" `congruency` "f <*>" , lawContextReduced = reduced lhs rhs , lawContextTcProp = let showX = show x showF = show f' in lawWhere [ "ap f x" `congruency` "f <*> x, where" , "f = " ++ showF , "x = " ++ showX ] } heqCtx1 lhs rhs ctx hedgehog-classes-0.2.5.4/src/Hedgehog/Classes/MonadIO.hs0000644000000000000000000000436007346545000021001 0ustar0000000000000000{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE QuantifiedConstraints #-} {-# LANGUAGE RankNTypes #-} module Hedgehog.Classes.MonadIO (monadIOLaws) where import Control.Monad.IO.Class (MonadIO(..)) import Hedgehog import Hedgehog.Classes.Common -- | Tests the following 'MonadIO' laws: -- -- [__Return__]: @'liftIO' '.' 'return'@ ≡ @'return'@ -- [__Lift__]: @'liftIO' (m '>>=' f)@ ≡ @'liftIO' m '>>=' ('liftIO' '.' f)@ monadIOLaws :: ( MonadIO f , forall x. Eq x => Eq (f x), forall x. Show x => Show (f x) ) => (forall x. Gen x -> Gen (f x)) -> Laws monadIOLaws gen = Laws "MonadIO" [ ("Return", monadIOReturn gen) , ("Lift", monadIOLift gen) ] type MonadIOProp f = ( MonadIO f , forall x. Eq x => Eq (f x), forall x. Show x => Show (f x) ) => (forall x. Gen x -> Gen (f x)) -> Property monadIOReturn :: forall f. MonadIOProp f monadIOReturn _fgen = property $ do x <- forAll genSmallInteger let lhs = liftIO (return x) let rhs = return x :: f Integer let ctx = contextualise $ LawContext { lawContextLawName = "Return", lawContextTcName = "MonadIO" , lawContextLawBody = "liftIO . return" `congruency` "return" , lawContextReduced = reduced lhs rhs , lawContextTcProp = let showX = show x in lawWhere [ "liftIO . return $ x" `congruency` "return x, where" , "x = " ++ showX ] } heqCtx1 lhs rhs ctx monadIOLift :: forall f. MonadIOProp f monadIOLift _fgen = property $ do m <- forAllWith showIO $ genIO genSmallInteger f' <- forAll genLinearEquation let f = pure . runLinearEquation f' let lhs = liftIO (m >>= f) :: f Integer let rhs = liftIO m >>= (liftIO . f) :: f Integer let ctx = contextualise $ LawContext { lawContextLawName = "Lift", lawContextTcName = "MonadIO" , lawContextLawBody = "liftIO (m >>= f)" `congruency` "liftIO m >>= (liftIO . f)" , lawContextReduced = reduced lhs rhs , lawContextTcProp = let showM = showIO m showF = show f' in lawWhere [ "liftIO (m >>= f)" `congruency` "liftIO m >>= (liftIO . f), where" , "f = " ++ showF , "m = " ++ showM ] } heqCtx1 lhs rhs ctx hedgehog-classes-0.2.5.4/src/Hedgehog/Classes/MonadPlus.hs0000644000000000000000000001141207346545000021411 0ustar0000000000000000{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE QuantifiedConstraints #-} {-# LANGUAGE RankNTypes #-} module Hedgehog.Classes.MonadPlus (monadPlusLaws) where import Control.Monad (MonadPlus(..)) import Hedgehog import Hedgehog.Classes.Common -- | Tests the following 'MonadPlus' laws: -- -- [__Left Identity__]: @'mplus' 'mzero'@ ≡ @'id'@ -- [__Right Identity__]: @'flip' 'mplus' 'mzero'@ ≡ @'id'@ -- [__Associativity__]: @'mplus' a ('mplus' b c)@ ≡ @'mplus' ('mplus' a b) c@ -- [__Left Zero__]: @'mzero' '>>=' f@ ≡ @'mzero'@ -- [__Right Zero__]: @v '>>' 'mzero'@ ≡ @'mzero'@ monadPlusLaws :: ( MonadPlus f , forall x. Eq x => Eq (f x), forall x. Show x => Show (f x) ) => (forall x. Gen x -> Gen (f x)) -> Laws monadPlusLaws gen = Laws "MonadPlus" [ ("Left Identity", monadPlusLeftIdentity gen) , ("Right Identity", monadPlusRightIdentity gen) , ("Associativity", monadPlusAssociativity gen) , ("Left Zero", monadPlusLeftZero gen) , ("Right Zero", monadPlusRightZero gen) ] type MonadPlusProp f = ( MonadPlus f , forall x. Eq x => Eq (f x), forall x. Show x => Show (f x) ) => (forall x. Gen x -> Gen (f x)) -> Property monadPlusLeftIdentity :: forall f. MonadPlusProp f monadPlusLeftIdentity fgen = property $ do x <- forAll $ fgen genSmallInteger let lhs = mplus mzero x let rhs = x let ctx = contextualise $ LawContext { lawContextLawName = "Left Identity", lawContextTcName = "MonadPlus" , lawContextLawBody = "mplus mzero" `congruency` "id" , lawContextReduced = reduced lhs rhs , lawContextTcProp = let showX = show x; showMZero = show (mzero :: f Integer); in lawWhere [ "mplus mzero x" `congruency` "id x, where" , "x = " ++ showX , "mzero = " ++ showMZero ] } heqCtx1 lhs rhs ctx monadPlusRightIdentity :: forall f. MonadPlusProp f monadPlusRightIdentity fgen = property $ do x <- forAll $ fgen genSmallInteger let lhs = mplus x mzero let rhs = x let ctx = contextualise $ LawContext { lawContextLawName = "Right Identity", lawContextTcName = "MonadPlus" , lawContextLawBody = "flip mplus mzero" `congruency` "id" , lawContextReduced = reduced lhs rhs , lawContextTcProp = let showX = show x; showMZero = show (mzero :: f Integer); in lawWhere [ "mplus x mzero" `congruency` "id x, where" , "x = " ++ showX , "mzero = " ++ showMZero ] } heqCtx1 lhs rhs ctx monadPlusAssociativity :: forall f. MonadPlusProp f monadPlusAssociativity fgen = property $ do a <- forAll $ fgen genSmallInteger b <- forAll $ fgen genSmallInteger c <- forAll $ fgen genSmallInteger let lhs = mplus a (mplus b c) let rhs = mplus (mplus a b) c let ctx = contextualise $ LawContext { lawContextLawName = "Associativity", lawContextTcName = "MonadPlus" , lawContextLawBody = "mplus a (mplus b c)" `congruency` "mplus (mplus a b) c" , lawContextReduced = reduced lhs rhs , lawContextTcProp = let showA = show a; showB = show b; showC = show c; in lawWhere [ "mplus a (mplus b c)" `congruency` "mplus (mplus a b) c, where" , "a = " ++ showA , "b = " ++ showB , "c = " ++ showC ] } heqCtx1 lhs rhs ctx monadPlusLeftZero :: forall f. MonadPlusProp f monadPlusLeftZero _ = property $ do k' :: LinearEquationM f <- forAll genLinearEquationM let lhs = mzero >>= runLinearEquationM k' let rhs = mzero let ctx = contextualise $ LawContext { lawContextLawName = "Left Zero", lawContextTcName = "MonadPlus" , lawContextLawBody = "mzero >>= f" `congruency` "mzero" , lawContextReduced = reduced lhs rhs , lawContextTcProp = let showF = show k'; showMZero = show (mzero :: f Integer); in lawWhere [ "mzero >>= f" `congruency` "mzero, where" , "f = " ++ showF , "mzero = " ++ showMZero ] } heqCtx1 lhs rhs ctx monadPlusRightZero :: forall f. MonadPlusProp f monadPlusRightZero fgen = property $ do v <- forAll $ fgen genSmallInteger let lhs = v >> (mzero :: f Integer) let rhs = mzero let ctx = contextualise $ LawContext { lawContextLawName = "Right Zero", lawContextTcName = "MonadPlus" , lawContextLawBody = "v >> mzero" `congruency` "mzero" , lawContextReduced = reduced lhs rhs , lawContextTcProp = let showV = show v; showMZero = show (mzero :: f Integer); in lawWhere [ "v >> mzero" `congruency` "mzero, where" , "v = " ++ showV , "mzero = " ++ showMZero ] } heqCtx1 lhs rhs ctx hedgehog-classes-0.2.5.4/src/Hedgehog/Classes/MonadZip.hs0000644000000000000000000000347407346545000021241 0ustar0000000000000000{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE QuantifiedConstraints #-} {-# LANGUAGE RankNTypes #-} module Hedgehog.Classes.MonadZip (monadZipLaws) where import Control.Arrow (Arrow(..)) import Control.Monad.Zip (MonadZip(mzip)) import Hedgehog import Hedgehog.Classes.Common -- | Tests the following 'MonadZip' laws: -- -- [__Naturality__]: @'fmap' (f '***' g) ('mzip' ma mb)@ ≡ @'mzip' ('fmap' f ma) ('fmap' g mb)@ monadZipLaws :: ( MonadZip f , forall x. Eq x => Eq (f x), forall x. Show x => Show (f x) ) => (forall x. Gen x -> Gen (f x)) -> Laws monadZipLaws gen = Laws "Monad" [ ("Naturality", monadZipNaturality gen) ] type MonadZipProp f = ( MonadZip f , forall x. Eq x => Eq (f x), forall x. Show x => Show (f x) ) => (forall x. Gen x -> Gen (f x)) -> Property monadZipNaturality :: forall f. MonadZipProp f monadZipNaturality fgen = property $ do f' <- forAll genLinearEquation g' <- forAll genLinearEquation let f = runLinearEquation f' g = runLinearEquation g' ma <- forAll $ fgen genSmallInteger mb <- forAll $ fgen genSmallInteger let lhs = fmap (f *** g) (mzip ma mb) let rhs = mzip (fmap f ma) (fmap g mb) let ctx = contextualise $ LawContext { lawContextLawName = "Naturality", lawContextTcName = "MonadZip" , lawContextLawBody = "(fmap (f *** g) (mzip ma mb)" `congruency` "mzip (fmap f ma) (fmap g mb)" , lawContextReduced = reduced lhs rhs , lawContextTcProp = let showF = show f'; showG = show g'; showMA = show ma; showMB = show mb; in lawWhere [ "fmap (f *** g) (mzip ma mb)" `congruency` "mzip (fmap f ma) (fmap g mb), where" , "f = " ++ showF , "g = " ++ showG , "ma = " ++ showMA , "mb = " ++ showMB ] } heqCtx1 lhs rhs ctx hedgehog-classes-0.2.5.4/src/Hedgehog/Classes/Monoid.hs0000644000000000000000000001125107346545000020735 0ustar0000000000000000{-# LANGUAGE ScopedTypeVariables #-} module Hedgehog.Classes.Monoid (monoidLaws, commutativeMonoidLaws) where import Hedgehog import Hedgehog.Classes.Common -- | Tests the following 'Monoid' laws: -- -- [__Left Identity__]: @'mappend' 'mempty'@ ≡ @'id'@ -- [__Right Identity__]: @'flip' 'mappend' 'mempty'@ ≡ @'id'@ -- [__Associativity__]: @'mappend' a ('mappend' b c)@ ≡ @'mappend' ('mappend' a b) c@ -- [__Concatenation__]: @'mconcat'@ ≡ @'foldr' 'mappend' 'mempty'@ monoidLaws :: (Eq a, Monoid a, Show a) => Gen a -> Laws monoidLaws gen = Laws "Monoid" [ ("Left Identity", monoidLeftIdentity gen) , ("Right Identity", monoidRightIdentity gen) , ("Associativity", monoidAssociative gen) , ("Concatenation", monoidConcatenation gen) ] -- | Tests the following 'Monoid' laws: -- -- [__Commutativity__]: @'mappend' a b@ ≡ @'mappend' b a@ commutativeMonoidLaws :: (Eq a, Monoid a, Show a) => Gen a -> Laws commutativeMonoidLaws gen = Laws "Commutative Monoid" [ ("Commutativity", monoidCommutative gen) ] monoidConcatenation :: forall a. (Eq a, Monoid a, Show a) => Gen a -> Property monoidConcatenation gen = property $ do as <- forAll $ genSmallList gen let lhs = mconcat as let rhs = foldr mappend mempty as let ctx = contextualise $ LawContext { lawContextLawName = "Concatenation", lawContextTcName = "Monoid" , lawContextLawBody = "mconcat" `congruency` "foldr mappend mempty" , lawContextReduced = reduced lhs rhs , lawContextTcProp = let showAS = show as; showMempty = show (mempty :: a); in lawWhere [ "mconcat as" `congruency` "foldr mappend mempty as, where" , "as = " ++ showAS , "mempty = " ++ showMempty ] } heqCtx lhs rhs ctx monoidAssociative :: forall a. (Eq a, Monoid a, Show a) => Gen a -> Property monoidAssociative gen = property $ do a <- forAll gen b <- forAll gen c <- forAll gen let lhs = mappend a (mappend b c) let rhs = mappend (mappend a b) c let ctx = contextualise $ LawContext { lawContextLawName = "Associativity", lawContextTcName = "Monoid" , lawContextLawBody = "mappend a (mappend b c)" `congruency` "mappend (mappend a b) c" , lawContextReduced = reduced lhs rhs , lawContextTcProp = let showA = show a; showB = show b; showC = show c; in lawWhere [ "mappend a (mappend b c)" `congruency` "mappend (mappend a b) c, where" , "a = " ++ showA , "b = " ++ showB , "c = " ++ showC ] } heqCtx lhs rhs ctx monoidLeftIdentity :: forall a. (Eq a, Monoid a, Show a) => Gen a -> Property monoidLeftIdentity gen = property $ do a <- forAll gen let lhs = mappend mempty a let rhs = a let ctx = contextualise $ LawContext { lawContextLawName = "Left Identity", lawContextTcName = "Monoid" , lawContextLawBody = "mappend mempty" `congruency` "id" , lawContextReduced = reduced lhs rhs , lawContextTcProp = let showA = show a; showMempty = show (mempty :: a); in lawWhere [ "mappend mempty a" `congruency` "a, where" , "a = " ++ showA , "mempty = " ++ showMempty ] } heqCtx lhs rhs ctx monoidRightIdentity :: forall a. (Eq a, Monoid a, Show a) => Gen a -> Property monoidRightIdentity gen = property $ do a <- forAll gen let lhs = mappend a mempty let rhs = a let ctx = contextualise $ LawContext { lawContextLawName = "Right Identity", lawContextTcName = "Monoid" , lawContextLawBody = "flip mappend mempty" `congruency` "id" , lawContextReduced = reduced lhs rhs , lawContextTcProp = let showA = show a; showMempty = show (mempty :: a); in lawWhere [ "mappend a mempty" `congruency` "a, where" , "a = " ++ showA , "mempty = " ++ showMempty ] } heqCtx lhs rhs ctx monoidCommutative :: forall a. (Eq a, Monoid a, Show a) => Gen a -> Property monoidCommutative gen = property $ do a <- forAll gen b <- forAll gen let lhs = mappend a b let rhs = mappend b a let ctx = contextualise $ LawContext { lawContextLawName = "Commutativity", lawContextTcName = "Monoid (Commutative)" , lawContextLawBody = "mappend" `congruency` "flip mappend" , lawContextReduced = reduced lhs rhs , lawContextTcProp = let showA = show a; showB = show b; in lawWhere [ "mappend a b" `congruency` "mappend b a, where" , "a = " ++ showA , "b = " ++ showB ] } heqCtx lhs rhs ctx hedgehog-classes-0.2.5.4/src/Hedgehog/Classes/Ord.hs0000644000000000000000000000710107346545000020233 0ustar0000000000000000{-# LANGUAGE ScopedTypeVariables #-} module Hedgehog.Classes.Ord (ordLaws) where import Hedgehog import Hedgehog.Classes.Common -- | Tests the following 'Ord' laws: -- -- [__Antisymmetry__]: @x '<=' y '&&' y '<=' x@ ≡ @x '==' y@ -- [__Transitivity__]: @x '<=' y '&&' y '<=' z@ ≡ @x '<=' z@ -- [__Reflexivity__]: @x '<=' x@ ≡ @'True'@ -- [__Totality__]: @x '<=' y '||' y '<=' x@ ≡ @'True'@ ordLaws :: forall a. (Ord a, Show a) => Gen a -> Laws ordLaws gen = Laws "Ord" [ ("Antisymmetry", ordAntisymmetric gen) , ("Transitivity", ordTransitive gen) , ("Reflexivity", ordReflexive gen) , ("Totality", ordTotal gen) ] ordAntisymmetric :: forall a. (Ord a, Show a) => Gen a -> Property ordAntisymmetric gen = property $ do a <- forAll gen b <- forAll gen let lhs = (a <= b) && (b <= a) let rhs = a == b let ctx = contextualise $ LawContext { lawContextLawName = "Antisymmetry", lawContextTcName = "Ord" , lawContextLawBody = "x <= y && y <= x" `congruency` "x == y" , lawContextReduced = reduced lhs rhs , lawContextTcProp = let showA = show a; showB = show b; in lawWhere [ "x <= y && y <= x" `congruency` "x == y, where" , "x = " ++ showA , "y = " ++ showB ] } heqCtx lhs rhs ctx ordTransitive :: forall a. (Ord a, Show a) => Gen a -> Property ordTransitive gen = property $ do x <- forAll gen y <- forAll gen z <- forAll gen let lhs = x <= y && y <= z let rhs = x <= z let ctx = contextualise $ LawContext { lawContextLawName = "Transitivity", lawContextTcName = "Ord" , lawContextLawBody = "x <= y && y <= z" `implies` "x <= z" , lawContextReduced = reduced lhs rhs , lawContextTcProp = let showX = show x; showY = show y; showZ = show z; in lawWhere [ "x <= y && y <= z" `implies` "x <= z, where" , "x = " ++ showX , "y = " ++ showY , "z = " ++ showZ ] } case (compare x y, compare y z) of (LT,LT) -> hLessThanCtx x z ctx (LT,EQ) -> hLessThanCtx x z ctx (LT,GT) -> success (EQ,LT) -> hLessThanCtx x z ctx (EQ,EQ) -> heqCtx x z ctx (EQ,GT) -> hGreaterThanCtx x z ctx (GT,LT) -> success (GT,EQ) -> hGreaterThanCtx x z ctx (GT,GT) -> hGreaterThanCtx x z ctx ordTotal :: forall a. (Ord a, Show a) => Gen a -> Property ordTotal gen = property $ do a <- forAll gen b <- forAll gen let lhs = (a <= b) || (b <= a) let rhs = True let ctx = contextualise $ LawContext { lawContextLawName = "Totality", lawContextTcName = "Ord" , lawContextLawBody = "x <= y || y <= x" `congruency` "True" , lawContextReduced = reduced lhs rhs , lawContextTcProp = let showA = show a; showB = show b; in lawWhere [ "(x <= y) || (y <= x)" `congruency` "True, where" , "x = " ++ showA , "y = " ++ showB ] } heqCtx lhs rhs ctx ordReflexive :: forall a. (Ord a, Show a) => Gen a -> Property ordReflexive gen = property $ do x <- forAll gen let lhs = x <= x let rhs = True let ctx = contextualise $ LawContext { lawContextLawName = "Reflexivity", lawContextTcName = "Ord" , lawContextLawBody = "x <= x" `congruency` "True" , lawContextReduced = reduced lhs rhs , lawContextTcProp = let showX = show x; in lawWhere [ "x <= x" `congruency` "True, where" , "x = " ++ showX ] } heqCtx lhs rhs ctx hedgehog-classes-0.2.5.4/src/Hedgehog/Classes/Prim.hs0000644000000000000000000002417307346545000020426 0ustar0000000000000000{-# language CPP #-} {-# language LambdaCase #-} {-# language UnboxedTuples #-} {-# language TypeApplications #-} {-# language MagicHash #-} {-# language BangPatterns #-} {-# language ScopedTypeVariables #-} #ifndef HAVE_PRIMITIVE module Hedgehog.Classes.Prim () where #else module Hedgehog.Classes.Prim (primLaws) where import Control.Monad (when) import Foreign.Marshal.Alloc import GHC.Exts hiding (setByteArray#) import Control.Monad.IO.Class (liftIO) import Control.Monad.Primitive import Data.Primitive import Data.Primitive.Ptr import Hedgehog import Hedgehog.Classes.Common import Hedgehog.Internal.Gen (sample) import qualified Hedgehog.Gen as Gen import qualified Hedgehog.Range as Range -- | Tests the following 'Prim' laws: -- -- [__ByteArray Set-Get__]: @'primitive_' ('writeByteArray#' ba# ix# x) '*>' 'primitive' ('readByteArray#' ba# ix#)@ ≡ @'pure' x@ -- [__ByteArray Get-Set__]: @'primitive' ('readByteArray#' ba# ix#) '>>=' \x -> 'primitive_' ('writeByteArray#' ba# ix# x)@ ≡ @'pure' ()@ -- [__ByteArray Set-Set__]: @'primitive_' ('writeByteArray#' ba# ix# x) *> 'primitive_' ('writeByteArray#' ba# ix# x)@ ≡ @'primitive_' ('writeByteArray#' ba# ix# x)@ -- [__ByteArray Set Range__]: The behavior of 'setByteArray#' matches the default implementation -- [__ByteArray List Conversion Roundtrips__]: Turning a list into a 'PrimArray' and back gives you the same list -- [__Addr Set-Get__]: @'primitive_' ('writeOffAddr#' addr# ix# x) '*>' 'primitive' ('readOffAddr#' addr# ix#)@ ≡ @'pure' x@ -- [__Addr Get-Set__]: @'primitive' ('readOffAddr#' addr# ix#) '>>=' \x -> 'primitive_' ('writeOffAddr#' addr# ix# x)@ ≡ @'pure' ()@ -- [__Addr Set-Set__]: @'primitive_' ('writeOffAddr#' addr# ix# x) '*>' 'primitive_' ('writeOffAddr#' addr# ix# x)@ ≡ @'primitive_' ('writeOffAddr#' addr# ix# x)@ -- [__Addr Set Range__]: The behavior of 'setOffAddr#' matches the default implementation -- [__Addr List Conversion Roundtrips__]: Mallocing a list and then reconstructing it gives you the same list primLaws :: (Prim a, Eq a, Show a) => Gen a -> Laws primLaws gen = Laws "Prim" [ ("ByteArray Set-Get (you get back what you put in)", primSetGetByteArray gen) , ("ByteArray Get-Set (putting back what you got out has no effect)", primGetSetByteArray gen) , ("ByteArray Set-Set (putting twice is the same as putting once)", primSetSetByteArray gen) , ("ByteArray Set Range", primSetByteArray gen) , ("ByteArray List Conversion Roundtrips", primListRoundtripByteArray gen) , ("Addr Set-Get (you get back what you put in)", primSetGetAddr gen) , ("Addr Get-Set (putting back what you got out has no effect)", primGetSetAddr gen) , ("Addr Set-Set (putting twice is the same as putting once)", primSetSetAddr gen) , ("Addr Set Range", primSetRangeAddr gen) , ("Addr List Conversion Roundtrips", primListRoundtripAddr gen) ] genSmallArrayLen :: Gen Int genSmallArrayLen = Gen.integral (Range.linear 1 10) genMutPrimArray :: Prim a => Gen a -> Int -> IO (MutablePrimArray (PrimState IO) a) genMutPrimArray gen len = do marr <- newPrimArray len let go :: Int -> IO () go !ix = when (ix < len) $ do writePrimArray marr ix =<< sample gen go (ix + 1) go 0 pure marr genPrimArray :: forall a. Prim a => Gen a -> Int -> IO (PrimArray a) genPrimArray gen len = unsafeFreezePrimArray =<< genMutPrimArray gen len -- | Setting an element and getting it back should give back the same element primSetGetByteArray :: (Eq a, Show a, Prim a) => Gen a -> Property primSetGetByteArray gen = property $ do len <- forAll genSmallArrayLen ix <- forAll $ Gen.int (Range.linear 0 (len - 1)) el <- forAll gen el' <- liftIO $ do marr <- genMutPrimArray gen len writePrimArray marr ix el readPrimArray marr ix el === el' -- | Getting an element and putting it back should not change the array primGetSetByteArray :: (Eq a, Show a, Prim a) => Gen a -> Property primGetSetByteArray gen = property $ do len <- forAll genSmallArrayLen ix <- forAll $ Gen.int (Range.linear 0 (len - 1)) (arr1, arr2) <- liftIO $ do arr1 <- genPrimArray gen len marr2 <- newPrimArray len copyPrimArray marr2 0 arr1 0 len writePrimArray marr2 ix =<< readPrimArray marr2 ix arr2 <- unsafeFreezePrimArray marr2 pure (arr1, arr2) arr1 === arr2 -- | Setting and element once and twice should result in the same array (setting -- should be idempotent) primSetSetByteArray :: (Eq a, Show a, Prim a) => Gen a -> Property primSetSetByteArray gen = property $ do len <- forAll genSmallArrayLen ix <- forAll $ Gen.int (Range.linear 0 (len - 1)) el <- forAll gen (arr1, arr2) <- liftIO $ do marr1 <- genMutPrimArray gen len writePrimArray marr1 ix el marr2 <- newPrimArray len copyMutablePrimArray marr2 0 marr1 0 len arr1 <- unsafeFreezePrimArray marr1 writePrimArray marr2 ix el arr2 <- unsafeFreezePrimArray marr2 pure (arr1, arr2) arr1 === arr2 -- | Setting a range should match the default implementation primSetByteArray :: (Eq a, Show a, Prim a) => Gen a -> Property primSetByteArray gen = property $ do len <- forAll genSmallArrayLen (low, high) <- fmap order $ (,) <$> forAll (Gen.int (Range.linear 0 (len - 1))) <*> forAll (Gen.int (Range.linear 0 (len - 1))) el <- forAll gen (arr2, arr3) <- liftIO $ do arr1 <- genPrimArray gen len marr2 <- newPrimArray len copyPrimArray marr2 0 arr1 0 len marr3 <- newPrimArray len copyPrimArray marr3 0 arr1 0 len setPrimArray marr2 low (high - low) el arr2 <- unsafeFreezePrimArray marr2 defaultSetPrimArray marr3 low (high - low) el arr3 <- unsafeFreezePrimArray marr3 pure (arr2, arr3) arr2 === arr3 where order (x, y) = if x < y then (x, y) else (y, x) defaultSetPrimArray :: (Prim a, PrimMonad m) => MutablePrimArray (PrimState m) a -> Int -> Int -> a -> m () defaultSetPrimArray (MutablePrimArray marr#) (I# off#) (I# len#) x = primitive_ (go off#) where end# = off# +# len# go !ix# s# = if isTrue# (ix# >=# end#) then s# else case writeByteArray# marr# ix# x s# of s2# -> go (ix# +# 1#) s2# -- | @'toList' . 'fromList'@ should result in the same list primListRoundtripByteArray :: forall a. (Eq a, Show a, Prim a) => Gen a -> Property primListRoundtripByteArray gen = property $ do xs <- forAll $ genSmallNonEmptyList gen xs === toList (fromList xs :: PrimArray a) withBytes :: forall a b. Prim a => Int -> (Ptr a -> IO b) -> IO b withBytes len h = do p <- mallocBytes (len * sizeOf (undefined :: a)) h p <* free p ptrToPrimArray :: forall a. Prim a => Ptr a -> Int -> IO (PrimArray a) ptrToPrimArray p len = do marr <- newPrimArray len copyPtrToMutablePrimArray marr 0 p len unsafeFreezePrimArray marr -- | Setting an element and getting it back should give back the same element primSetGetAddr :: forall a. (Eq a, Show a, Prim a) => Gen a -> Property primSetGetAddr gen = property $ do len <- forAll genSmallArrayLen ix <- forAll $ Gen.int (Range.linear 0 (len - 1)) el <- forAll gen el' <- liftIO $ withBytes len $ \p -> do writeOffPtr p ix el readOffPtr p ix el === el' -- | Getting an element and putting it back should not change the array primGetSetAddr :: (Eq a, Show a, Prim a) => Gen a -> Property primGetSetAddr gen = property $ do len <- forAll genSmallArrayLen ix <- forAll $ Gen.int (Range.linear 0 (len - 1)) (arr1, arr2) <- liftIO $ do arr1 <- genPrimArray gen len arr2 <- withBytes len $ \p -> do copyPrimArrayToPtr p arr1 0 len writeOffPtr p ix =<< readOffPtr p ix ptrToPrimArray p len pure (arr1, arr2) arr1 === arr2 -- | Setting and element once and twice should result in the same array (setting -- should be idempotent) primSetSetAddr :: (Eq a, Show a, Prim a) => Gen a -> Property primSetSetAddr gen = property $ do len <- forAll genSmallArrayLen ix <- forAll $ Gen.int (Range.linear 0 (len - 1)) el <- forAll gen (arr2, arr3) <- liftIO $ do arr1 <- genPrimArray gen len withBytes len $ \p1 -> do copyPrimArrayToPtr p1 arr1 0 len writeOffPtr p1 ix el arr2 <- ptrToPrimArray p1 len withBytes len $ \p2 -> do copyPrimArrayToPtr p2 arr2 0 len writeOffPtr p2 ix el arr3 <- ptrToPrimArray p2 len pure (arr2, arr3) arr2 === arr3 -- | Setting a range should match the default implementation primSetRangeAddr :: (Eq a, Show a, Prim a) => Gen a -> Property primSetRangeAddr gen = property $ do len <- forAll genSmallArrayLen (low, high) <- fmap order $ (,) <$> forAll (Gen.int (Range.linear 0 (len - 1))) <*> forAll (Gen.int (Range.linear 0 (len - 1))) el <- forAll gen (arr2, arr3) <- liftIO $ do withBytes len $ \p1 -> do withBytes len $ \p2 -> do arr1 <- genPrimArray gen len copyPrimArrayToPtr p1 arr1 0 len copyPrimArrayToPtr p2 arr1 0 len setOffPtr p1 low (high - low) el arr2 <- ptrToPrimArray p1 len defaultSetOffAddr p2 low (high - low) el arr3 <- ptrToPrimArray p2 len pure (arr2, arr3) arr2 === arr3 where order (x, y) = if x < y then (x, y) else (y, x) setOffPtr (Ptr addr#) (I# off#) (I# len#) x = primitive_ (setOffAddr# addr# off# len# x) defaultSetOffAddr :: (Prim a, PrimMonad m) => Ptr a -> Int -> Int -> a -> m () defaultSetOffAddr (Ptr addr#) (I# off#) (I# len#) x = primitive_ (go off#) where end# = off# +# len# go !ix# s# = if isTrue# (ix# >=# end#) then s# else case writeOffAddr# addr# ix# x s# of s2# -> go (ix# +# 1#) s2# -- | Mallocing an array, emptying a list into the array, and then rebuilding the -- list from that array should produce the original list. primListRoundtripAddr :: forall a. (Eq a, Show a, Prim a) => Gen a -> Property primListRoundtripAddr gen = property $ do xs <- forAll $ genSmallList gen let len = length xs xs' <- liftIO $ withBytes len $ \p -> do let listToPtr :: Int -> [a] -> IO () listToPtr !ix = \case [] -> pure () (y:ys) -> writeOffPtr p ix y *> listToPtr (ix + 1) ys let ptrToList :: Int -> IO [a] ptrToList !ix = if ix >= len then pure [] else (:) <$> readOffPtr p ix <*> ptrToList (ix + 1) listToPtr 0 xs ptrToList 0 xs === xs' #endif hedgehog-classes-0.2.5.4/src/Hedgehog/Classes/Semigroup.hs0000644000000000000000000001616007346545000021466 0ustar0000000000000000{-# LANGUAGE ScopedTypeVariables #-} module Hedgehog.Classes.Semigroup ( semigroupLaws , commutativeSemigroupLaws , exponentialSemigroupLaws , idempotentSemigroupLaws , rectangularBandSemigroupLaws ) where import Data.Semigroup (Semigroup(..)) import Hedgehog import Hedgehog.Classes.Common import Data.List.NonEmpty import qualified Hedgehog.Gen as Gen import qualified Hedgehog.Range as Range import qualified Data.Foldable as Foldable -- | Tests the following 'Semigroup' laws: -- -- [__Associativity__]: @a '<>' (b '<>' c)@ ≡ @(a '<>' b) '<>' c@ -- [__Concatenation__]: @'sconcat'@ ≡ @'Foldable.foldr1' ('<>')@ -- [__Times__]: @'stimes' n a@ ≡ @'foldr1' ('<>') ('replicate' n a)@ semigroupLaws :: (Eq a, Semigroup a, Show a) => Gen a -> Laws semigroupLaws gen = Laws "Semigroup" [ ("Associativity", semigroupAssociative gen) , ("Concatenation", semigroupConcatenation gen) , ("Times", semigroupTimes gen) ] -- | Tests the following 'Semigroup' laws: -- -- [__Commutativity__]: @a '<>' b@ ≡ @b '<>' a@ commutativeSemigroupLaws :: (Eq a, Semigroup a, Show a) => Gen a -> Laws commutativeSemigroupLaws gen = Laws "Commutative Semigroup" [ ("Commutative", semigroupCommutative gen) ] -- | Tests the following 'Semigroup' laws: -- -- [__Exponentiality__]: @'stimes' n (a '<>' b)@ ≡ @'stimes' n a '<>' 'stimes' n b@ exponentialSemigroupLaws :: (Eq a, Semigroup a, Show a) => Gen a -> Laws exponentialSemigroupLaws gen = Laws "Exponential Semigroup" [ ("Exponential", semigroupExponential gen) ] -- | Tests the following 'Semigroup' laws: -- -- [__Idempotency__]: @a '<>' a@ ≡ @a@ idempotentSemigroupLaws :: (Eq a, Semigroup a, Show a) => Gen a -> Laws idempotentSemigroupLaws gen = Laws "Idempotent Semigroup" [ ("Idempotent", semigroupIdempotent gen) ] -- | Tests the following 'Semigroup' laws: -- -- [__Rectangular Bandedness__]: @a '<>' b '<>' a@ ≡ @a@ rectangularBandSemigroupLaws :: (Eq a, Semigroup a, Show a) => Gen a -> Laws rectangularBandSemigroupLaws gen = Laws "Rectangular Band Semigroup" [ ("Rectangular Band", semigroupRectangularBand gen) ] semigroupAssociative :: forall a. (Eq a, Semigroup a, Show a) => Gen a -> Property semigroupAssociative gen = property $ do a <- forAll gen b <- forAll gen c <- forAll gen let lhs = a <> (b <> c) let rhs = (a <> b) <> c let ctx = contextualise $ LawContext { lawContextLawName = "Associativity", lawContextTcName = "Semigroup" , lawContextLawBody = "a <> (b <> c)" `congruency` "(a <> b) <> c" , lawContextReduced = reduced lhs rhs , lawContextTcProp = let showA = show a; showB = show b; showC = show c; in lawWhere [ "a <> (b <> c)" `congruency` "(a <> b) <> c, where" , "a = " ++ showA , "b = " ++ showB , "c = " ++ showC ] } heqCtx lhs rhs ctx semigroupCommutative :: forall a. (Eq a, Semigroup a, Show a) => Gen a -> Property semigroupCommutative gen = property $ do a <- forAll gen b <- forAll gen let lhs = a <> b let rhs = b <> a let ctx = contextualise $ LawContext { lawContextLawName = "Commutativity", lawContextTcName = "Semigroup" , lawContextLawBody = "a <> b" `congruency` "b <> a" , lawContextReduced = reduced lhs rhs , lawContextTcProp = let showA = show a; showB = show b; in lawWhere [ "a <> b" `congruency` "b <> a, where" , "a = " ++ showA , "b = " ++ showB ] } heqCtx lhs rhs ctx semigroupConcatenation :: forall a. (Eq a, Semigroup a, Show a) => Gen a -> Property semigroupConcatenation gen = property $ do a <- forAll gen as <- forAll $ genSmallList gen let ne = a :| as let lhs = sconcat ne let rhs = Foldable.foldr1 (<>) ne let ctx = contextualise $ LawContext { lawContextLawName = "Concatenation", lawContextTcName = "Semigroup" , lawContextLawBody = "sconcat" `congruency` "foldr1 (<>)" , lawContextReduced = reduced lhs rhs , lawContextTcProp = let showNE = show ne; in lawWhere [ "sconcat ne" `congruency` "foldr1 (<>) ne, where" , "ne = " ++ showNE ] } heqCtx lhs rhs ctx semigroupTimes :: forall a. (Eq a, Semigroup a, Show a) => Gen a -> Property semigroupTimes gen = property $ do a <- forAll gen n <- forAll (Gen.int (Range.linear 2 5)) let lhs = stimes n a let rhs = Foldable.foldr1 (<>) (replicate n a) let ctx = contextualise $ LawContext { lawContextLawName = "Times", lawContextTcName = "Semigroup" , lawContextLawBody = "stimes n a" `congruency` "foldr1 (<>) (replicate n a)" , lawContextReduced = reduced lhs rhs , lawContextTcProp = let showN = show n; showA = show a; in lawWhere [ "stimes n a" `congruency` "foldr1 (<>) (replicate n a), where" , "a = " ++ showA , "n = " ++ showN ] } heqCtx lhs rhs ctx semigroupExponential :: forall a. (Eq a, Semigroup a, Show a) => Gen a -> Property semigroupExponential gen = property $ do a <- forAll gen b <- forAll gen n <- forAll (Gen.int (Range.linear 2 5)) let lhs = stimes n (a <> b) let rhs = stimes n a <> stimes n b let ctx = contextualise $ LawContext { lawContextLawName = "Exponential", lawContextTcName = "Semigroup" , lawContextLawBody = "stimes n (a <> b)" `congruency` "stimes n a <> stimes n b" , lawContextReduced = reduced lhs rhs , lawContextTcProp = let showN = show n; showA = show a; showB = show b; in lawWhere [ "stimes n (a <> b)" `congruency` "stimes n a <> stimes n b, where" , "a = " ++ showA , "b = " ++ showB , "n = " ++ showN ] } heqCtx lhs rhs ctx semigroupIdempotent :: forall a. (Eq a, Semigroup a, Show a) => Gen a -> Property semigroupIdempotent gen = property $ do a <- forAll gen let lhs = a <> a let rhs = a let ctx = contextualise $ LawContext { lawContextLawName = "Idempotency", lawContextTcName = "Semigroup" , lawContextLawBody = "a <> a" `congruency` "a" , lawContextReduced = reduced lhs rhs , lawContextTcProp = let showA = show a; in lawWhere [ "a <> a" `congruency` "a, where" , "a = " ++ showA ] } heqCtx lhs rhs ctx semigroupRectangularBand :: forall a. (Eq a, Semigroup a, Show a) => Gen a -> Property semigroupRectangularBand gen = property $ do a <- forAll gen b <- forAll gen let lhs = a <> b <> a let rhs = a let ctx = contextualise $ LawContext { lawContextLawName = "Rectangular Band", lawContextTcName = "Semigroup" , lawContextLawBody = "a <> b <> a" `congruency` "a" , lawContextReduced = reduced lhs rhs , lawContextTcProp = let showA = show a; showB = show b; in lawWhere [ "a <> b <> a" `congruency` "a, where" , "a = " ++ showA , "b = " ++ showB ] } heqCtx lhs rhs ctx hedgehog-classes-0.2.5.4/src/Hedgehog/Classes/Semiring.hs0000644000000000000000000003075607346545000021300 0ustar0000000000000000{-# language CPP #-} {-# language ScopedTypeVariables #-} {-# language RankNTypes #-} #ifndef HAVE_SEMIRINGS module Hedgehog.Classes.Semiring () where #else module Hedgehog.Classes.Semiring (semiringLaws, ringLaws, starLaws) where import Hedgehog import Hedgehog.Classes.Common import Prelude hiding (Num(..)) import Data.Semiring import Data.Star -- | Tests the following 'Semiring' laws: -- -- [__Additive Left Identity__]: @'zero' '+' x@ ≡ @x@ -- [__Additive Right Identity__]: @x '+' 'zero'@ ≡ @x@ -- [__Additive Associativity__]: @x '+' (y '+' z)@ ≡ @(x '+' y) '+' z@ -- [__Additive Commutativity__]: @x '+' y@ ≡ @y '+' x@ -- [__Multiplicative Left Identity__]: @'one' '*' x@ ≡ @x@ -- [__Multiplicative Right Identity__]: @x '*' 'one'@ ≡ @x@ -- [__Multiplicative Associativity__]: @x '*' (y '*' z)@ ≡ @(x '*' y) '*' z@ -- [__Multiplicatiion Left-Distributes Over Addtion__]: @x '*' (y '+' z)@ ≡ @(x '*' y) '+' (x '*' z)@ -- [__Multiplication Right-Distibutes Over Addition__]: @(y '+' z) '*' x@ ≡ @(y '*' x) '+' (z '*' x)@ -- [__Multiplicative Left Annihilation__]: @'zero' '*' x@ ≡ @'zero'@ -- [__Multiplicative Right Annihilation__]: @x '*' 'zero'@ ≡ @'zero'@ semiringLaws :: (Semiring a, Eq a, Show a) => Gen a -> Laws semiringLaws gen = Laws "Semiring" [ ("Additive Left Identity", semiringAdditiveLeftIdentity gen) , ("Additive Right Identity", semiringAdditiveRightIdentity gen) , ("Additive Associativity", semiringAdditiveAssociativity gen) , ("Additive Commutativity", semiringAdditiveCommutativity gen) , ("Multiplicative Left Identity", semiringMultiplicativeLeftIdentity gen) , ("Multiplicative Right Identity", semiringMultiplicativeRightIdentity gen) , ("Multiplicative Associativity", semiringMultiplicativeAssociativity gen) , ("Multiplication Left-Distributes Over Addition", semiringLeftMultiplicationDistributes gen) , ("Multiplication Right-Distributes Over Addition", semiringRightMultiplicationDistributes gen) , ("Multiplicative Left Annihilation", semiringLeftAnnihilation gen) , ("Multiplicative Right Annihilation", semiringRightAnnihilation gen) ] -- | Tests the following 'Ring' laws: -- -- [__Additive Inverse__]: @'negate' x '+' x@ ≡ @'zero'@ ringLaws :: (Ring a, Eq a, Show a) => Gen a -> Laws ringLaws gen = Laws "Ring" [ ("Additive Inverse", ringAdditiveInverse gen) ] -- | Tests the following 'Star' laws: -- -- [__Asteration__]: @'star' x@ ≡ @'one' '+' x '*' 'star' x@ -- [__APlus__]: @'aplus' x@ ≡ @x '*' 'star' x@ starLaws :: (Star a, Eq a, Show a) => Gen a -> Laws starLaws gen = Laws "Star" [ ("Asteration", starAsteration gen) , ("APlus", starAplus gen) ] type SemiringProp a = (Semiring a, Eq a, Show a) => Gen a -> Property type RingProp a = (Ring a, Eq a, Show a) => Gen a -> Property type StarProp a = (Star a, Eq a, Show a) => Gen a -> Property ringAdditiveInverse :: forall a. RingProp a ringAdditiveInverse gen = property $ do a <- forAll gen let lhs = negate a + a let rhs = zero :: a let ctx = contextualise $ LawContext { lawContextLawName = "Additive Inverse", lawContextTcName = "Ring" , lawContextLawBody = "negate a + a" `congruency` "zero" , lawContextTcProp = let showA = show a; showZ = show (zero :: a); in lawWhere [ "negate a + a" `congruency` "zero, where" , "a = " ++ showA , "zero = " ++ showZ ] , lawContextReduced = reduced lhs rhs } heqCtx lhs rhs ctx semiringAdditiveLeftIdentity :: forall a. SemiringProp a semiringAdditiveLeftIdentity gen = property $ do x <- forAll gen let lhs = zero + x let rhs = x let ctx = contextualise $ LawContext { lawContextLawName = "Additive Left Identity", lawContextTcName = "Semiring" , lawContextLawBody = "zero + x" `congruency` "x" , lawContextReduced = reduced lhs rhs , lawContextTcProp = let showX = show x; showZ = show (zero :: a); in lawWhere [ "zero + x" `congruency` "x, where" , "x = " ++ showX , "zero = " ++ showZ ] } heqCtx lhs rhs ctx semiringAdditiveRightIdentity :: forall a. SemiringProp a semiringAdditiveRightIdentity gen = property $ do x <- forAll gen let lhs = x + zero let rhs = x let ctx = contextualise $ LawContext { lawContextLawName = "Additive Right Identity", lawContextTcName = "Semiring" , lawContextLawBody = "x + zero" `congruency` "x" , lawContextReduced = reduced lhs rhs , lawContextTcProp = let showX = show x; showZ = show (zero :: a); in lawWhere [ "x + zero" `congruency` "x, where" , "x = " ++ showX , "zero = " ++ showZ ] } heqCtx lhs rhs ctx semiringAdditiveAssociativity :: forall a. SemiringProp a semiringAdditiveAssociativity gen = property $ do a <- forAll gen b <- forAll gen c <- forAll gen let lhs = a + (b + c) let rhs = (a + b) + c let ctx = contextualise $ LawContext { lawContextLawName = "Additive Associativity", lawContextTcName = "Semiring" , lawContextLawBody = "x + (y + z)" `congruency` "(x + y) + z" , lawContextReduced = reduced lhs rhs , lawContextTcProp = let showX = show a; showY = show b; showZ = show c; in lawWhere [ "x + (y + z)" `congruency` "(x + y) + z, where" , "x = " ++ showX , "y = " ++ showY , "z = " ++ showZ ] } heqCtx lhs rhs ctx semiringAdditiveCommutativity :: forall a. SemiringProp a semiringAdditiveCommutativity gen = property $ do a <- forAll gen b <- forAll gen let lhs = a + b let rhs = b + a let ctx = contextualise $ LawContext { lawContextLawName = "Additive Commutativity", lawContextTcName = "Semiring" , lawContextLawBody = "x + y" `congruency` "y + x" , lawContextReduced = reduced lhs rhs , lawContextTcProp = let showX = show a; showY = show b; in lawWhere [ "x + y" `congruency` "y + x, where" , "x = " ++ showX , "y = " ++ showY ] } heqCtx lhs rhs ctx semiringMultiplicativeLeftIdentity :: forall a. SemiringProp a semiringMultiplicativeLeftIdentity gen = property $ do x <- forAll gen let lhs = one * x let rhs = x let ctx = contextualise $ LawContext { lawContextLawName = "Multiplicative Left Identity", lawContextTcName = "Semiring" , lawContextLawBody = "one * x" `congruency` "x" , lawContextReduced = reduced lhs rhs , lawContextTcProp = let showX = show x; showO = show (one :: a); in lawWhere [ "one * x" `congruency` "x, where" , "x = " ++ showX , "one = " ++ showO ] } heqCtx lhs rhs ctx semiringMultiplicativeRightIdentity :: forall a. SemiringProp a semiringMultiplicativeRightIdentity gen = property $ do x <- forAll gen let lhs = x * one let rhs = x let ctx = contextualise $ LawContext { lawContextLawName = "Multiplicative Right Identity", lawContextTcName = "Semiring" , lawContextLawBody = "x * one" `congruency` "x" , lawContextReduced = reduced lhs rhs , lawContextTcProp = let showX = show x; showO = show (one :: a); in lawWhere [ "x * one" `congruency` "x, where" , "x = " ++ showX , "one = " ++ showO ] } heqCtx lhs rhs ctx semiringMultiplicativeAssociativity :: forall a. SemiringProp a semiringMultiplicativeAssociativity gen = property $ do a <- forAll gen b <- forAll gen c <- forAll gen let lhs = a * (b * c) let rhs = (a * b) * c let ctx = contextualise $ LawContext { lawContextLawName = "Multiplicative Associativity", lawContextTcName = "Semiring" , lawContextLawBody = "x * (y * z)" `congruency` "(x * y) * z" , lawContextReduced = reduced lhs rhs , lawContextTcProp = let showX = show a; showY = show b; showZ = show c; in lawWhere [ "x * (y * z)" `congruency` "(x * y) * z, where" , "x = " ++ showX , "y = " ++ showY , "z = " ++ showZ ] } heqCtx lhs rhs ctx semiringLeftMultiplicationDistributes :: forall a. SemiringProp a semiringLeftMultiplicationDistributes gen = property $ do a <- forAll gen b <- forAll gen c <- forAll gen let lhs = a * (b + c) let rhs = (a * b) + (a * c) let ctx = contextualise $ LawContext { lawContextLawName = "Multiplication Left-Distributes Over Addition", lawContextTcName = "Semiring" , lawContextLawBody = "x * (y + z)" `congruency` "(x * y) + (x * z)" , lawContextReduced = reduced lhs rhs , lawContextTcProp = let showX = show a; showY = show b; showZ = show c; in lawWhere [ "x * (y + z)" `congruency` "(x * y) + (x * z), where" , "x = " ++ showX , "y = " ++ showY , "z = " ++ showZ ] } heqCtx lhs rhs ctx semiringRightMultiplicationDistributes :: forall a. SemiringProp a semiringRightMultiplicationDistributes gen = property $ do a <- forAll gen b <- forAll gen c <- forAll gen let lhs = (a + b) * c let rhs = (a * c) + (b * c) let ctx = contextualise $ LawContext { lawContextLawName = "Multiplication Right-Distributes Over Addition", lawContextTcName = "Semiring" , lawContextLawBody = "(y + z) * x" `congruency` "(y * x) + (z * x)" , lawContextReduced = reduced lhs rhs , lawContextTcProp = let showX = show a; showY = show b; showZ = show c; in lawWhere [ "(y + z) * x" `congruency` "(y * x) + (z * x), where" , "x = " ++ showX , "y = " ++ showY , "z = " ++ showZ ] } heqCtx lhs rhs ctx semiringLeftAnnihilation :: forall a. SemiringProp a semiringLeftAnnihilation gen = property $ do x <- forAll gen let lhs = zero * x let rhs = zero let ctx = contextualise $ LawContext { lawContextLawName = "Multiplicative Left Annihilation", lawContextTcName = "Semiring" , lawContextLawBody = "zero * x" `congruency` "zero" , lawContextReduced = reduced lhs rhs , lawContextTcProp = let showX = show x; showZ = show (zero :: a); in lawWhere [ "zero * x" `congruency` "zero, where" , "x = " ++ showX , "zero = " ++ showZ ] } heqCtx lhs rhs ctx semiringRightAnnihilation :: forall a. SemiringProp a semiringRightAnnihilation gen = property $ do x <- forAll gen let lhs = x * zero let rhs = zero let ctx = contextualise $ LawContext { lawContextLawName = "Multiplicative Right Annihilation", lawContextTcName = "Semiring" , lawContextLawBody = "x * zero" `congruency` "zero" , lawContextReduced = reduced lhs rhs , lawContextTcProp = let showX = show x; showZ = show (zero :: a); in lawWhere [ "x * zero" `congruency` "zero, where" , "x = " ++ showX , "zero = " ++ showZ ] } heqCtx lhs rhs ctx starAsteration :: forall a. StarProp a starAsteration gen = property $ do x <- forAll gen let lhs = star x let rhs = one + x * star x let ctx = contextualise $ LawContext { lawContextLawName = "Asteration", lawContextTcName = "Star" , lawContextLawBody = "star x" `congruency` "one + x * star x" , lawContextReduced = reduced lhs rhs , lawContextTcProp = let showX = show x; showOne = show (one :: a); in lawWhere [ "star x" `congruency` "one + x * star x, where" , "x = " ++ showX , "one = " ++ showOne ] } heqCtx lhs rhs ctx starAplus :: forall a. StarProp a starAplus gen = property $ do x <- forAll gen let lhs = aplus x let rhs = x * star x let ctx = contextualise $ LawContext { lawContextLawName = "APlus", lawContextTcName = "Star" , lawContextLawBody = "aplus x" `congruency` "x * star x" , lawContextReduced = reduced lhs rhs , lawContextTcProp = let showX = show x in lawWhere [ "aplus x" `congruency` "x * star x, where" , "x = " ++ showX ] } heqCtx lhs rhs ctx #endif hedgehog-classes-0.2.5.4/src/Hedgehog/Classes/Show.hs0000644000000000000000000000600407346545000020430 0ustar0000000000000000{-# LANGUAGE ScopedTypeVariables #-} module Hedgehog.Classes.Show (showLaws) where import Hedgehog import Hedgehog.Classes.Common -- | Tests the following 'Show' laws: -- -- [__ShowsPrec Zero__]: @'show' a@ ≡ @'showsPrec' 0 a \"\"@ -- [__ShowsPrec Equivariance__]: @'showsPrec' p a r '++' s@ ≡ @'showsPrec p a (r '++' s)@ -- [__ShowsPrec ShowList__]: @'showList' as r '++' s@ ≡ @'showList' as (r '++' s)@ showLaws :: (Show a) => Gen a -> Laws showLaws gen = Laws "Show" [ ("ShowsPrec Zero", showShowsPrecZero gen) , ("Equivariance: showsPrec", equivarianceShowsPrec gen) , ("Equivariance: showList", equivarianceShowList gen) ] showShowsPrecZero :: forall a. (Show a) => Gen a -> Property showShowsPrecZero gen = property $ do a <- forAll gen let lhs = show a let rhs = showsPrec 0 a "" let ctx = contextualise $ LawContext { lawContextLawName = "ShowsPrec Zero", lawContextTcName = "Show" , lawContextLawBody = "show a" `congruency` "showsPrec 0 a \"\"" , lawContextReduced = reduced lhs rhs , lawContextTcProp = let showA = show a; in lawWhere [ "show a" `congruency` "showsPrec 0 a \"\", where" , "a = " ++ showA ] } heqCtx lhs rhs ctx equivarianceShowsPrec :: forall a. (Show a) => Gen a -> Property equivarianceShowsPrec gen = property $ do p <- forAll genShowReadPrecedence a <- forAll gen r <- forAll genSmallString s <- forAll genSmallString let lhs = showsPrec p a r ++ s let rhs = showsPrec p a (r ++ s) let ctx = contextualise $ LawContext { lawContextLawName = "ShowsPrec Equivariance", lawContextTcName = "Show" , lawContextLawBody = "showsPrec p a r ++ s" `congruency` "showsPrec p a (r ++ s)" , lawContextReduced = reduced lhs rhs , lawContextTcProp = let showP = show p; showA = show a; showR = show r; showS = show s; in lawWhere [ "showsPrec p a r ++ s" `congruency` "showsPrec p a (r ++ s), where" , "p = " ++ showP , "a = " ++ showA , "r = " ++ showR , "s = " ++ showS ] } heqCtx lhs rhs ctx equivarianceShowList :: forall a. (Show a) => Gen a -> Property equivarianceShowList gen = property $ do as <- forAll $ genSmallList gen r <- forAll genSmallString s <- forAll genSmallString let lhs = showList as r ++ s let rhs = showList as (r ++ s) let ctx = contextualise $ LawContext { lawContextLawName = "ShowList Equivariance", lawContextTcName = "Show" , lawContextLawBody = "showList as r ++ s" `congruency` "showList as (r ++ s)" , lawContextReduced = reduced lhs rhs , lawContextTcProp = let showAS = show as; showR = show r; showS = show s; in lawWhere [ "showList as r ++ s" `congruency` "showList as (r ++ s), where" , "as = " ++ showAS , "r = " ++ showR , "s = " ++ showS ] } heqCtx lhs rhs ctx hedgehog-classes-0.2.5.4/src/Hedgehog/Classes/ShowRead.hs0000644000000000000000000001242007346545000021223 0ustar0000000000000000{-# LANGUAGE ScopedTypeVariables #-} module Hedgehog.Classes.ShowRead (showReadLaws) where import Hedgehog import Hedgehog.Classes.Common import Text.Read (readListDefault, readMaybe) import Text.Show (showListWith) -- | Tests the following 'Show' / 'Read' laws: -- -- [__Partial Isomorphism: show/read__]: @'readMaybe' '.' 'show'@ ≡ @'Just'@ -- [__Partial Isomorphism: show/read with initial space__]: @'readMaybe' '.' (\" \" '++') '.' 'show'@ ≡ @'Just'@ -- [__Partial Isomorphism: showsPrec/readPrec__]: @(a,\"\") `elem` 'readsPrec' p ('showsPrec' p a \"\")@ ≡ @'True'@ -- [__Partial Isomorphism: showList/readList__]: @(as,\"\") `elem` 'readList' ('showList' as \"\")@ ≡ @'True'@ -- [__Partial Isomorphism: showListWith shows/readListDefault__]: @(as,\"\") `elem` 'readListDefault' ('showListWith' 'shows' as \"\")@ ≡ @'True'@ showReadLaws :: (Eq a, Read a, Show a) => Gen a -> Laws showReadLaws gen = Laws "Show/Read" [ ("Partial Isomorphism: show/read", showReadPartialIsomorphism gen) , ("Partial Isomorphism: show/read with initial space", showReadSpacePartialIsomorphism gen) , ("Partial Isomorphism: showsPrec/readsPrec", showsPrecReadsPrecPartialIsomorphism gen) , ("Partial Isomorphism: showList/readList", showListReadListPartialIsomorphism gen) , ("Partial Isomorphism: showListWith shows/readListDefault", showListWithShowsReadListDefaultPartialIsomorphism gen) ] showReadPartialIsomorphism :: forall a. (Eq a, Read a, Show a) => Gen a -> Property showReadPartialIsomorphism gen = property $ do a <- forAll gen let lhs = readMaybe (show a) let rhs = Just a let ctx = contextualise $ LawContext { lawContextLawName = "Show/Read Partial Isomorphism", lawContextTcName = "Show/Read" , lawContextLawBody = "readMaybe . show" `congruency` "Just" , lawContextReduced = reduced lhs rhs , lawContextTcProp = let showA = show a; in lawWhere [ "readMaybe . show $ a" `congruency` "Just a, where" , "a = " ++ showA ] } heqCtx lhs rhs ctx showReadSpacePartialIsomorphism :: forall a. (Eq a, Read a, Show a) => Gen a -> Property showReadSpacePartialIsomorphism gen = property $ do a <- forAll gen let lhs = readMaybe (" " ++ show a) let rhs = Just a let ctx = contextualise $ LawContext { lawContextLawName = "Show/Read Partial Isomorphism With Initial Space", lawContextTcName = "Show/Read" , lawContextLawBody = "readMaybe . (\" \" ++) . show" `congruency` "Just" , lawContextReduced = reduced lhs rhs , lawContextTcProp = let showA = show a; in lawWhere [ "readMaybe . (\" \" ++) . show $ a" `congruency` "Just a, where" , "a = " ++ showA ] } heqCtx lhs rhs ctx showsPrecReadsPrecPartialIsomorphism :: forall a. (Eq a, Read a, Show a) => Gen a -> Property showsPrecReadsPrecPartialIsomorphism gen = property $ do a <- forAll gen p <- forAll genShowReadPrecedence let lhs = (a,"") `elem` readsPrec p (showsPrec p a "") let rhs = True let ctx = contextualise $ LawContext { lawContextLawName = "ShowsPrec/ReadsPrec partial isomorphism", lawContextTcName = "Show/Read" , lawContextLawBody = "(a,\"\") `elem` readsPrec p (showsPrec p a \"\")" `congruency` "True" , lawContextReduced = reduced lhs rhs , lawContextTcProp = let showA = show a; showP = show p in lawWhere [ "(a,\"\") `elem` readsPrec p (showsPrec p a \"\")" `congruency` "True, where" , "a = " ++ showA , "p = " ++ showP ] } heqCtx lhs rhs ctx showListReadListPartialIsomorphism :: forall a. (Eq a, Read a, Show a) => Gen a -> Property showListReadListPartialIsomorphism gen = property $ do as <- forAll $ genSmallList gen let lhs = (as,"") `elem` readList (showList as "") let rhs = True let ctx = contextualise $ LawContext { lawContextLawName = "ShowsList/ReadsList partial isomorphism", lawContextTcName = "Show/Read" , lawContextLawBody = "(as,\"\") `elem` readList (showList as \"\")" `congruency` "True" , lawContextReduced = reduced lhs rhs , lawContextTcProp = let showAS = show as in lawWhere [ "(as,\"\") `elem` readList (showList as \"\")" `congruency` "True, where" , "as = " ++ showAS ] } heqCtx lhs rhs ctx showListWithShowsReadListDefaultPartialIsomorphism :: forall a. (Eq a, Read a, Show a) => Gen a -> Property showListWithShowsReadListDefaultPartialIsomorphism gen = property $ do as <- forAll $ genSmallList gen let lhs = (as,"") `elem` readListDefault (showListWith shows as "") let rhs = True let ctx = contextualise $ LawContext { lawContextLawName = "ShowListWith/ReadListDefault partial isomorphism", lawContextTcName = "Show/Read" , lawContextLawBody = "(as,\"\") `elem` readListDefault (showListWith shows as \"\")" `congruency` "True" , lawContextReduced = reduced lhs rhs , lawContextTcProp = let showAS = show as in lawWhere [ "(as,\"\") `elem` readListDefault (showListWith shows as \"\")" `congruency` "True, where" , "as = " ++ showAS ] } heqCtx lhs rhs ctx hedgehog-classes-0.2.5.4/src/Hedgehog/Classes/Storable.hs0000644000000000000000000001263307346545000021270 0ustar0000000000000000{-# LANGUAGE ScopedTypeVariables #-} module Hedgehog.Classes.Storable (storableLaws) where import Hedgehog import Hedgehog.Classes.Common import Hedgehog.Internal.Gen (sample) import qualified Data.List as List import qualified Hedgehog.Gen as Gen import qualified Hedgehog.Range as Range import Foreign.Marshal.Alloc import Foreign.Marshal.Array import GHC.Ptr (Ptr(..), nullPtr, plusPtr, minusPtr, alignPtr) import Foreign.Storable (Storable(..)) import System.IO.Unsafe (unsafePerformIO) -- | Tests the following 'Storable' laws: -- -- [__Set-Get__]: @'pokeElemOff' ptr ix a '>>' 'peekElemOff' ptr ix@ ≡ @'pure' a@ -- [__Get-Set__]: @'peekElemOff' ptr ix '>>=' 'pokeElemOff' ptr ix@ ≡ @'pure' ()@ (Putting back what you got out has no effect) -- [__List Conversion Roundtrips__]: Mallocing a list and then reconstructing it gives you the same list -- [__PeekElemOff/Peek__]: @'peekElemOff' a i@ ≡ @'peek' ('plusPtr' a (i '*' 'sizeOf' 'undefined'))@ -- [__PokeElemOff/Poke__]: @'pokeElemOff' a i x@ ≡ @'poke' ('plusPtr' a (i '*' 'sizeOf' 'undefined')) x@ -- [__PeekByteOff/Peek__]: @'peekByteOff' a i@ ≡ @'peek' ('plusPtr' a i)@ -- [__PokeByteOff/Peek__]: @'pokeByteOff' a i x@ ≡ @'poke' ('plusPtr' a i) x@ storableLaws :: (Eq a, Show a, Storable a) => Gen a -> Laws storableLaws gen = Laws "Storable" [ ("Set-Get (you get back what you put in)", storableSetGet gen) , ("Get-Set (putting back what you got out has no effect)", storableGetSet gen) , ("List Conversion Roundtrips", storableList gen) , ("peekElemOff a i ≡ peek (plusPtr a (i * sizeOf undefined))", storablePeekElem gen) , ("pokeElemOff a i x ≡ poke (plusPtr a (i * sizeOf undefined)) x ≡ id ", storablePokeElem gen) , ("peekByteOff a i ≡ peek (plusPtr a i)", storablePeekByte gen) , ("pokeByteOff a i x ≡ poke (plusPtr a i) x ≡ id ", storablePokeByte gen) ] genArray :: forall a. (Storable a) => Gen a -> Int -> IO (Ptr a) genArray gen len = do let go ix xs = if ix == len then pure xs else do x <- sample gen go (ix + 1) (x : xs) as <- go 0 [] newArray as storablePeekElem :: forall a. (Eq a, Show a, Storable a) => Gen a -> Property storablePeekElem gen = property $ do as <- forAll $ genSmallNonEmptyList gen let len = List.length as ix <- forAll $ Gen.int (Range.linear 0 (len - 1)) unsafePerformIO $ do addr <- genArray gen len x <- peekElemOff addr ix y <- peek (addr `plusPtr` (ix * sizeOf (undefined :: a))) free addr pure (x === y) storablePokeElem :: forall a. (Eq a, Show a, Storable a) => Gen a -> Property storablePokeElem gen = property $ do as <- forAll $ genSmallNonEmptyList gen x <- forAll gen let len = List.length as ix <- forAll $ Gen.int (Range.linear 0 (len - 1)) unsafePerformIO $ do addr <- genArray gen len pokeElemOff addr ix x u <- peekElemOff addr ix poke (addr `plusPtr` (ix * sizeOf x)) x v <- peekElemOff addr ix free addr pure (u === v) storablePeekByte :: forall a. (Eq a, Show a, Storable a) => Gen a -> Property storablePeekByte gen = property $ do as <- forAll $ genSmallNonEmptyList gen let len = List.length as ix <- forAll $ Gen.int (Range.linear 0 (len - 1)) let off = ix * (nullPtr `plusPtr` sizeOf (head as)) `alignPtr` alignment (head as) `minusPtr` nullPtr unsafePerformIO $ do addr <- genArray gen len x :: a <- peekByteOff addr off y :: a <- peek (addr `plusPtr` off) free addr pure (x === y) storablePokeByte :: forall a. (Eq a, Show a, Storable a) => Gen a -> Property storablePokeByte gen = property $ do as <- forAll $ genSmallNonEmptyList gen x <- forAll gen let len = List.length as off <- forAll $ Gen.int (Range.linear 0 (len - 1)) unsafePerformIO $ do addr <- genArray gen len pokeByteOff addr off x u :: a <- peekByteOff addr off poke (addr `plusPtr` off) x v :: a <- peekByteOff addr off free addr pure (u === v) storableSetGet :: forall a. (Eq a, Show a, Storable a) => Gen a -> Property storableSetGet gen = property $ do a <- forAll gen len <- forAll $ Gen.int (Range.linear 1 20) ix <- forAll $ Gen.int (Range.linear 0 (len - 1)) unsafePerformIO $ do ptr <- genArray gen len pokeElemOff ptr ix a a' <- peekElemOff ptr ix free ptr pure (a === a') storableGetSet :: forall a. (Eq a, Show a, Storable a) => Gen a -> Property storableGetSet gen = property $ do as <- forAll $ genSmallNonEmptyList gen let len = List.length as ix <- forAll $ Gen.int (Range.linear 0 (len - 1)) unsafePerformIO $ do ptrA <- newArray as ptrB <- genArray gen len copyArray ptrB ptrA len a <- peekElemOff ptrA ix pokeElemOff ptrA ix a res <- arrayEq ptrA ptrB len free ptrA free ptrB pure (res === True) storableList :: forall a. (Eq a, Show a, Storable a) => Gen a -> Property storableList gen = property $ do as <- forAll $ genSmallNonEmptyList gen unsafePerformIO $ do let len = List.length as ptr <- newArray as let rebuild :: Int -> IO [a] rebuild ix = if ix < len then (:) <$> peekElemOff ptr ix <*> rebuild (ix + 1) else pure [] asNew <- rebuild 0 free ptr pure (as === asNew) arrayEq :: forall a. (Eq a, Storable a) => Ptr a -> Ptr a -> Int -> IO Bool arrayEq ptrA ptrB len = go 0 where go i = if i < len then do a <- peekElemOff ptrA i b <- peekElemOff ptrB i if a == b then go (i + 1) else pure False else pure True hedgehog-classes-0.2.5.4/src/Hedgehog/Classes/Traversable.hs0000644000000000000000000000700107346545000021760 0ustar0000000000000000{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE QuantifiedConstraints #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE LambdaCase #-} module Hedgehog.Classes.Traversable (traversableLaws) where import Hedgehog import Hedgehog.Classes.Common import Data.Functor.Identity import Data.Functor.Compose import Data.Traversable (Traversable(..), foldMapDefault, fmapDefault) -- | Tests the following 'Traversable' laws: -- -- [__Naturality__]: @t '.' 'traverse' f@ ≡ @'traverse' (t '.' f), for every applicative transformation t@ -- [__Identity__]: @'traverse' 'Identity'@ ≡ @'Identity'@ -- [__Composition__]: @'traverse' ('Compose' '.' 'fmap' g '.' f)@ ≡ @'Compose' '.' 'fmap' ('traverse' g) '.' 'traverse' f@ -- [__SequenceA Naturality__]: @t '.' 'sequenceA'@ ≡ @'sequenceA' '.' 'fmap' t, for every applicative transformation t@ -- [__SequenceA Identity__]: @'sequenceA' '.' 'fmap' 'Identity'@ ≡ @'Identity'@ -- [__SequenceA Composition__]: @'sequenceA' '.' 'fmap' 'Compose'@ ≡ @'Compose' '.' 'fmap' 'sequenceA' '.' 'sequenceA'@ -- [__FoldMap__]: @'foldMap'@ ≡ @'foldMapDefault'@ -- [__Fmap__]: @'fmap'@ ≡ @'fmapDefault'@ traversableLaws :: ( Traversable f , forall x. Eq x => Eq (f x), forall x. Show x => Show (f x) ) => (forall x. Gen x -> Gen (f x)) -> Laws traversableLaws gen = Laws "Foldable" [ ("Naturality", traversableNaturality gen) , ("Identity", traversableIdentity gen) , ("Composition", traversableComposition gen) , ("Sequence Naturality", traversableSequenceNaturality gen) , ("Sequence Identity", traversableSequenceIdentity gen) , ("Sequence Composition", traversableSequenceComposition gen) , ("foldMap", traversableFoldMap gen) , ("fmap", traversableFmap gen) ] type TraversableProp f = ( Traversable f , forall x. Eq x => Eq (f x), forall x. Show x => Show (f x) ) => (forall x. Gen x -> Gen (f x)) -> Property traversableNaturality :: TraversableProp f traversableNaturality fgen = property $ do a <- forAll $ fgen genSmallInteger (apTrans (traverse func4 a)) `heq1` (traverse (apTrans . func4) a) traversableIdentity :: TraversableProp f traversableIdentity fgen = property $ do t <- forAll $ fgen genSmallInteger (traverse Identity t) `heq1` (Identity t) traversableComposition :: TraversableProp f traversableComposition fgen = property $ do t <- forAll $ fgen genSmallInteger let lhs = (traverse (Compose . fmap func5 . func6) t) let rhs = (Compose (fmap (traverse func5) (traverse func6 t))) lhs `heq1` rhs traversableSequenceNaturality :: TraversableProp f traversableSequenceNaturality fgen = property $ do x <- forAll $ fgen (genCompose genSmallInteger genTriple (genTuple genSetInteger)) let a = fmap toSpecialApplicative x (apTrans (sequenceA a)) `heq1` (sequenceA (fmap apTrans a)) traversableSequenceIdentity :: TraversableProp f traversableSequenceIdentity fgen = property $ do t <- forAll $ fgen genSmallInteger (sequenceA (fmap Identity t)) `heq1` (Identity t) traversableSequenceComposition :: TraversableProp f traversableSequenceComposition fgen = property $ do let genTripleInteger = genTriple genSmallInteger t <- forAll $ fgen (genTriple genTripleInteger) (sequenceA (fmap Compose t)) `heq1` (Compose (fmap sequenceA (sequenceA t))) traversableFoldMap :: TraversableProp f traversableFoldMap fgen = property $ do t <- forAll $ fgen genSmallInteger foldMap func3 t `heq1` foldMapDefault func3 t traversableFmap :: TraversableProp f traversableFmap fgen = property $ do t <- forAll $ fgen genSmallInteger fmap func3 t `heq1` fmapDefault func3 t hedgehog-classes-0.2.5.4/test/0000755000000000000000000000000007346545000014235 5ustar0000000000000000hedgehog-classes-0.2.5.4/test/Spec.hs0000644000000000000000000000331107346545000015461 0ustar0000000000000000module Main (main) where import Hedgehog.Classes import Spec.Alternative import Spec.Applicative import Spec.Arrow import Spec.Bifoldable import Spec.Bifunctor import Spec.Binary import Spec.Bitraversable import Spec.Bits import Spec.Category import Spec.Comonad import Spec.Contravariant import Spec.Enum import Spec.Eq import Spec.Foldable import Spec.Functor import Spec.Generic import Spec.Integral --import Spec.Ix import Spec.Json import Spec.Monad import Spec.Monoid import Spec.MVector import Spec.Ord import Spec.Prim import Spec.Semigroup import Spec.Semiring import Spec.Show import Spec.Storable import Spec.Traversable main :: IO Bool main = lawsCheckMany allLaws allNullaryLaws :: [(String, [Laws])] allNullaryLaws = testBits ++ testEnum ++ testBoundedEnum ++ testBinary ++ testEq ++ testGeneric ++ testIntegral -- ++ testIx ++ testJson ++ testMonoid ++ testCommutativeMonoid ++ testOrd ++ testPrim ++ testSemigroup ++ testCommutativeSemigroup ++ testExponentialSemigroup ++ testIdempotentSemigroup ++ testRectangularBandSemigroup ++ testSemiring ++ testRing ++ testStar ++ testShow ++ testShowRead ++ testStorable ++ testMUVector allUnaryLaws :: [(String, [Laws])] allUnaryLaws = testAlternative ++ testApplicative ++ testComonad ++ testContravariant ++ testFoldable ++ testFunctor ++ testMonad ++ testMonadIO ++ testMonadPlus ++ testMonadZip ++ testTraversable allBinaryLaws :: [(String, [Laws])] allBinaryLaws = testArrow ++ testBifoldable ++ testBifoldableFunctor ++ testBifunctor ++ testBitraversable ++ testCategory ++ testCommutativeCategory allLaws :: [(String, [Laws])] allLaws = allNullaryLaws ++ allUnaryLaws ++ allBinaryLaws hedgehog-classes-0.2.5.4/test/Spec/0000755000000000000000000000000007346545000015127 5ustar0000000000000000hedgehog-classes-0.2.5.4/test/Spec/Alternative.hs0000644000000000000000000000062007346545000017737 0ustar0000000000000000module Spec.Alternative (testAlternative) where import Hedgehog.Classes import qualified Hedgehog.Gen as Gen import qualified Hedgehog.Range as Range testAlternative :: [(String, [Laws])] testAlternative = [ ("[]", lawsList) , ("Maybe", lawsMaybe) ] lawsList :: [Laws] lawsList = [alternativeLaws (Gen.list (Range.linear 0 6))] lawsMaybe :: [Laws] lawsMaybe = [alternativeLaws Gen.maybe] hedgehog-classes-0.2.5.4/test/Spec/Applicative.hs0000644000000000000000000000342407346545000017727 0ustar0000000000000000module Spec.Applicative (testApplicative) where import Data.Functor.Compose (Compose(..)) import Data.Functor.Identity (Identity(..)) import Hedgehog import Hedgehog.Classes import qualified Hedgehog.Gen as Gen import qualified Hedgehog.Range as Range import Prelude hiding (either) testApplicative :: [(String, [Laws])] testApplicative = [ ("[]", lawsList) , ("Maybe", lawsMaybe) , ("Either e", lawsEither) , ("Compose", lawsCompose) -- , ("Bin", lawsBin) ] lawsList :: [Laws] lawsList = [applicativeLaws (Gen.list (Range.linear 0 6))] lawsMaybe :: [Laws] lawsMaybe = [applicativeLaws Gen.maybe] lawsEither :: [Laws] lawsEither = [applicativeLaws eitherInteger] lawsCompose :: [Laws] lawsCompose = [applicativeLaws genCompose] genCompose :: Gen a -> Gen (Compose Identity Identity a) genCompose = fmap (Compose . Identity . Identity) eitherInteger :: MonadGen m => m a -> m (Either Integer a) eitherInteger = either (Gen.integral (Range.linear 0 20)) either :: MonadGen m => m e -> m a -> m (Either e a) either genE genA = Gen.sized $ \n -> Gen.frequency [ (2, Left <$> genE) , (1 + fromIntegral n, Right <$> genA) ] {- data Bin a = Leaf | Node (Bin a) a (Bin a) deriving (Eq, Show) instance Functor Bin where fmap _ Leaf = Leaf fmap f (Node l x r) = Node (fmap f l) (f x) (fmap f r) instance Applicative Bin where pure x = Node Leaf x Leaf Leaf <*> _ = Leaf _ <*> Leaf = Leaf Node fl fx fr <*> Node l x r = Node (fl <*> l) (fx x) (fr <*> r) genBin' :: Gen a -> Gen (Bin a) genBin' gen = do x <- gen pure $ Node (Node Leaf x (Node Leaf x Leaf)) x (Node (Node Leaf x Leaf) x Leaf) genBin :: Gen a -> Gen (Bin a) genBin gen = Gen.frequency [ (1, pure Leaf) , (6, genBin' gen) ] lawsBin :: [Laws] lawsBin = [applicativeLaws genBin] -} hedgehog-classes-0.2.5.4/test/Spec/Arrow.hs0000644000000000000000000000015507346545000016556 0ustar0000000000000000module Spec.Arrow (testArrow) where import Hedgehog.Classes testArrow :: [(String, [Laws])] testArrow = [] hedgehog-classes-0.2.5.4/test/Spec/Bifoldable.hs0000644000000000000000000000175707346545000017520 0ustar0000000000000000module Spec.Bifoldable (testBifoldable, testBifoldableFunctor) where import Data.Functor.Const (Const(..)) import Hedgehog import Hedgehog.Classes import qualified Hedgehog.Gen as Gen import Prelude hiding (either, const) testBifoldable :: [(String, [Laws])] testBifoldable = [ ("Either", lawsEither) , ("Const", lawsConst) ] testBifoldableFunctor :: [(String, [Laws])] testBifoldableFunctor = [ ("Either", functorLawsEither) , ("Const", functorLawsConst) ] lawsConst, functorLawsConst :: [Laws] lawsConst = [bifoldableLaws const] functorLawsConst = [bifoldableFunctorLaws const] const :: MonadGen m => m a -> m b -> m (Const a b) const genA _genB = fmap Const genA lawsEither, functorLawsEither :: [Laws] lawsEither = [bifoldableLaws either] functorLawsEither = [bifoldableFunctorLaws either] either :: MonadGen m => m e -> m a -> m (Either e a) either genE genA = Gen.sized $ \n -> Gen.frequency [ (2, Left <$> genE) , (1 + fromIntegral n, Right <$> genA) ] hedgehog-classes-0.2.5.4/test/Spec/Bifunctor.hs0000644000000000000000000000127507346545000017423 0ustar0000000000000000module Spec.Bifunctor (testBifunctor) where import Data.Functor.Const (Const(..)) import Hedgehog import Hedgehog.Classes import qualified Hedgehog.Gen as Gen import Prelude hiding (either, const) testBifunctor :: [(String, [Laws])] testBifunctor = [ ("Either", lawsEither) , ("Const", lawsConst) ] lawsEither :: [Laws] lawsEither = [bifunctorLaws either] lawsConst :: [Laws] lawsConst = [bifunctorLaws const] const :: MonadGen m => m a -> m b -> m (Const a b) const genA _genB = fmap Const genA either :: MonadGen m => m e -> m a -> m (Either e a) either genE genA = Gen.sized $ \n -> Gen.frequency [ (2, Left <$> genE) , (1 + fromIntegral n, Right <$> genA) ]hedgehog-classes-0.2.5.4/test/Spec/Binary.hs0000644000000000000000000000115107346545000016705 0ustar0000000000000000{-# LANGUAGE DeriveGeneric #-} module Spec.Binary (testBinary) where import Hedgehog import Hedgehog.Classes import qualified Hedgehog.Gen as Gen import qualified Hedgehog.Range as Range import Data.Binary import GHC.Generics (Generic(..)) testBinary :: [(String, [Laws])] testBinary = [ ("Person", listPerson) ] data Person = Person { name :: String, age :: Int } deriving (Eq, Show, Generic) instance Binary Person where listPerson :: [Laws] listPerson = [binaryLaws genPerson] genPerson :: Gen Person genPerson = Person <$> (Gen.string (Range.linear 3 7) Gen.alpha) <*> (Gen.int (Range.linear 0 65)) hedgehog-classes-0.2.5.4/test/Spec/Bitraversable.hs0000644000000000000000000000132507346545000020251 0ustar0000000000000000module Spec.Bitraversable (testBitraversable) where import Data.Functor.Const (Const(..)) import Hedgehog import Hedgehog.Classes import qualified Hedgehog.Gen as Gen import Prelude hiding (either, const) testBitraversable :: [(String, [Laws])] testBitraversable = [ ("Either", lawsEither) , ("Const", lawsConst) ] lawsEither :: [Laws] lawsEither = [bitraversableLaws either] lawsConst :: [Laws] lawsConst = [bitraversableLaws const] const :: MonadGen m => m a -> m b -> m (Const a b) const genA _genB = fmap Const genA either :: MonadGen m => m e -> m a -> m (Either e a) either genE genA = Gen.sized $ \n -> Gen.frequency [ (2, Left <$> genE) , (1 + fromIntegral n, Right <$> genA) ]hedgehog-classes-0.2.5.4/test/Spec/Bits.hs0000644000000000000000000000206507346545000016367 0ustar0000000000000000module Spec.Bits (testBits) where import Hedgehog.Classes import qualified Hedgehog.Gen as Gen import qualified Hedgehog.Range as Range ranged :: (Bounded a, Num a) => (Range.Range a -> b) -> b ranged f = f (Range.constantBounded) testBits :: [(String, [Laws])] testBits = [ ("Int", listInt) , ("Int8", listInt8) , ("Int16", listInt16) , ("Int32", listInt32) , ("Int64", listInt64) , ("Word", listWord) , ("Word8", listWord8) , ("Word16", listWord16) , ("Word32", listWord32) , ("Word64", listWord64) ] listInt, listInt8, listInt16, listInt32, listInt64 :: [Laws] listInt = [bitsLaws (ranged Gen.int)] listInt8 = [bitsLaws (ranged Gen.int8)] listInt16 = [bitsLaws (ranged Gen.int16)] listInt32 = [bitsLaws (ranged Gen.int32)] listInt64 = [bitsLaws (ranged Gen.int64)] listWord, listWord8, listWord16, listWord32, listWord64 :: [Laws] listWord = [bitsLaws (ranged Gen.word)] listWord8 = [bitsLaws (ranged Gen.word8)] listWord16 = [bitsLaws (ranged Gen.word16)] listWord32 = [bitsLaws (ranged Gen.word32)] listWord64 = [bitsLaws (ranged Gen.word64)] hedgehog-classes-0.2.5.4/test/Spec/Category.hs0000644000000000000000000000110107346545000017231 0ustar0000000000000000module Spec.Category (testCategory, testCommutativeCategory) where import Control.Category import Hedgehog import Hedgehog.Classes import Prelude hiding ((.), id) testCategory :: [(String, [Laws])] testCategory = [ ("ProxyC", [categoryLaws genProxyC]) ] testCommutativeCategory :: [(String, [Laws])] testCommutativeCategory = [ ("ProxyC", [commutativeCategoryLaws genProxyC]) ] data ProxyC a b = ProxyC deriving (Eq, Show) instance Category ProxyC where id = ProxyC _ . _ = ProxyC genProxyC :: Gen a -> Gen b -> Gen (ProxyC a b) genProxyC _ _ = pure ProxyC hedgehog-classes-0.2.5.4/test/Spec/Comonad.hs0000644000000000000000000000270607346545000017050 0ustar0000000000000000{-# language DerivingStrategies , GeneralizedNewtypeDeriving #-} {-# options_ghc -fno-warn-orphans #-} module Spec.Comonad ( testComonad ) where import Data.List.NonEmpty import Control.Applicative (liftA2) import Control.Comonad import Control.Comonad.Store hiding (store) import Data.Functor.Identity (Identity(..)) import Hedgehog import Hedgehog.Classes import Prelude hiding (either) import qualified Hedgehog.Gen as Gen import qualified Hedgehog.Range as Range testComonad :: [(String, [Laws])] testComonad = [ ("Identity", [comonadLaws identity]) , ("NonEmpty", [comonadLaws nonempty]) , ("(,) e", [comonadLaws tup]) , ("StoreT Integer Identity", [comonadLaws store]) ] store :: MonadGen m => m a -> m (StoreT Integer Identity a) store gen = do a <- gen pure $ StoreT (Identity (const a)) 20 instance (Comonad w, Show s, Show a) => Show (StoreT s w a) where show (StoreT wf s) = show $ "StoreT { s = " ++ show s ++ ", extract stuff = " ++ show (extract wf s) ++ "}" instance (Comonad w, Eq a) => Eq (StoreT s w a) where StoreT wf s == StoreT wf' s' = extract wf s == extract wf' s' identity :: MonadGen m => m a -> m (Identity a) identity = fmap Identity nonempty :: MonadGen m => m a -> m (NonEmpty a) nonempty gen = liftA2 (:|) gen (list gen) tup :: MonadGen m => m a -> m (Integer, a) tup gen = (,) <$> Gen.integral (Range.linear 20 50) <*> gen list :: MonadGen m => m a -> m [a] list = Gen.list $ Range.linear 0 6 hedgehog-classes-0.2.5.4/test/Spec/Contravariant.hs0000644000000000000000000000353507346545000020304 0ustar0000000000000000{-# LANGUAGE DerivingVia #-} module Spec.Contravariant (testContravariant) where import Hedgehog import Hedgehog.Classes --import Data.Functor.Contravariant -- lol import Data.Functor.Const (Const(..)) import Data.Functor.Sum (Sum(..)) import Data.Functor.Product (Product(..)) import Data.Proxy (Proxy(..)) import qualified Hedgehog.Gen as Gen import qualified Hedgehog.Range as Range testContravariant :: [(String, [Laws])] testContravariant = [ ("Proxy", listProxy) , ("Const", listConst) , ("Sum", listSum) , ("Product", listProduct) -- , ("Bad Contravariant", listBadContravariant) ] listProxy :: [Laws] listProxy = [contravariantLaws genProxy] listConst :: [Laws] listConst = [contravariantLaws genConst] listSum :: [Laws] listSum = [contravariantLaws genSum] listProduct :: [Laws] listProduct = [contravariantLaws genProduct] --listBadContravariant :: [Laws] --listBadContravariant = [contravariantLaws genBadContravariant] genProxy :: Gen a -> Gen (Proxy a) genProxy = const (pure Proxy) genConst :: Gen b -> Gen (Const Integer b) genConst _ = fmap Const (Gen.integral (Range.linear 0 20)) genSum :: Gen a -> Gen (Sum (Const ()) (Const ()) a) genSum _genA = Gen.sized $ \n -> Gen.frequency [ (2, pure $ InL (Const ())) , (1 + fromIntegral n, pure $ InR (Const ())) ] genProduct :: Gen a -> Gen (Product (Const ()) (Const ()) a) genProduct _genA = do pure (Pair (Const ()) (Const ())) {- newtype BadContravariant a = BadContravariant (a -> a) instance Show (BadContravariant a) where show _ = "BadContravariant <>" instance Eq a => Eq (BadContravariant a) where BadContravariant f == BadContravariant g = False instance Contravariant BadContravariant where contramap f _ = BadContravariant id genBadContravariant :: Gen a -> Gen (BadContravariant a) genBadContravariant = fmap (BadContravariant . const) -} hedgehog-classes-0.2.5.4/test/Spec/Enum.hs0000644000000000000000000000375607346545000016402 0ustar0000000000000000module Spec.Enum (testEnum, testBoundedEnum) where import Hedgehog import Hedgehog.Classes import Data.Int (Int64) import Data.Word (Word64) import qualified Hedgehog.Gen as Gen import qualified Hedgehog.Range as Range import Numeric.Natural (Natural) testEnum :: [(String, [Laws])] testEnum = [ ("Integer", listInteger) , ("Natural", listNatural) ] testBoundedEnum :: [(String, [Laws])] testBoundedEnum = [ ("E", listE) , ("Int", listInt) , ("Int8", listInt8) , ("Int16", listInt16) , ("Int32", listInt32) , ("Int64", listInt64) , ("Word", listWord) , ("Word8", listWord8) , ("Word16", listWord16) , ("Word32", listWord32) , ("Word64", listWord64) ] listE :: [Laws] listE = [boundedEnumLaws genE] data E = E1 | E2 | E3 | E4 | E5 | E6 | E7 | E8 deriving (Eq, Show, Enum, Bounded) genE :: Gen E genE = Gen.frequency [ (1, pure E1) , (1, pure E2) , (1, pure E3) , (1, pure E4) , (1, pure E5) , (1, pure E6) , (1, pure E7) , (1, pure E8) ] ranged :: (Bounded a, Num a) => (Range.Range a -> b) -> b ranged f = f (Range.constantBounded) listInt, listInt8, listInt16, listInt32, listInt64 :: [Laws] listInt = [boundedEnumLaws (ranged Gen.int)] listInt8 = [boundedEnumLaws (ranged Gen.int8)] listInt16 = [boundedEnumLaws (ranged Gen.int16)] listInt32 = [boundedEnumLaws (ranged Gen.int32)] listInt64 = [boundedEnumLaws (ranged Gen.int64)] listWord, listWord8, listWord16, listWord32, listWord64 :: [Laws] listWord = [boundedEnumLaws (ranged Gen.word)] listWord8 = [boundedEnumLaws (ranged Gen.word8)] listWord16 = [boundedEnumLaws (ranged Gen.word16)] listWord32 = [boundedEnumLaws (ranged Gen.word32)] listWord64 = [boundedEnumLaws (ranged Gen.word64)] listInteger, listNatural :: [Laws] listInteger = [enumLaws (Gen.integral $ Range.constantFrom (0 :: Integer) (2 * fromIntegral (minBound :: Int64)) (2 * fromIntegral (maxBound :: Int64)))] listNatural = [enumLaws (Gen.integral $ Range.constant (0 :: Natural) (2 * fromIntegral (maxBound :: Word64)))] hedgehog-classes-0.2.5.4/test/Spec/Eq.hs0000644000000000000000000000306507346545000016034 0ustar0000000000000000module Spec.Eq (testEq) where import Hedgehog.Classes import qualified Hedgehog.Gen as Gen import qualified Hedgehog.Range as Range ranged :: (Bounded a, Num a) => (Range.Range a -> b) -> b ranged f = f (Range.constantBounded) testEq :: [(String, [Laws])] testEq = [ ("Int", listInt) , ("Int8", listInt8) , ("Int16", listInt16) , ("Int32", listInt32) , ("Int64", listInt64) , ("Word", listWord) , ("Word8", listWord8) , ("Word16", listWord16) , ("Word32", listWord32) , ("Word64", listWord64) -- , ("BadEq", listBadEq) ] listInt, listInt8, listInt16, listInt32, listInt64 :: [Laws] listInt = [eqLaws (ranged Gen.int)] listInt8 = [eqLaws (ranged Gen.int8)] listInt16 = [eqLaws (ranged Gen.int16)] listInt32 = [eqLaws (ranged Gen.int32)] listInt64 = [eqLaws (ranged Gen.int64)] listWord, listWord8, listWord16, listWord32, listWord64 :: [Laws] listWord = [eqLaws (ranged Gen.word)] listWord8 = [eqLaws (ranged Gen.word8)] listWord16 = [eqLaws (ranged Gen.word16)] listWord32 = [eqLaws (ranged Gen.word32)] listWord64 = [eqLaws (ranged Gen.word64)] {- listBadEq :: [Laws] listBadEq = [ eqLaws $ pure BadReflexive ] ++ [ eqLaws $ Gen.frequency [(1, pure BadSymmetric1),(1,pure BadSymmetric2)] ] data BadReflexive = BadReflexive deriving (Show) instance Eq BadReflexive where _ == _ = False data BadSymmetric = BadSymmetric1 | BadSymmetric2 deriving (Show) instance Eq BadSymmetric where BadSymmetric1 == BadSymmetric1 = True BadSymmetric2 == BadSymmetric2 = True BadSymmetric2 == BadSymmetric1 = True BadSymmetric1 == BadSymmetric2 = False -} hedgehog-classes-0.2.5.4/test/Spec/Foldable.hs0000644000000000000000000000146407346545000017200 0ustar0000000000000000module Spec.Foldable (testFoldable) where import Hedgehog import Hedgehog.Classes import Data.Set (Set) import qualified Data.Set as Set --import qualified Data.List as List --import qualified Hedgehog.Gen as Gen --import qualified Hedgehog.Range as Range testFoldable :: [(String, [Laws])] testFoldable = [ ("Set", listSet) -- , ("BadList", listBadList) ] listSet :: [Laws] listSet = [foldableLaws genSet] genSet :: Gen a -> Gen (Set a) genSet gen = do x <- gen pure (Set.singleton x) {- listBadList :: [Laws] listBadList = [foldableLaws genBadList] genBadList :: Gen a -> Gen (BadList a) genBadList gen = BadList <$> Gen.list (Range.linear 0 20) gen newtype BadList a = BadList [a] deriving (Eq, Show) instance Foldable BadList where foldMap f (BadList x) = foldMap f x foldl' = List.foldl -} hedgehog-classes-0.2.5.4/test/Spec/Functor.hs0000644000000000000000000000213007346545000017077 0ustar0000000000000000module Spec.Functor (testFunctor) where import Data.Functor.Compose (Compose(..)) import Data.Functor.Identity (Identity(..)) import Hedgehog import Hedgehog.Classes import qualified Hedgehog.Gen as Gen import qualified Hedgehog.Range as Range import Prelude hiding (either) testFunctor :: [(String, [Laws])] testFunctor = [ ("[]", lawsList) , ("Maybe", lawsMaybe) , ("Either e", lawsEither) , ("Compose", lawsCompose) ] lawsList :: [Laws] lawsList = [functorLaws (Gen.list (Range.linear 0 6))] lawsMaybe :: [Laws] lawsMaybe = [functorLaws Gen.maybe] lawsEither :: [Laws] lawsEither = [functorLaws eitherInteger] lawsCompose :: [Laws] lawsCompose = [functorLaws genCompose] genCompose :: Gen a -> Gen (Compose Identity Identity a) genCompose = fmap (Compose . Identity . Identity) eitherInteger :: MonadGen m => m a -> m (Either Integer a) eitherInteger = either (Gen.integral (Range.linear 0 20)) either :: MonadGen m => m e -> m a -> m (Either e a) either genE genA = Gen.sized $ \n -> Gen.frequency [ (2, Left <$> genE) , (1 + fromIntegral n, Right <$> genA) ] hedgehog-classes-0.2.5.4/test/Spec/Generic.hs0000644000000000000000000000156407346545000017045 0ustar0000000000000000{-# LANGUAGE DeriveGeneric #-} module Spec.Generic (testGeneric) where import Hedgehog import Hedgehog.Classes import qualified Hedgehog.Gen as Gen import GHC.Generics (Generic(..)) testGeneric :: [(String, [Laws])] testGeneric = [ ("E", listE) , ("Bool", listBool) , ("Maybe Bool", listMaybe) ] listE :: [Laws] listE = [genericLaws genE (genRep genE)] listBool :: [Laws] listBool = [genericLaws Gen.bool (genRep Gen.bool)] listMaybe :: [Laws] listMaybe = [genericLaws (Gen.maybe Gen.bool) (genRep (Gen.maybe Gen.bool))] data E = E1 | E2 | E3 | E4 | E5 | E6 | E7 | E8 deriving (Eq, Show, Generic) genRep :: Generic a => Gen a -> Gen (Rep a ()) genRep gen = do x <- gen pure (from x) genE :: Gen E genE = Gen.frequency [ (1, pure E1) , (1, pure E2) , (1, pure E3) , (1, pure E4) , (1, pure E5) , (1, pure E6) , (1, pure E7) , (1, pure E8) ] hedgehog-classes-0.2.5.4/test/Spec/Integral.hs0000644000000000000000000000216407346545000017233 0ustar0000000000000000module Spec.Integral (testIntegral) where import Hedgehog.Classes import qualified Hedgehog.Gen as Gen import qualified Hedgehog.Range as Range ranged :: (Bounded a, Integral a) => (Range.Range a -> b) -> b ranged f = f (Range.linear 1 maxBound) testIntegral :: [(String, [Laws])] testIntegral = [ ("Int", listInt) , ("Int8", listInt8) , ("Int16", listInt16) , ("Int32", listInt32) , ("Int64", listInt64) , ("Word", listWord) , ("Word8", listWord8) , ("Word16", listWord16) , ("Word32", listWord32) , ("Word64", listWord64) ] listInt, listInt8, listInt16, listInt32, listInt64 :: [Laws] listInt = [integralLaws (ranged Gen.int)] listInt8 = [integralLaws (ranged Gen.int8)] listInt16 = [integralLaws (ranged Gen.int16)] listInt32 = [integralLaws (ranged Gen.int32)] listInt64 = [integralLaws (ranged Gen.int64)] listWord, listWord8, listWord16, listWord32, listWord64 :: [Laws] listWord = [integralLaws (ranged Gen.word)] listWord8 = [integralLaws (ranged Gen.word8)] listWord16 = [integralLaws (ranged Gen.word16)] listWord32 = [integralLaws (ranged Gen.word32)] listWord64 = [integralLaws (ranged Gen.word64)] hedgehog-classes-0.2.5.4/test/Spec/Json.hs0000644000000000000000000000121507346545000016373 0ustar0000000000000000{-# LANGUAGE DeriveGeneric #-} module Spec.Json (testJson) where import Hedgehog import Hedgehog.Classes import qualified Hedgehog.Gen as Gen import qualified Hedgehog.Range as Range import GHC.Generics (Generic) import Data.Aeson (FromJSON, ToJSON) testJson :: [(String, [Laws])] testJson = [ ("Person", listPerson) ] data Person = Person { name :: String, age :: Int } deriving (Eq, Show, Generic) instance FromJSON Person where instance ToJSON Person where listPerson :: [Laws] listPerson = [jsonLaws genPerson] genPerson :: Gen Person genPerson = Person <$> (Gen.string (Range.linear 3 7) Gen.alpha) <*> (Gen.int (Range.linear 0 65)) hedgehog-classes-0.2.5.4/test/Spec/MVector.hs0000644000000000000000000000102607346545000017041 0ustar0000000000000000{-# LANGUAGE CPP #-} #if !HAVE_VECTOR module Spec.MVector (testMUVector) where testMUVector :: [a] testMUVector = [] #else module Spec.MVector (testMUVector) where import qualified Hedgehog.Gen as Gen import qualified Hedgehog.Range as Range import Hedgehog.Classes (Laws, muvectorLaws) testMUVector :: [(String, [Laws])] testMUVector = [ ("Word8", [muvectorLaws (Gen.word8 Range.constantBounded)]) , ("(Int, Word)", [muvectorLaws ((,) <$> Gen.int Range.constantBounded <*> Gen.word Range.constantBounded)]) ] #endif hedgehog-classes-0.2.5.4/test/Spec/Monad.hs0000644000000000000000000000520707346545000016525 0ustar0000000000000000{-# language DerivingStrategies , GeneralizedNewtypeDeriving #-} module Spec.Monad ( testMonad , testMonadIO , testMonadPlus , testMonadZip ) where import Control.Applicative (Alternative(..), liftA2) import Control.Monad.IO.Class (MonadIO(..)) import Data.Functor.Identity (Identity(..)) import Hedgehog import Hedgehog.Classes import qualified Hedgehog.Gen as Gen import qualified Hedgehog.Range as Range import System.IO.Unsafe (unsafePerformIO) import Prelude hiding (either) testMonad :: [(String, [Laws])] testMonad = [ ("[]", lawsList) , ("Either e", lawsEither) , ("Identity", lawsIdentity) , ("IO", lawsIO) , ("Maybe", lawsMaybe) ] {- testMonadFix :: [(String, [Laws])] testMonadFix = [ ("[]", fixLawsList) , ("Either e", fixLawsEither) , ("Identity", fixLawsIdentity) , ("IO", fixLawsIO) , ("Maybe", fixLawsMaybe) ] -} testMonadIO :: [(String, [Laws])] testMonadIO = [ ("IO", ioLawsIO) ] testMonadPlus :: [(String, [Laws])] testMonadPlus = [ ("[]", plusLawsList) , ("Maybe", plusLawsMaybe) ] testMonadZip :: [(String, [Laws])] testMonadZip = [ ("[]", zipLawsList) , ("Identity", zipLawsIdentity) , ("Maybe", zipLawsMaybe) ] lawsEither :: [Laws] lawsEither = [monadLaws eitherInteger] eitherInteger :: MonadGen m => m a -> m (Either Integer a) eitherInteger = either (Gen.integral (Range.linear 0 20)) either :: MonadGen m => m e -> m a -> m (Either e a) either genE genA = Gen.sized $ \n -> Gen.frequency [ (2, Left <$> genE) , (1 + fromIntegral n, Right <$> genA) ] lawsIdentity, zipLawsIdentity :: [Laws] lawsIdentity = [monadLaws identity] zipLawsIdentity = [monadZipLaws identity] identity :: MonadGen m => m a -> m (Identity a) identity = fmap Identity lawsList, plusLawsList, zipLawsList :: [Laws] lawsList = [monadLaws list] plusLawsList = [monadPlusLaws list] zipLawsList = [monadZipLaws list] list :: MonadGen m => m a -> m [a] list = Gen.list $ Range.linear 0 6 lawsMaybe, plusLawsMaybe, zipLawsMaybe :: [Laws] lawsMaybe = [monadLaws Gen.maybe] plusLawsMaybe = [monadPlusLaws Gen.maybe] zipLawsMaybe = [monadZipLaws Gen.maybe] lawsIO, ioLawsIO :: [Laws] lawsIO = [monadLaws io] ioLawsIO = [monadIOLaws io] newtype TestIO a = TestIO (IO a) deriving newtype (Functor, Applicative, Monad, Alternative) -- | Unsafe! instance Eq a => Eq (TestIO a) where TestIO a == TestIO b = unsafePerformIO $ liftA2 (==) a b {-# noinline (==) #-} -- | Unsafe! instance Show a => Show (TestIO a) where showsPrec d (TestIO a) = unsafePerformIO $ fmap (showsPrec d) a instance MonadIO TestIO where liftIO = TestIO io :: MonadGen m => m a -> m (TestIO a) io = fmap pure hedgehog-classes-0.2.5.4/test/Spec/Monoid.hs0000644000000000000000000000260407346545000016712 0ustar0000000000000000module Spec.Monoid (testMonoid, testCommutativeMonoid) where import Hedgehog (Gen) import Hedgehog.Classes import Data.Coerce (coerce) import qualified Hedgehog.Gen as Gen import qualified Hedgehog.Range as Range import Data.Monoid testMonoid :: [(String, [Laws])] testMonoid = [ ("Sum Integer", lawsSum) , ("Product Integer", lawsProduct) , ("Maybe Integer", lawsMaybe) , ("Ap Maybe Integer", lawsAp) ] testCommutativeMonoid :: [(String, [Laws])] testCommutativeMonoid = [ ("Sum Integer", commutativeLawsSum) , ("Product Integer", commutativeLawsProduct) , ("Maybe Integer", commutativeLawsMaybe) ] genInteger :: Gen Integer genInteger = Gen.integral (Range.linear (-3) 20) lawsSum, commutativeLawsSum :: [Laws] lawsSum = [monoidLaws genSum] commutativeLawsSum = [commutativeMonoidLaws genSum] genSum :: Gen (Sum Integer) genSum = fmap coerce genInteger lawsProduct, commutativeLawsProduct :: [Laws] lawsProduct = [monoidLaws genProduct] commutativeLawsProduct = [commutativeMonoidLaws genProduct] genProduct :: Gen (Product Integer) genProduct = fmap coerce genInteger lawsMaybe, commutativeLawsMaybe :: [Laws] lawsMaybe = [monoidLaws genMaybe] commutativeLawsMaybe = [commutativeMonoidLaws genMaybe] genMaybe :: Gen (Maybe (Sum Integer)) genMaybe = Gen.maybe genSum lawsAp :: [Laws] lawsAp = [monoidLaws genAp] genAp :: Gen (Ap Maybe (Sum Integer)) genAp = fmap coerce genMaybe hedgehog-classes-0.2.5.4/test/Spec/Ord.hs0000644000000000000000000000271607346545000016215 0ustar0000000000000000{-# language TypeApplications #-} module Spec.Ord (testOrd) where import Hedgehog.Classes import Hedgehog (Gen) import GHC.Natural import qualified Hedgehog.Range as Range import qualified Hedgehog.Gen as Gen testOrd :: [(String, [Laws])] testOrd = [ ("Int", listInt) , ("Int8", listInt8) , ("Int16", listInt16) , ("Int32", listInt32) , ("Int64", listInt64) , ("Word", listWord) , ("Word8", listWord8) , ("Word16", listWord16) , ("Word32", listWord32) , ("Word64", listWord64) , ("Natural", listNatural) , ("Pair", listPair) ] ranged :: (Integral a) => (Range.Range a -> b) -> b ranged f = f (Range.linear 0 100) listInt, listInt8, listInt16, listInt32, listInt64 :: [Laws] listInt = [ordLaws (ranged Gen.int)] listInt8 = [ordLaws (ranged Gen.int8)] listInt16 = [ordLaws (ranged Gen.int16)] listInt32 = [ordLaws (ranged Gen.int32)] listInt64 = [ordLaws (ranged Gen.int64)] listWord, listWord8, listWord16, listWord32, listWord64 :: [Laws] listWord = [ordLaws (ranged Gen.word)] listWord8 = [ordLaws (ranged Gen.word8)] listWord16 = [ordLaws (ranged Gen.word16)] listWord32 = [ordLaws (ranged Gen.word32)] listWord64 = [ordLaws (ranged Gen.word64)] listNatural :: [Laws] listNatural = [ordLaws (ranged @Natural Gen.integral)] listPair :: [Laws] listPair = [ordLaws (genPair (ranged Gen.int) (ranged Gen.int8))] data Pair a b = Pair a b deriving (Eq, Ord, Show) genPair :: Gen a -> Gen b -> Gen (Pair a b) genPair genA genB = Pair <$> genA <*> genB hedgehog-classes-0.2.5.4/test/Spec/Prim.hs0000644000000000000000000000153207346545000016373 0ustar0000000000000000{-# language TypeApplications #-} module Spec.Prim (testPrim) where import qualified Hedgehog.Gen as Gen import qualified Hedgehog.Range as Range import Hedgehog.Classes (Laws, primLaws) testPrim :: [(String, [Laws])] testPrim = [ ("Int", [primLaws (Gen.int Range.constantBounded)]) , ("Int8", [primLaws (Gen.int8 Range.constantBounded)]) , ("Int16", [primLaws (Gen.int16 Range.constantBounded)]) , ("Int32", [primLaws (Gen.int32 Range.constantBounded)]) , ("Int64", [primLaws (Gen.int64 Range.constantBounded)]) , ("Word", [primLaws (Gen.word Range.constantBounded)]) , ("Word8", [primLaws (Gen.word8 Range.constantBounded)]) , ("Word16", [primLaws (Gen.word16 Range.constantBounded)]) , ("Word32", [primLaws (Gen.word32 Range.constantBounded)]) , ("Word64", [primLaws (Gen.word64 Range.constantBounded)]) ] hedgehog-classes-0.2.5.4/test/Spec/Semigroup.hs0000644000000000000000000000324107346545000017435 0ustar0000000000000000module Spec.Semigroup ( testSemigroup , testCommutativeSemigroup , testExponentialSemigroup , testIdempotentSemigroup , testRectangularBandSemigroup ) where import Hedgehog.Classes import Data.Monoid (Sum(..)) import Data.Semigroup (Last(..)) import Hedgehog (Gen) import qualified Hedgehog.Gen as Gen import qualified Hedgehog.Range as Range testSemigroup :: [(String, [Laws])] testSemigroup = [ ("Last", lawsLast) , ("Maybe", lawsMaybe) ] testCommutativeSemigroup :: [(String, [Laws])] testCommutativeSemigroup = [ ("Maybe", commutativeLawsMaybe) ] testExponentialSemigroup :: [(String, [Laws])] testExponentialSemigroup = [ ("Last", exponentialLawsLast) , ("Maybe", exponentialLawsMaybe) ] testIdempotentSemigroup :: [(String, [Laws])] testIdempotentSemigroup = [ ("Last", idempotentLawsLast) ] testRectangularBandSemigroup :: [(String, [Laws])] testRectangularBandSemigroup = [ ("Last", rectangularBandLawsLast) ] genInteger :: Gen Integer genInteger = Gen.integral (Range.linear (-3) 20) lawsLast, exponentialLawsLast, idempotentLawsLast, rectangularBandLawsLast :: [Laws] lawsLast = [semigroupLaws genLast] exponentialLawsLast = [exponentialSemigroupLaws genLast] idempotentLawsLast = [idempotentSemigroupLaws genLast] rectangularBandLawsLast = [rectangularBandSemigroupLaws genLast] genLast :: Gen (Last Integer) genLast = Last <$> genInteger lawsMaybe, commutativeLawsMaybe, exponentialLawsMaybe :: [Laws] lawsMaybe = [semigroupLaws genMaybe] commutativeLawsMaybe = [commutativeSemigroupLaws genMaybe] exponentialLawsMaybe = [exponentialSemigroupLaws genMaybe] genMaybe :: Gen (Maybe (Sum Integer)) genMaybe = Gen.maybe (Sum <$> genInteger) hedgehog-classes-0.2.5.4/test/Spec/Semiring.hs0000644000000000000000000000442507346545000017245 0ustar0000000000000000module Spec.Semiring ( testSemiring , testRing , testStar ) where import Hedgehog.Classes import qualified Hedgehog.Gen as Gen import qualified Hedgehog.Range as Range testSemiring :: [(String, [Laws])] testSemiring = [ ("Bool", lawsBool) , ("Int", lawsInt) , ("Int8", lawsInt8) , ("Int16", lawsInt16) , ("Int32", lawsInt32) , ("Int64", lawsInt64) , ("Word", lawsWord) , ("Word8", lawsWord8) , ("Word16", lawsWord16) , ("Word32", lawsWord32) , ("Word64", lawsWord64) ] testRing :: [(String, [Laws])] testRing = [ ("Int", ringLawsInt) , ("Int8", ringLawsInt8) , ("Int16", ringLawsInt16) , ("Int32", ringLawsInt32) , ("Int64", ringLawsInt64) , ("Word", ringLawsWord) , ("Word8", ringLawsWord8) , ("Word16", ringLawsWord16) , ("Word32", ringLawsWord32) , ("Word64", ringLawsWord64) ] testStar :: [(String, [Laws])] testStar = [ ("Bool", starLawsBool) ] ranged :: (Bounded a, Num a) => (Range.Range a -> b) -> b ranged f = f Range.constantBounded lawsBool, starLawsBool :: [Laws] lawsBool = [semiringLaws Gen.bool] starLawsBool = [starLaws Gen.bool] lawsInt, lawsInt8, lawsInt16, lawsInt32, lawsInt64 :: [Laws] lawsInt = [semiringLaws (ranged Gen.int)] lawsInt8 = [semiringLaws (ranged Gen.int8)] lawsInt16 = [semiringLaws (ranged Gen.int16)] lawsInt32 = [semiringLaws (ranged Gen.int32)] lawsInt64 = [semiringLaws (ranged Gen.int64)] lawsWord, lawsWord8, lawsWord16, lawsWord32, lawsWord64 :: [Laws] lawsWord = [semiringLaws (ranged Gen.word)] lawsWord8 = [semiringLaws (ranged Gen.word8)] lawsWord16 = [semiringLaws (ranged Gen.word16)] lawsWord32 = [semiringLaws (ranged Gen.word32)] lawsWord64 = [semiringLaws (ranged Gen.word64)] ringLawsInt, ringLawsInt8, ringLawsInt16, ringLawsInt32, ringLawsInt64 :: [Laws] ringLawsInt = [ringLaws (ranged Gen.int)] ringLawsInt8 = [ringLaws (ranged Gen.int8)] ringLawsInt16 = [ringLaws (ranged Gen.int16)] ringLawsInt32 = [ringLaws (ranged Gen.int32)] ringLawsInt64 = [ringLaws (ranged Gen.int64)] ringLawsWord, ringLawsWord8, ringLawsWord16, ringLawsWord32, ringLawsWord64 :: [Laws] ringLawsWord = [ringLaws (ranged Gen.word)] ringLawsWord8 = [ringLaws (ranged Gen.word8)] ringLawsWord16 = [ringLaws (ranged Gen.word16)] ringLawsWord32 = [ringLaws (ranged Gen.word32)] ringLawsWord64 = [ringLaws (ranged Gen.word64)] hedgehog-classes-0.2.5.4/test/Spec/Show.hs0000644000000000000000000000451207346545000016405 0ustar0000000000000000module Spec.Show ( testShow , testShowRead ) where import Hedgehog import Hedgehog.Classes import qualified Hedgehog.Gen as Gen import qualified Hedgehog.Range as Range testShow :: [(String, [Laws])] testShow = [ ("E", lawsE) , ("Int", lawsInt) , ("Int8", lawsInt8) , ("Int16", lawsInt16) , ("Int32", lawsInt32) , ("Int64", lawsInt64) , ("Word", lawsWord) , ("Word8", lawsWord8) , ("Word16", lawsWord16) , ("Word32", lawsWord32) , ("Word64", lawsWord64) ] testShowRead :: [(String, [Laws])] testShowRead = [ ("E", readLawsE) , ("Int", readLawsInt) , ("Int8", readLawsInt8) , ("Int16", readLawsInt16) , ("Int32", readLawsInt32) , ("Int64", readLawsInt64) , ("Word", readLawsWord) , ("Word8", readLawsWord8) , ("Word16", readLawsWord16) , ("Word32", readLawsWord32) , ("Word64", readLawsWord64) ] lawsE, readLawsE :: [Laws] lawsE = [showLaws genE] readLawsE = [showReadLaws genE] data E = E1 | E2 | E3 | E4 | E5 | E6 | E7 | E8 deriving (Eq, Show, Read, Enum, Bounded) genE :: Gen E genE = Gen.enumBounded ranged :: (Bounded a, Num a) => (Range.Range a -> b) -> b ranged f = f (Range.constantBounded) lawsInt, lawsInt8, lawsInt16, lawsInt32, lawsInt64 :: [Laws] lawsInt = [showLaws (ranged Gen.int)] lawsInt8 = [showLaws (ranged Gen.int8)] lawsInt16 = [showLaws (ranged Gen.int16)] lawsInt32 = [showLaws (ranged Gen.int32)] lawsInt64 = [showLaws (ranged Gen.int64)] lawsWord, lawsWord8, lawsWord16, lawsWord32, lawsWord64 :: [Laws] lawsWord = [showLaws (ranged Gen.word)] lawsWord8 = [showLaws (ranged Gen.word8)] lawsWord16 = [showLaws (ranged Gen.word16)] lawsWord32 = [showLaws (ranged Gen.word32)] lawsWord64 = [showLaws (ranged Gen.word64)] readLawsInt, readLawsInt8, readLawsInt16, readLawsInt32, readLawsInt64 :: [Laws] readLawsInt = [showReadLaws (ranged Gen.int)] readLawsInt8 = [showReadLaws (ranged Gen.int8)] readLawsInt16 = [showReadLaws (ranged Gen.int16)] readLawsInt32 = [showReadLaws (ranged Gen.int32)] readLawsInt64 = [showReadLaws (ranged Gen.int64)] readLawsWord, readLawsWord8, readLawsWord16, readLawsWord32, readLawsWord64 :: [Laws] readLawsWord = [showReadLaws (ranged Gen.word)] readLawsWord8 = [showReadLaws (ranged Gen.word8)] readLawsWord16 = [showReadLaws (ranged Gen.word16)] readLawsWord32 = [showReadLaws (ranged Gen.word32)] readLawsWord64 = [showReadLaws (ranged Gen.word64)] hedgehog-classes-0.2.5.4/test/Spec/Storable.hs0000644000000000000000000000513207346545000017237 0ustar0000000000000000module Spec.Storable (testStorable) where import Foreign.C.String (CString, newCString, peekCString) import Foreign.C.Types (CInt) import Foreign.Ptr (nullPtr, castPtr, plusPtr, minusPtr, alignPtr) import Foreign.Storable (Storable, sizeOf, alignment, peek, peekByteOff, poke, pokeByteOff) import Hedgehog (Gen) import Hedgehog.Classes import qualified Hedgehog.Gen as Gen import qualified Hedgehog.Range as Range testStorable :: [(String, [Laws])] testStorable = [ ("Int", lawsInt) , ("Int8", lawsInt8) , ("Int16", lawsInt16) , ("Int32", lawsInt32) , ("Int64", lawsInt64) , ("Word", lawsWord) , ("Word8", lawsWord8) , ("Word16", lawsWord16) , ("Word32", lawsWord32) , ("Word64", lawsWord64) , ("complex struct", lawsStruct) ] ranged :: (Bounded a, Num a) => (Range.Range a -> b) -> b ranged f = f (Range.constantBounded) lawsInt, lawsInt8, lawsInt16, lawsInt32, lawsInt64 :: [Laws] lawsInt = [storableLaws (ranged Gen.int)] lawsInt8 = [storableLaws (ranged Gen.int8)] lawsInt16 = [storableLaws (ranged Gen.int16)] lawsInt32 = [storableLaws (ranged Gen.int32)] lawsInt64 = [storableLaws (ranged Gen.int64)] lawsWord, lawsWord8, lawsWord16, lawsWord32, lawsWord64 :: [Laws] lawsWord = [storableLaws (ranged Gen.word)] lawsWord8 = [storableLaws (ranged Gen.word8)] lawsWord16 = [storableLaws (ranged Gen.word16)] lawsWord32 = [storableLaws (ranged Gen.word32)] lawsWord64 = [storableLaws (ranged Gen.word64)] lawsStruct :: [Laws] lawsStruct = [storableLaws genStruct] genStruct :: Gen TestStruct genStruct = TestStruct <$> fmap fromIntegral (Gen.integral Range.linearBounded :: Gen CInt) <*> Gen.string (Range.linear 0 16) (Gen.filter (/= '\NUL') Gen.latin1) data TestStruct = TestStruct { testPadding :: Int , testString :: String } deriving (Eq, Show) instance Storable TestStruct where sizeOf _ = offsetTest + (sizeOf (undefined :: Int) `max` sizeOf (undefined :: CString)) alignment _ = alignment (undefined :: Int) `lcm` alignment (undefined :: CString) peek ptr = do pad <- peek $ castPtr ptr strPtr <- peekByteOff ptr offsetTest str <- if strPtr == nullPtr then return "" else peekCString strPtr return $ TestStruct { testPadding = pad , testString = str } poke ptr x = do poke (castPtr ptr) $ testPadding x strPtr <- newCString $ testString x pokeByteOff ptr offsetTest strPtr offsetTest :: Int offsetTest = (nullPtr `plusPtr` sizeOf int) `alignPtr` alignment string `minusPtr` nullPtr where int = undefined :: Int string = undefined :: CString hedgehog-classes-0.2.5.4/test/Spec/Traversable.hs0000644000000000000000000000047107346545000017737 0ustar0000000000000000module Spec.Traversable (testTraversable) where import Hedgehog.Classes import qualified Hedgehog.Gen as Gen import qualified Hedgehog.Range as Range testTraversable :: [(String, [Laws])] testTraversable = [ ("[]", lawsList) ] lawsList :: [Laws] lawsList = [traversableLaws (Gen.list (Range.linear 0 6))]