├── .gitignore ├── .travis.yml ├── Makefile ├── README.md ├── hedgehog-checkers-lens ├── LICENSE ├── Makefile ├── README.md ├── Setup.hs ├── hedgehog-checkers-lens.cabal ├── package.yaml ├── src │ └── Hedgehog │ │ └── Checkers │ │ └── Lens │ │ └── Properties.hs ├── stack.yaml └── tests │ └── tests.hs ├── hedgehog-checkers ├── LICENSE ├── Makefile ├── Setup.hs ├── hedgehog-checkers.cabal ├── package.yaml ├── src │ └── Hedgehog │ │ ├── Checkers.hs │ │ └── Checkers │ │ ├── Classes.hs │ │ ├── Properties.hs │ │ └── Ugly │ │ └── Function │ │ └── Hack.hs └── tests │ └── tests.hs └── stack.yaml /.gitignore: -------------------------------------------------------------------------------- 1 | dist 2 | dist-* 3 | cabal-dev 4 | *.o 5 | *.hi 6 | *.chi 7 | *.chs.h 8 | *.dyn_o 9 | *.dyn_hi 10 | .hpc 11 | .hsenv 12 | .cabal-sandbox/ 13 | cabal.sandbox.config 14 | *.prof 15 | *.aux 16 | *.hp 17 | *.eventlog 18 | .stack-work/ 19 | cabal.project.local 20 | .HTF/ 21 | .ghc.environment.* 22 | 23 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | sudo: false 2 | language: generic 3 | 4 | install: 5 | # stack 6 | - mkdir -p ~/.local/bin 7 | - travis_retry curl -L https://github.com/commercialhaskell/stack/releases/download/v1.4.0/stack-1.4.0-linux-x86_64.tar.gz | tar xz --wildcards --strip-components=1 -C ~/.local/bin '*/stack' 8 | - export PATH=~/.local/bin:$PATH 9 | - stack --no-terminal --version 10 | 11 | script: 12 | - stack setup --no-terminal 13 | - stack update --no-terminal 14 | - stack build -j2 --fast --no-terminal 15 | - travis_wait 45 sleep 1800 & 16 | - stack test --no-terminal hedgehog-checkers:tests 17 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | stack_yaml = STACK_YAML="stack.yaml" 2 | stack = $(stack_yaml) stack 3 | 4 | build: 5 | $(stack) build 6 | 7 | test: 8 | $(stack) test 9 | 10 | upload: 11 | $(stack) upload hedgehog-checkers 12 | $(stack) upload hedgehog-checkers-lens 13 | 14 | .PHONY : build test 15 | 16 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # hedgehog-checkers 2 | 3 | [![Build Status](https://travis-ci.org/bitemyapp/hedgehog-checkers.svg?branch=master)](https://travis-ci.org/bitemyapp/hedgehog-checkers) 4 | 5 | `hedgehog-checkers` wraps up the expected properties associated with various standard type classes as Hedgehog properties. Inspired by Conal Elliot's [checkers](https://hackage.haskell.org/package/checkers) library. 6 | 7 | `hedgehog-checkers-lens` depends on `hedgehog-checkers` and includes `Lens`, `Prism`, `Setter`, `Traversal`, and `Iso`. The properties are defined for the widely used [lens library](https://github.com/ekmett/lens/). 8 | -------------------------------------------------------------------------------- /hedgehog-checkers-lens/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright Author name here (c) 2017 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Author name here nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -------------------------------------------------------------------------------- /hedgehog-checkers-lens/Makefile: -------------------------------------------------------------------------------- 1 | package = hedgehog-checkers-lens 2 | 3 | stack_yaml = STACK_YAML="../stack.yaml" 4 | stack = $(stack_yaml) stack 5 | 6 | build: 7 | $(stack) build $(package) 8 | 9 | build-dirty: 10 | $(stack) build --ghc-options=-fforce-recomp $(package) 11 | 12 | run: 13 | $(stack) build --fast && $(stack) exec -- $(package) 14 | 15 | install: 16 | $(stack) install 17 | 18 | ghci: 19 | $(stack) ghci $(package):lib 20 | 21 | test: 22 | $(stack) test $(package) 23 | 24 | test-ghci: 25 | $(stack) ghci $(package):test:$(package)-tests 26 | 27 | bench: 28 | $(stack) bench $(package) 29 | 30 | ghcid: 31 | $(stack) exec -- ghcid -c "stack ghci $(package):lib --test --ghci-options='-fobject-code -fno-warn-unused-do-bind' --main-is $(package):$(package)" 32 | 33 | dev-deps: 34 | stack install ghcid 35 | 36 | .PHONY : build build-dirty run install ghci test test-ghci ghcid dev-deps 37 | 38 | -------------------------------------------------------------------------------- /hedgehog-checkers-lens/README.md: -------------------------------------------------------------------------------- 1 | # hedgehog-checkers-lens 2 | -------------------------------------------------------------------------------- /hedgehog-checkers-lens/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /hedgehog-checkers-lens/hedgehog-checkers-lens.cabal: -------------------------------------------------------------------------------- 1 | -- This file has been generated from package.yaml by hpack version 0.28.2. 2 | -- 3 | -- see: https://github.com/sol/hpack 4 | -- 5 | -- hash: 6d8a12f17d936f2e4a1c75d0c1e8bfb3a6e4fb9d1654f7c87b59c4ff832b5794 6 | 7 | name: hedgehog-checkers-lens 8 | version: 0.1.0.0 9 | description: hedgehog-checkers-lens provides the various lens, prism, setter, and traversal laws as ready-to-use properties. 10 | category: Web 11 | homepage: https://github.com/bitemyapp/hedgehog-checkers#readme 12 | author: Chris Allen 13 | maintainer: cma@bitemyapp.com 14 | copyright: 2017, Chris Allen 15 | license: BSD3 16 | license-file: LICENSE 17 | build-type: Simple 18 | cabal-version: >= 1.10 19 | extra-source-files: 20 | README.md 21 | 22 | library 23 | hs-source-dirs: 24 | src 25 | build-depends: 26 | base >=4.7 && <5 27 | , hedgehog >=0.5 && <0.6 28 | , hedgehog-checkers 29 | , lens >=4 && <5 30 | exposed-modules: 31 | Hedgehog.Checkers.Lens.Properties 32 | other-modules: 33 | Paths_hedgehog_checkers_lens 34 | default-language: Haskell2010 35 | 36 | test-suite tests 37 | type: exitcode-stdio-1.0 38 | main-is: tests.hs 39 | hs-source-dirs: 40 | tests 41 | ghc-options: -threaded -Wall -rtsopts -with-rtsopts=-N 42 | build-depends: 43 | base >=4.7 && <5 44 | , hedgehog >=0.5 && <0.6 45 | , hedgehog-checkers 46 | , hedgehog-checkers-lens 47 | , lens >=4 && <5 48 | other-modules: 49 | Paths_hedgehog_checkers_lens 50 | default-language: Haskell2010 51 | -------------------------------------------------------------------------------- /hedgehog-checkers-lens/package.yaml: -------------------------------------------------------------------------------- 1 | name: hedgehog-checkers-lens 2 | version: 0.1.0.0 3 | homepage: https://github.com/bitemyapp/hedgehog-checkers#readme 4 | license: BSD3 5 | author: Chris Allen 6 | maintainer: cma@bitemyapp.com 7 | copyright: 2017, Chris Allen 8 | category: Web 9 | description: hedgehog-checkers-lens provides the various lens, prism, setter, and traversal laws as ready-to-use properties. 10 | extra-source-files: 11 | - README.md 12 | 13 | dependencies: 14 | - base >= 4.7 && < 5 15 | - hedgehog >= 0.5 && < 0.6 16 | - hedgehog-checkers 17 | - lens >= 4 && < 5 18 | 19 | library: 20 | source-dirs: src 21 | exposed-modules: 22 | - Hedgehog.Checkers.Lens.Properties 23 | 24 | tests: 25 | tests: 26 | main: tests.hs 27 | source-dirs: tests 28 | dependencies: 29 | - hedgehog-checkers-lens 30 | ghc-options: 31 | - -threaded 32 | - -Wall 33 | - -rtsopts 34 | - -with-rtsopts=-N 35 | -------------------------------------------------------------------------------- /hedgehog-checkers-lens/src/Hedgehog/Checkers/Lens/Properties.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables #-} 2 | {-# LANGUAGE RankNTypes #-} 3 | 4 | module Hedgehog.Checkers.Lens.Properties 5 | ( isSetter 6 | , isLens 7 | , isIso 8 | , isPrism 9 | , isTraversal 10 | ) where 11 | 12 | import Control.Applicative 13 | import Data.Functor.Compose 14 | 15 | import Control.Lens 16 | 17 | import Hedgehog 18 | import qualified Hedgehog.Gen as Gen 19 | import qualified Hedgehog.Range as Range 20 | 21 | import Hedgehog.Checkers.Ugly.Function.Hack 22 | 23 | ----------------------------------------------------------- 24 | -- | A 'Setter' is only legal if the following 3 laws hold: 25 | -- 26 | -- 1. @set l y (set l x a) ≡ set l y a@ 27 | -- 28 | -- 2. @over l id ≡ id@ 29 | -- 30 | -- 3. @over l f . over l g ≡ over l (f . g)@ 31 | isSetter :: (Show s, Show a, Eq s) 32 | => Setter' s a 33 | -> Gen a 34 | -> Gen s 35 | -> Gen (a -> a) 36 | -> PropertyT IO () 37 | isSetter setter genv gens genf = do 38 | settee <- forAll gens 39 | val <- forAll genv 40 | val' <- forAll genv 41 | f <- funcForAllWtf genf 42 | g <- funcForAllWtf genf 43 | assert $ setter_id setter settee 44 | assert $ setter_composition setter settee f g 45 | assert $ setter_set_set setter val val' settee 46 | 47 | -- The first setter law: 48 | setter_id :: Eq s => Setter' s a -> s -> Bool 49 | setter_id l s = over l id s == s 50 | 51 | -- The second setter law: 52 | setter_composition :: Eq s 53 | => Setter' s a 54 | -> s 55 | -> (a -> a) 56 | -> (a -> a) 57 | -> Bool 58 | setter_composition l s f g = 59 | over l f (over l g s) == over l (f . g) s 60 | 61 | setter_set_set :: ( Eq s 62 | , Show a 63 | , Show s 64 | ) 65 | => Setter' s a 66 | -> a 67 | -> a 68 | -> s 69 | -> Bool 70 | setter_set_set setter val val' s = 71 | (set setter val' (set setter val s)) == set setter val' s 72 | 73 | -- type Lens s t a b = forall f. Functor f => (a -> f b) -> s -> f t 74 | 75 | isLens :: ( Eq a 76 | , Eq s 77 | , Show a 78 | , Show s 79 | ) 80 | => Lens' s a 81 | -> Gen a 82 | -> Gen s 83 | -> Gen (a -> a) 84 | -> PropertyT IO () 85 | isLens lens genv gens genf = do 86 | settee <- forAll gens 87 | val <- forAll genv 88 | assert $ lens_set_view lens val settee 89 | assert $ lens_view_set lens settee 90 | isSetter lens genv gens genf 91 | 92 | -- 1) You get back what you put in: 93 | -- view l (set l v s) ≡ v 94 | 95 | lens_set_view :: ( Eq a 96 | , Show a 97 | , Show s 98 | ) 99 | => Lens' s a 100 | -> a 101 | -> s 102 | -> Bool 103 | lens_set_view setter val s = do 104 | (view setter (set setter val s)) == val 105 | 106 | -- 2) Putting back what you got doesn't change anything: 107 | -- set l (view l s) s ≡ s 108 | 109 | lens_view_set :: ( Eq s 110 | , Show s 111 | ) 112 | => Lens' s a 113 | -> s 114 | -> Bool 115 | lens_view_set setter s = do 116 | (set setter (view setter s) s) == s 117 | 118 | 119 | isIso :: ( Eq a 120 | , Eq s 121 | , Show a 122 | , Show s 123 | ) 124 | => Iso' s a 125 | -> Gen a 126 | -> Gen s 127 | -> Gen (a -> a) 128 | -> Gen (s -> s) 129 | -> PropertyT IO () 130 | isIso l gena gens genf genfs = do 131 | a <- forAll gena 132 | s <- forAll gens 133 | assert $ iso_hither l s 134 | assert $ iso_yon l a 135 | isLens l gena gens genf 136 | isLens (from l) gens gena genfs 137 | 138 | -- isIso :: (Arbitrary s, Arbitrary a, CoArbitrary s, CoArbitrary a, Show s, Show a, Eq s, Eq a, Function s, Function a) 139 | -- => Iso' s a -> Property 140 | -- isIso l = iso_hither l .&. iso_yon l .&. isLens l .&. isLens (from l) 141 | 142 | iso_hither :: Eq s => AnIso' s a -> s -> Bool 143 | iso_hither l s = s ^. cloneIso l . from l == s 144 | 145 | iso_yon :: Eq a => AnIso' s a -> a -> Bool 146 | iso_yon l a = a ^. from l . cloneIso l == a 147 | 148 | -- 3) Setting twice is the same as setting once: 149 | -- set l v' (set l v s) ≡ set l v' s 150 | 151 | -- type Prism s t a b = forall p f. (Choice p, Applicative f) => p a (f b) -> p s (f t) 152 | 153 | isPrism :: ( Show s 154 | , Show a 155 | , Eq s 156 | , Eq a 157 | ) 158 | => Prism' s a 159 | -> Gen a 160 | -> Gen s 161 | -> Gen (a -> a) 162 | -> PropertyT IO () 163 | isPrism l gena gens genf = do 164 | a <- forAll gena 165 | s <- forAll gens 166 | assert $ prism_yin l a 167 | assert $ prism_yang l s 168 | isTraversal l gena gens genf 169 | 170 | -- isPrism :: (Arbitrary s, Arbitrary a, CoArbitrary a, Show s, Show a, Eq s, Eq a, Function a) 171 | -- => Prism' s a -> Property 172 | -- isPrism l = isTraversal l .&. prism_yin l .&. prism_yang l 173 | 174 | prism_yin :: Eq a => Prism' s a -> a -> Bool 175 | prism_yin l a = preview l (review l a) == Just a 176 | 177 | prism_yang :: Eq s => Prism' s a -> s -> Bool 178 | prism_yang l s = maybe s (review l) (preview l s) == s 179 | 180 | -- First, if I re or review a value with a Prism and then preview or use (^?), I will get it back: 181 | -- preview l (review l b) ≡ Just b 182 | -- previewOfReviewIdentity :: 183 | -- ( Eq b 184 | -- , Show b 185 | -- ) 186 | -- => Prism' s b 187 | -- -> Gen b 188 | -- -> PropertyT IO () 189 | -- previewOfReviewIdentity prism genb = do 190 | -- b <- forAll genb 191 | -- (preview prism (review prism b)) === (Just b) 192 | 193 | -- Second, if you can extract a value a using a Prism l from a value s, then the value s is completely described by l and a: 194 | -- If preview l s ≡ Just a then review l a ≡ s 195 | -- previewJustReviewIdentity :: PropertyT IO () 196 | -- previewJustReviewIdentity = undefined 197 | 198 | -- | A 'Traversal' is only legal if it is a valid 'Setter' (see 'isSetter' for 199 | -- what makes a 'Setter' valid), and the following laws hold: 200 | -- 201 | -- 1. @t pure ≡ pure@ 202 | -- 203 | -- 2. @fmap (t f) . t g ≡ getCompose . t (Compose . fmap f . g)@ 204 | isTraversal :: ( Eq s 205 | , Show a 206 | , Show s 207 | ) 208 | => Traversal' s a 209 | -> Gen a 210 | -> Gen s 211 | -> Gen (a -> a) 212 | -> PropertyT IO () 213 | isTraversal l gena gens genf = do 214 | s <- forAll gens 215 | as <- forAll (Gen.list (Range.linear 0 50) gena) 216 | bs <- forAll (Gen.list (Range.linear 0 50) gena) 217 | t <- forAll Gen.bool 218 | assert $ traverse_pureMaybe l s 219 | assert $ traverse_pureList l s 220 | assert $ traverse_compose 221 | l 222 | (\x -> as ++ [x] ++ bs) 223 | (\x -> if t then Just x else Nothing) 224 | s 225 | isSetter l gena gens genf 226 | 227 | traverse_pure :: forall f s a 228 | . ( Applicative f 229 | , Eq (f s) 230 | ) 231 | => LensLike' f s a 232 | -> s 233 | -> Bool 234 | traverse_pure l s = l pure s == (pure s :: f s) 235 | 236 | traverse_pureMaybe :: Eq s 237 | => LensLike' Maybe s a 238 | -> s 239 | -> Bool 240 | traverse_pureMaybe = traverse_pure 241 | 242 | traverse_pureList :: Eq s 243 | => LensLike' [] s a 244 | -> s 245 | -> Bool 246 | traverse_pureList = traverse_pure 247 | 248 | traverse_compose :: ( Applicative f 249 | , Applicative g 250 | , Eq (f (g s)) 251 | ) 252 | => Traversal' s a 253 | -> (a -> g a) 254 | -> (a -> f a) 255 | -> s 256 | -> Bool 257 | traverse_compose t f g s = 258 | (fmap (t f) . t g) s == (getCompose . t (Compose . fmap f . g)) s 259 | -------------------------------------------------------------------------------- /hedgehog-checkers-lens/stack.yaml: -------------------------------------------------------------------------------- 1 | # This file was automatically generated by 'stack init' 2 | # 3 | # Some commonly used options have been documented as comments in this file. 4 | # For advanced use and comprehensive documentation of the format, please see: 5 | # https://docs.haskellstack.org/en/stable/yaml_configuration/ 6 | 7 | # Resolver to choose a 'specific' stackage snapshot or a compiler version. 8 | # A snapshot resolver dictates the compiler version and the set of packages 9 | # to be used for project dependencies. For example: 10 | # 11 | # resolver: lts-3.5 12 | # resolver: nightly-2015-09-21 13 | # resolver: ghc-7.10.2 14 | # resolver: ghcjs-0.1.0_ghc-7.10.2 15 | # resolver: 16 | # name: custom-snapshot 17 | # location: "./custom-snapshot.yaml" 18 | resolver: lts-9.11 19 | 20 | # User packages to be built. 21 | # Various formats can be used as shown in the example below. 22 | # 23 | # packages: 24 | # - some-directory 25 | # - https://example.com/foo/bar/baz-0.0.2.tar.gz 26 | # - location: 27 | # git: https://github.com/commercialhaskell/stack.git 28 | # commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a 29 | # - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a 30 | # extra-dep: true 31 | # subdirs: 32 | # - auto-update 33 | # - wai 34 | # 35 | # A package marked 'extra-dep: true' will only be built if demanded by a 36 | # non-dependency (i.e. a user package), and its test suites and benchmarks 37 | # will not be run. This is useful for tweaking upstream packages. 38 | packages: 39 | - . 40 | # Dependency packages to be pulled from upstream that are not in the resolver 41 | # (e.g., acme-missiles-0.3) 42 | # extra-deps: [] 43 | 44 | # Override default flag values for local packages and extra-deps 45 | # flags: {} 46 | 47 | # Extra package databases containing global packages 48 | # extra-package-dbs: [] 49 | 50 | # Control whether we use the GHC we find on the path 51 | # system-ghc: true 52 | # 53 | # Require a specific version of stack, using version ranges 54 | # require-stack-version: -any # Default 55 | # require-stack-version: ">=1.6" 56 | # 57 | # Override the architecture used by stack, especially useful on Windows 58 | # arch: i386 59 | # arch: x86_64 60 | # 61 | # Extra directories used by stack for building 62 | # extra-include-dirs: [/path/to/dir] 63 | # extra-lib-dirs: [/path/to/dir] 64 | # 65 | # Allow a newer minor version of GHC than the snapshot specifies 66 | # compiler-check: newer-minor -------------------------------------------------------------------------------- /hedgehog-checkers-lens/tests/tests.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE TemplateHaskell #-} 3 | 4 | module Main where 5 | 6 | import Data.Functor (void) 7 | 8 | import Control.Lens 9 | 10 | import Hedgehog 11 | import qualified Hedgehog.Gen as Gen 12 | import qualified Hedgehog.Range as Range 13 | 14 | import Hedgehog.Checkers.Ugly.Function.Hack 15 | 16 | import Hedgehog.Checkers.Lens.Properties 17 | 18 | data Foo = 19 | Foo 20 | { _bar :: Int 21 | , _baz :: Int 22 | , _dunno :: String } 23 | deriving (Eq, Show) 24 | 25 | makeLenses ''Foo 26 | 27 | genFoo' :: Gen Int -> Gen String -> Gen Foo 28 | genFoo' gi gs = do 29 | i <- gi 30 | i' <- gi 31 | s <- gs 32 | return (Foo i i' s) 33 | 34 | genFoo :: Gen Foo 35 | genFoo = 36 | let string = Gen.string (Range.linear 0 100) Gen.ascii 37 | int = Gen.int (Range.linear 0 100) 38 | in genFoo' int string 39 | 40 | allLensLawsFoo :: Property 41 | allLensLawsFoo = property $ do 42 | let string = Gen.string (Range.linear 0 100) Gen.ascii 43 | int = Gen.int (Range.linear 0 100) 44 | isLens bar int genFoo (ordFuncWtf' int int) 45 | isLens baz int genFoo (ordFuncWtf' int int) 46 | isLens dunno string genFoo (ordFuncWtf' string string) 47 | 48 | main :: IO () 49 | main = do 50 | void $ 51 | checkParallel $ 52 | Group "Control.Lens.Lens" [ ("all laws applied to foo's lenses" 53 | , allLensLawsFoo) 54 | ] 55 | -------------------------------------------------------------------------------- /hedgehog-checkers/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright Author name here (c) 2017 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Author name here nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -------------------------------------------------------------------------------- /hedgehog-checkers/Makefile: -------------------------------------------------------------------------------- 1 | package = hedgehog-checkers 2 | 3 | stack_yaml = STACK_YAML="../stack.yaml" 4 | stack = $(stack_yaml) stack 5 | 6 | build: 7 | $(stack) build $(package) 8 | 9 | build-dirty: 10 | $(stack) build --ghc-options=-fforce-recomp $(package) 11 | 12 | run: 13 | $(stack) build --fast && $(stack) exec -- $(package) 14 | 15 | install: 16 | $(stack) install 17 | 18 | ghci: 19 | $(stack) ghci $(package):lib 20 | 21 | test: 22 | $(stack) test $(package) 23 | 24 | test-ghci: 25 | $(stack) ghci $(package):test:$(package)-tests 26 | 27 | bench: 28 | $(stack) bench $(package) 29 | 30 | ghcid: 31 | $(stack) exec -- ghcid -c "stack ghci $(package):lib --test --ghci-options='-fobject-code -fno-warn-unused-do-bind' --main-is $(package):$(package)" 32 | 33 | dev-deps: 34 | stack install ghcid 35 | 36 | .PHONY : build build-dirty run install ghci test test-ghci ghcid dev-deps 37 | 38 | -------------------------------------------------------------------------------- /hedgehog-checkers/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /hedgehog-checkers/hedgehog-checkers.cabal: -------------------------------------------------------------------------------- 1 | -- This file has been generated from package.yaml by hpack version 0.28.2. 2 | -- 3 | -- see: https://github.com/sol/hpack 4 | -- 5 | -- hash: d9473e2b2b2334566749ed381599128f7177c37c73091ebc176381ee6124fcf8 6 | 7 | name: hedgehog-checkers 8 | version: 0.1.0.0 9 | category: Web 10 | homepage: https://github.com/bitemyapp/hedgehog-checkers#readme 11 | author: Chris Allen 12 | maintainer: cma@bitemyapp.com 13 | copyright: 2017, Chris Allen 14 | license: BSD3 15 | license-file: LICENSE 16 | build-type: Simple 17 | cabal-version: >= 1.10 18 | description: hedgehog-checkers wraps up the expected properties associated with various standard type classes as Hedgehog properties. 19 | 20 | library 21 | hs-source-dirs: 22 | src 23 | build-depends: 24 | base >=4.7 && <5 25 | , containers >=0.4 && <0.6 26 | , hedgehog >=0.5 && <0.6 27 | , semigroupoids >=5 && <6 28 | , semigroups >=0.9 && <1 29 | exposed-modules: 30 | Hedgehog.Checkers 31 | Hedgehog.Checkers.Ugly.Function.Hack 32 | other-modules: 33 | Hedgehog.Checkers.Classes 34 | Hedgehog.Checkers.Properties 35 | Paths_hedgehog_checkers 36 | default-language: Haskell2010 37 | 38 | test-suite tests 39 | type: exitcode-stdio-1.0 40 | main-is: tests.hs 41 | hs-source-dirs: 42 | tests 43 | ghc-options: -threaded -Wall -rtsopts -with-rtsopts=-N 44 | build-depends: 45 | base >=4.7 && <5 46 | , either >=5 && <6 47 | , hedgehog >=0.5 && <0.6 48 | , hedgehog-checkers 49 | other-modules: 50 | Paths_hedgehog_checkers 51 | default-language: Haskell2010 52 | -------------------------------------------------------------------------------- /hedgehog-checkers/package.yaml: -------------------------------------------------------------------------------- 1 | name: hedgehog-checkers 2 | version: 0.1.0.1 3 | homepage: https://github.com/bitemyapp/hedgehog-checkers#readme 4 | license: BSD3 5 | author: Chris Allen 6 | maintainer: cma@bitemyapp.com 7 | copyright: 2017, Chris Allen 8 | category: Web 9 | description: hedgehog-checkers wraps up the expected properties associated with various standard type classes as Hedgehog properties. 10 | 11 | dependencies: 12 | - base >= 4.7 && < 5 13 | - hedgehog >= 0.5 && < 0.6 14 | 15 | library: 16 | source-dirs: src 17 | dependencies: 18 | - containers >= 0.4 && < 0.6 19 | - semigroups >= 0.9 && < 1 20 | - semigroupoids >= 5 && < 6 21 | exposed-modules: 22 | - Hedgehog.Checkers 23 | - Hedgehog.Checkers.Ugly.Function.Hack 24 | 25 | tests: 26 | tests: 27 | main: tests.hs 28 | source-dirs: tests 29 | dependencies: 30 | - hedgehog-checkers 31 | - either >= 5 && < 6 32 | ghc-options: 33 | - -threaded 34 | - -Wall 35 | - -rtsopts 36 | - -with-rtsopts=-N 37 | -------------------------------------------------------------------------------- /hedgehog-checkers/src/Hedgehog/Checkers.hs: -------------------------------------------------------------------------------- 1 | module Hedgehog.Checkers 2 | ( 3 | -- * Classes 4 | ord 5 | , alt 6 | , alternative 7 | , alternativeAltAgreement 8 | , bifunctor 9 | , functor 10 | , semigroup 11 | , monoid 12 | , apply 13 | , applicative 14 | , applicativeApplyAgreement 15 | 16 | -- * Laws 17 | , identity 18 | , leftIdentity 19 | , rightIdentity 20 | , associativity 21 | , commutativity 22 | , reflexive 23 | , transitive 24 | , symmetric 25 | , antiSymmetric 26 | ) where 27 | 28 | import Hedgehog.Checkers.Classes 29 | import Hedgehog.Checkers.Properties 30 | -------------------------------------------------------------------------------- /hedgehog-checkers/src/Hedgehog/Checkers/Classes.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables #-} 2 | {-# LANGUAGE RankNTypes #-} 3 | 4 | module Hedgehog.Checkers.Classes 5 | ( 6 | -- | Classes 7 | ord 8 | , alt 9 | , alternative 10 | , alternativeAltAgreement 11 | , bifunctor 12 | , functor 13 | , semigroup 14 | , monoid 15 | , apply 16 | , applicative 17 | , applicativeApplyAgreement 18 | ) where 19 | 20 | import Control.Applicative 21 | import Data.Bifunctor 22 | import Data.Functor.Alt 23 | import Data.Semigroup 24 | 25 | import Hedgehog 26 | import qualified Hedgehog.Gen as Gen 27 | import qualified Hedgehog.Range as Range 28 | 29 | import Hedgehog.Checkers.Properties 30 | import Hedgehog.Checkers.Ugly.Function.Hack 31 | 32 | -- | Total ordering, genf (a -> Gen a) should 33 | -- always return a value equal to or higher 34 | -- than its input. 35 | ord :: forall a. (Eq a, Ord a, Show a) 36 | => Gen a -> (a -> Gen a) -> PropertyT IO () 37 | ord gena genf = do 38 | reflexive rel gena 39 | transitive rel gena genf 40 | antiSymmetric rel gena genf 41 | where 42 | rel = (<=) 43 | 44 | -- | is associative: (a b) c = a (b c) 45 | -- <$> left-distributes over : f <$> (a b) = (f <$> a) (f <$> b) 46 | alt :: ( Alt f 47 | , Eq (f a) 48 | , Show (f a) 49 | ) 50 | => Gen (f a) -> PropertyT IO () 51 | alt gen = do 52 | associativity () gen 53 | -- f <$> (a b) = (f <$> a) (f <$> b) 54 | 55 | -- | Alternative instances should respect identity 56 | -- (left and right) and associativity for (<|>) 57 | -- empty <|> x = x 58 | -- x <|> empty = x 59 | -- 60 | -- a <|> (b <|> c) = (a <|> b) <|> c 61 | alternative :: ( Alternative f 62 | , Eq (f a) 63 | , Show (f a) 64 | ) 65 | => Gen (f a) -> PropertyT IO () 66 | alternative gen = do 67 | identity (<|>) empty gen 68 | associativity (<|>) gen 69 | 70 | alternativeAltAgreement :: ( Alt f 71 | , Alternative f 72 | , Eq (f a) 73 | , Show (f a) 74 | ) 75 | => Gen (f a) -> PropertyT IO () 76 | alternativeAltAgreement gen = do 77 | fa <- forAll gen 78 | fb <- forAll gen 79 | (fa fb) === (fa <|> fb) 80 | 81 | -- fmap (f . g) == fmap f . fmap g 82 | -- ??? inferrable from: fmap id = id 83 | functor :: ( Functor f 84 | , Eq (f a) 85 | , Show (f a) 86 | ) 87 | => Gen (f a) -> PropertyT IO () 88 | functor gen = do 89 | functorIdentity 90 | where functorIdentity = do 91 | fa <- forAll gen 92 | fmap id fa === id fa 93 | 94 | -- bimap id id ≡ id 95 | -- first id ≡ id 96 | -- second id ≡ id 97 | -- bimap f g ≡ first f . second g 98 | bifunctor :: -- forall f a b . 99 | ( Bifunctor f 100 | , Eq (f a b) 101 | , Eq (f c c) 102 | , Ord a 103 | , Ord b 104 | , Show (f a b) 105 | , Show (f c c) 106 | ) 107 | => Gen (f a b) 108 | -> Gen a 109 | -> Gen b 110 | -> Gen c 111 | -> PropertyT IO () 112 | bifunctor gen gena genb genc = do 113 | bimapIdentity 114 | firstIdentity 115 | secondIdentity 116 | bimapFirstSecondDistribute 117 | where bimapIdentity = do 118 | fab <- forAll gen 119 | bimap id id fab === id fab 120 | firstIdentity = do 121 | fab <- forAll gen 122 | first id fab === id fab 123 | secondIdentity = do 124 | fab <- forAll gen 125 | second id fab === id fab 126 | bimapFirstSecondDistribute = do 127 | fab <- forAll gen 128 | f <- ordFuncWtf gena genc 129 | g <- ordFuncWtf genb genc 130 | bimap f g fab === (first f . second g) fab 131 | 132 | semigroup :: ( Semigroup a 133 | , Eq a 134 | , Show a 135 | ) 136 | => Gen a 137 | -> PropertyT IO () 138 | semigroup gen = do 139 | associativity (<>) gen 140 | 141 | monoid :: ( Monoid a 142 | , Semigroup a 143 | , Eq a 144 | , Show a 145 | ) 146 | => Gen a 147 | -> PropertyT IO () 148 | monoid gen = do 149 | semigroup gen 150 | identity mappend mempty gen 151 | associativity mappend gen 152 | monoidSemigroupSame 153 | where monoidSemigroupSame = do 154 | a <- forAll gen 155 | b <- forAll gen 156 | mappend a b === a <> b 157 | 158 | apply :: forall f a b c 159 | . ( Apply f 160 | , Eq (f a) 161 | , Eq (f b) 162 | , Eq (f c) 163 | , Ord a 164 | , Ord b 165 | , Show a 166 | , Show b 167 | , Show c 168 | , Show (f a) 169 | , Show (f b) 170 | , Show (f c) 171 | ) 172 | => Gen (f a) 173 | -> Gen a 174 | -> Gen b 175 | -> Gen c 176 | -> PropertyT IO () 177 | apply gen gena genb genc = do 178 | applyComposition 179 | applyRight 180 | applyLeft 181 | where applyComposition = do 182 | fa <- forAll gen 183 | fbc <- liftedFunctionWtf gen genb genc 184 | fab <- liftedFunctionWtf gen gena genb 185 | ((.) <$> fbc <.> fab <.> fa) === (fbc <.> (fab <.> fa)) 186 | applyRight = do 187 | fa <- forAll gen 188 | fbc <- liftedFunctionWtf gen genb genc 189 | ab <- ordFuncWtf gena genb 190 | (fbc <.> (ab <$> fa)) === ((. ab) <$> fbc <.> fa) 191 | applyLeft = do 192 | fa <- forAll gen 193 | fab <- liftedFunctionWtf gen gena genb 194 | bc <- ordFuncWtf genb genc 195 | (bc <$> (fab <.> fa)) === ((bc .) <$> fab <.> fa) 196 | 197 | applicative :: forall f a b c 198 | . ( Applicative f 199 | , Eq (f a) 200 | , Eq (f b) 201 | , Eq (f c) 202 | , Ord a 203 | , Ord b 204 | , Show a 205 | , Show (f a) 206 | , Show (f b) 207 | , Show (f c) 208 | ) 209 | => Gen (f a) 210 | -> Gen a 211 | -> Gen b 212 | -> Gen c 213 | -> PropertyT IO () 214 | applicative gen gena genb genc = do 215 | applicativeIdentity 216 | applicativeComposition 217 | applicativeHomomorphism 218 | applicativeInterchange 219 | applicativeFunctor 220 | where applicativeIdentity = do 221 | fa <- forAll gen 222 | (pure id <*> fa) === fa 223 | 224 | applicativeComposition = do 225 | fa <- forAll gen 226 | fbc <- liftedFunctionWtf gen genb genc 227 | fab <- liftedFunctionWtf gen gena genb 228 | (pure (.) <*> fbc <*> fab <*> fa) === (fbc <*> (fab <*> fa)) 229 | 230 | applicativeHomomorphism = do 231 | a <- forAll gena 232 | f <- ordFuncWtf gena genb 233 | let p :: x -> f x 234 | p = pure 235 | (p f <*> p a) === p (f a) 236 | 237 | applicativeInterchange = do 238 | a <- forAll gena 239 | fab <- liftedFunctionWtf gen gena genb 240 | (fab <*> pure a) === (pure ($ a) <*> fab) 241 | 242 | applicativeFunctor = do 243 | fa <- forAll gen 244 | f <- ordFuncWtf gena genb 245 | fmap f fa === (pure f <*> fa) 246 | 247 | applicativeApplyAgreement :: ( Monad m 248 | , Apply f 249 | , Applicative f 250 | , Show b 251 | , Show (f a) 252 | , Show (f b) 253 | , Eq (f b) 254 | , Ord a 255 | ) 256 | => Gen (f a) -> Gen a -> Gen b -> PropertyT m () 257 | applicativeApplyAgreement gen gena genb = do 258 | fa <- forAll gen 259 | fab <- liftedFunctionWtf gen gena genb 260 | (fab <.> fa) === (fab <*> fa) 261 | 262 | ---- Done 263 | -- (Semigroup e, Monoid e) => Alternative (Validation e) 264 | -- Alt (Validation e) 265 | -- Functor (Validation e) 266 | -- Bifunctor Validation 267 | -- Semigroup e => Semigroup (Validation e a) 268 | -- Monoid e => Monoid (Validation e a)Source 269 | -- Semigroup e => Applicative (Validation e) 270 | -- (Ord a, Ord e) => Ord (Validation e a) 271 | 272 | ---- To be done 273 | -- Traversable (Validation e) 274 | -- Bitraversable Validation 275 | -- https://github.com/bitemyapp/hedgehog-checkers/issues/9 276 | 277 | -- (Eq a, Eq e) => Eq (Validation e a) 278 | -- (Show a, Show e) => Show (Validation e a) 279 | -------------------------------------------------------------------------------- /hedgehog-checkers/src/Hedgehog/Checkers/Properties.hs: -------------------------------------------------------------------------------- 1 | 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | 4 | module Hedgehog.Checkers.Properties 5 | ( 6 | -- | Laws 7 | identity 8 | , leftIdentity 9 | , rightIdentity 10 | , associativity 11 | , commutativity 12 | , reflexive 13 | , transitive 14 | , symmetric 15 | , antiSymmetric 16 | ) where 17 | 18 | import Hedgehog 19 | 20 | leftIdentity :: (Eq a, Show a) 21 | => (a -> a -> a) 22 | -> a 23 | -> Gen a 24 | -> PropertyT IO () 25 | leftIdentity f i gen = do 26 | x <- forAll gen 27 | f i x === x 28 | 29 | rightIdentity :: (Eq a, Show a) 30 | => (a -> a -> a) 31 | -> a 32 | -> Gen a 33 | -> PropertyT IO () 34 | rightIdentity f i gen = do 35 | x <- forAll gen 36 | f x i === x 37 | 38 | identity :: (Eq a, Show a) 39 | => (a -> a -> a) 40 | -> a 41 | -> Gen a 42 | -> PropertyT IO () 43 | identity f i gen = do 44 | leftIdentity f i gen 45 | rightIdentity f i gen 46 | 47 | associativity :: (Eq a, Show a) 48 | => (a -> a -> a) 49 | -> Gen a 50 | -> PropertyT IO () 51 | associativity f gen = do 52 | x <- forAll gen 53 | y <- forAll gen 54 | z <- forAll gen 55 | f x (f y z) === f (f x y) z 56 | 57 | commutativity :: (Eq b, Show a, Show b) 58 | => (a -> a -> b) 59 | -> Gen a 60 | -> PropertyT IO () 61 | commutativity f gena = do 62 | a <- forAll gena 63 | a' <- forAll gena 64 | f a a' === f a' a 65 | 66 | reflexive :: (Show a) 67 | => (a -> a -> Bool) 68 | -> Gen a 69 | -> PropertyT IO () 70 | reflexive rel gena = do 71 | a <- forAll gena 72 | assert $ rel a a 73 | 74 | transitive :: (Show a) 75 | => (a -> a -> Bool) 76 | -> Gen a 77 | -> (a -> Gen a) 78 | -> PropertyT IO () 79 | transitive rel gena genf = do 80 | a <- forAll gena 81 | b <- forAll (genf a) 82 | c <- forAll (genf b) 83 | ((rel a b) && (rel b c)) === (rel a c) 84 | 85 | symmetric :: (Show a) 86 | => (a -> a -> Bool) 87 | -> Gen a 88 | -> (a -> Gen a) 89 | -> PropertyT IO () 90 | symmetric rel gena genf = do 91 | a <- forAll gena 92 | b <- forAll (genf a) 93 | (rel a b) === (rel b a) 94 | 95 | antiSymmetric :: (Eq a, Show a) 96 | => (a -> a -> Bool) 97 | -> Gen a 98 | -> (a -> Gen a) 99 | -> PropertyT IO () 100 | antiSymmetric rel gena genf = do 101 | a <- forAll gena 102 | b <- forAll (genf a) 103 | ((rel a b) && (rel b a)) === (a == b) 104 | -------------------------------------------------------------------------------- /hedgehog-checkers/src/Hedgehog/Checkers/Ugly/Function/Hack.hs: -------------------------------------------------------------------------------- 1 | module Hedgehog.Checkers.Ugly.Function.Hack where 2 | 3 | import Data.Map (Map) 4 | import qualified Data.Map as Map 5 | 6 | import Hedgehog 7 | import qualified Hedgehog.Gen as Gen 8 | import qualified Hedgehog.Range as Range 9 | 10 | ---------- vvvvv CANCER PLEASE IGNORE vvvvv ----------------------------- 11 | 12 | fromMap :: Ord k => v -> Map k v -> k -> v 13 | fromMap defaultValue kvs k = 14 | case Map.lookup k kvs of 15 | Nothing -> 16 | defaultValue 17 | Just value -> 18 | value 19 | 20 | ordFuncWtf'' :: Ord a => Range Int -> Gen a -> Gen b -> Gen (a -> b) 21 | ordFuncWtf'' range gen gen' = do 22 | defaultV <- gen' 23 | let tupGen = (,) <$> gen <*> gen' 24 | map <- Gen.map range tupGen 25 | return $ fromMap defaultV map 26 | 27 | ordFuncWtf' :: Ord a => Gen a -> Gen b -> Gen (a -> b) 28 | ordFuncWtf' = ordFuncWtf'' (Range.linear 0 1000) 29 | 30 | funcForAllWtf :: Monad m => Gen a -> PropertyT m a 31 | funcForAllWtf g = do 32 | let funcShow _ = "" 33 | forAllWith funcShow $ g 34 | 35 | ordFuncWtf :: (Ord a, Monad m) => Gen a -> Gen b -> PropertyT m (a -> b) 36 | ordFuncWtf gena genb = do 37 | -- let funcShow _ = "" 38 | -- forAllWith funcShow $ ordFuncWtf' gena genb 39 | funcForAllWtf $ ordFuncWtf' gena genb 40 | 41 | liftedFunctionWtf :: (Functor f, Show (f z), Ord a, Monad m) 42 | => Gen (f z) -> Gen a -> Gen b -> PropertyT m (f (a -> b)) 43 | liftedFunctionWtf gen gena genb = do 44 | fab' <- ordFuncWtf gena genb 45 | fmap (const fab') <$> forAll gen 46 | 47 | ---------- ^^^^^ CANCER PLEASE IGNORE ^^^^^ ----------------------------- 48 | -------------------------------------------------------------------------------- /hedgehog-checkers/tests/tests.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Main where 4 | 5 | import Control.Monad 6 | import Data.Either.Validation 7 | import Data.Monoid (Sum(..)) 8 | import System.Exit (exitFailure) 9 | 10 | import Hedgehog 11 | import qualified Hedgehog.Gen as Gen 12 | import qualified Hedgehog.Range as Range 13 | 14 | import Hedgehog.Checkers 15 | 16 | genValidation :: Gen a -> Gen b -> Gen (Validation a b) 17 | genValidation ga gb = do 18 | a <- ga 19 | b <- gb 20 | Gen.choice [return $ Failure a, return $ Success b] 21 | 22 | validationAlternative :: Property 23 | validationAlternative = property $ do 24 | let genSumInt = Sum <$> Gen.int (Range.linear 0 maxBound) 25 | genVal = genValidation genSumInt genSumInt 26 | alternative genVal 27 | 28 | genInt :: Gen Int 29 | genInt = Gen.int (Range.linear 0 maxBound) 30 | 31 | genSum :: Gen (Sum Int) 32 | genSum = Sum <$> genInt 33 | 34 | genEither' :: Gen a -> Gen b -> Gen (Either a b) 35 | genEither' ga gb = do 36 | a <- ga 37 | b <- gb 38 | Gen.choice [return $ Left a, return $ Right b] 39 | 40 | genEither :: Gen (Either Int Int) 41 | genEither = genEither' genInt genInt 42 | 43 | eitherAlt :: Property 44 | eitherAlt = property $ do 45 | alt genEither 46 | 47 | eitherBifunctor :: Property 48 | eitherBifunctor = property $ do 49 | bifunctor genEither genInt genInt genInt 50 | 51 | eitherFunctor :: Property 52 | eitherFunctor = property $ do 53 | functor genEither 54 | 55 | eitherApply :: Property 56 | eitherApply = property $ do 57 | apply genEither genInt genInt genInt 58 | 59 | eitherApplicative :: Property 60 | eitherApplicative = property $ do 61 | applicative genEither genInt genInt genInt 62 | 63 | eitherSemigroup :: Property 64 | eitherSemigroup = property $ do 65 | semigroup genEither 66 | 67 | genMaybe' :: Gen a -> Gen (Maybe a) 68 | genMaybe' ga = 69 | -- I need to bias this to Just 70 | Gen.choice [return Nothing, Just <$> ga] 71 | 72 | genMaybe :: Gen (Maybe (Sum Int)) 73 | genMaybe = genMaybe' genSum 74 | 75 | maybeMonoid :: Property 76 | maybeMonoid = property $ do 77 | monoid genMaybe 78 | 79 | maybeAlt :: Property 80 | maybeAlt = property $ alt genMaybe 81 | 82 | maybeAlternative :: Property 83 | maybeAlternative = property $ alternative genMaybe 84 | 85 | maybeAlternativeAlt :: Property 86 | maybeAlternativeAlt = property $ alternativeAltAgreement genMaybe 87 | 88 | maybeApply :: Property 89 | maybeApply = property $ 90 | apply genMaybe genSum genSum genSum 91 | 92 | maybeApplicative :: Property 93 | maybeApplicative = property $ 94 | applicative genMaybe genSum genSum genSum 95 | 96 | maybeApplicativeApply :: Property 97 | maybeApplicativeApply = property $ 98 | applicativeApplyAgreement genMaybe genSum genSum 99 | 100 | intOrd :: Property 101 | intOrd = property $ 102 | ord genInt varyGenInt 103 | where varyGenInt i = 104 | Gen.int (Range.linear i maxBound) 105 | 106 | main :: IO () 107 | main = do 108 | e <- 109 | checkParallel $ 110 | Group "Data.Either" [ ("Alt", eitherAlt) 111 | , ("Bifunctor", eitherBifunctor) 112 | , ("Functor", eitherFunctor) 113 | , ("Semigroup", eitherSemigroup) 114 | , ("Apply", eitherApply) 115 | , ("Applicative", eitherApplicative) 116 | ] 117 | m <- 118 | checkParallel $ 119 | Group "Data.Maybe" [ ("Monoid", maybeMonoid) 120 | , ("Alt", maybeAlt) 121 | , ("Alternative", maybeAlternative) 122 | , ("AlternativeAlt", maybeAlternativeAlt) 123 | , ("Apply", maybeApply) 124 | , ("Applicative", maybeApplicative) 125 | , ("ApplicativeApply", maybeApplicativeApply) 126 | ] 127 | o <- 128 | checkParallel $ 129 | Group "Ord" [ ("Int", intOrd) 130 | ] 131 | unless (and [e,m,o]) exitFailure 132 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-11.5 2 | 3 | packages: 4 | - hedgehog-checkers 5 | - hedgehog-checkers-lens 6 | --------------------------------------------------------------------------------