├── .envrc ├── .gitignore ├── .travis.yml ├── ChangeLog.md ├── LICENCE ├── README.md ├── default.nix ├── example └── Example.hs ├── hedgehog-fn.cabal ├── hedgehog-fn.nix ├── shell.nix └── src └── Hedgehog ├── Function.hs └── Function └── Internal.hs /.envrc: -------------------------------------------------------------------------------- 1 | # content of `.envrc` file: 2 | eval "$(lorri direnv)" -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | 2 | dist/ 3 | dist-newstyle/ 4 | result 5 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | # This Travis job script has been generated by a script via 2 | # 3 | # haskell-ci 'hedgehog-fn.cabal' '-o' '.travis.yml' 4 | # 5 | # For more information, see https://github.com/haskell-CI/haskell-ci 6 | # 7 | # version: 0.3.20190313 8 | # 9 | language: c 10 | dist: xenial 11 | 12 | git: 13 | submodules: false # whether to recursively clone submodules 14 | 15 | cache: 16 | directories: 17 | - $HOME/.cabal/packages 18 | - $HOME/.cabal/store 19 | 20 | before_cache: 21 | - rm -fv $CABALHOME/packages/hackage.haskell.org/build-reports.log 22 | # remove files that are regenerated by 'cabal update' 23 | - rm -fv $CABALHOME/packages/hackage.haskell.org/00-index.* 24 | - rm -fv $CABALHOME/packages/hackage.haskell.org/*.json 25 | - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.cache 26 | - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.tar 27 | - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.tar.idx 28 | 29 | - rm -rfv $CABALHOME/packages/head.hackage 30 | 31 | matrix: 32 | include: 33 | - compiler: "ghc-8.6.4" 34 | addons: {apt: {packages: [ghc-ppa-tools,cabal-install-2.4,ghc-8.6.4], sources: [hvr-ghc]}} 35 | - compiler: "ghc-8.4.4" 36 | addons: {apt: {packages: [ghc-ppa-tools,cabal-install-2.4,ghc-8.4.4], sources: [hvr-ghc]}} 37 | - compiler: "ghc-8.2.2" 38 | addons: {apt: {packages: [ghc-ppa-tools,cabal-install-2.4,ghc-8.2.2], sources: [hvr-ghc]}} 39 | - compiler: "ghc-8.0.2" 40 | addons: {apt: {packages: [ghc-ppa-tools,cabal-install-2.4,ghc-8.0.2], sources: [hvr-ghc]}} 41 | - compiler: "ghc-7.10.3" 42 | addons: {apt: {packages: [ghc-ppa-tools,cabal-install-2.4,ghc-7.10.3], sources: [hvr-ghc]}} 43 | 44 | before_install: 45 | - HC=/opt/ghc/bin/${CC} 46 | - HCPKG=${HC/ghc/ghc-pkg} 47 | - unset CC 48 | - CABAL=/opt/ghc/bin/cabal 49 | - CABALHOME=$HOME/.cabal 50 | - export PATH="$CABALHOME/bin:$PATH" 51 | - ROOTDIR=$(pwd) 52 | - HCNUMVER=$(( $(${HC} --numeric-version|sed -E 's/([0-9]+)\.([0-9]+)\.([0-9]+).*/\1 * 10000 + \2 * 100 + \3/') )) 53 | - echo $HCNUMVER 54 | 55 | install: 56 | - ${CABAL} --version 57 | - echo "$(${HC} --version) [$(${HC} --print-project-git-commit-id 2> /dev/null || echo '?')]" 58 | - TEST=--enable-tests 59 | - BENCH=--enable-benchmarks 60 | - GHCHEAD=${GHCHEAD-false} 61 | - travis_retry ${CABAL} update -v 62 | - sed -i.bak 's/^jobs:/-- jobs:/' $CABALHOME/config 63 | - rm -fv cabal.project cabal.project.local 64 | - grep -Ev -- '^\s*--' $CABALHOME/config | grep -Ev '^\s*$' 65 | - rm -f cabal.project 66 | - touch cabal.project 67 | - "printf 'packages: \".\"\\n' >> cabal.project" 68 | - "printf 'write-ghc-environment-files: always\\n' >> cabal.project" 69 | - touch cabal.project.local 70 | - "for pkg in $($HCPKG list --simple-output); do echo $pkg | sed 's/-[^-]*$//' | grep -vE -- '^(hedgehog-fn)$' | sed 's/^/constraints: /' | sed 's/$/ installed/' >> cabal.project.local; done" 71 | - cat cabal.project || true 72 | - cat cabal.project.local || true 73 | - if [ -f "./configure.ac" ]; then (cd "." && autoreconf -i); fi 74 | - rm -f cabal.project.freeze 75 | - ${CABAL} new-freeze -w ${HC} ${TEST} ${BENCH} --project-file="cabal.project" --dry 76 | - "cat \"cabal.project.freeze\" | sed -E 's/^(constraints: *| *)//' | sed 's/any.//'" 77 | - rm "cabal.project.freeze" 78 | - ${CABAL} new-build -w ${HC} ${TEST} ${BENCH} --project-file="cabal.project" --dep -j2 all 79 | - ${CABAL} new-build -w ${HC} --disable-tests --disable-benchmarks --project-file="cabal.project" --dep -j2 all 80 | - rm -rf .ghc.environment.* "."/dist 81 | - DISTDIR=$(mktemp -d /tmp/dist-test.XXXX) 82 | 83 | # Here starts the actual work to be performed for the package under test; 84 | # any command which exits with a non-zero exit code causes the build to fail. 85 | script: 86 | # test that source-distributions can be generated 87 | - ${CABAL} new-sdist all 88 | - mv dist-newstyle/sdist/*.tar.gz ${DISTDIR}/ 89 | - cd ${DISTDIR} || false 90 | - find . -maxdepth 1 -name '*.tar.gz' -exec tar -xvf '{}' \; 91 | - rm -f cabal.project 92 | - touch cabal.project 93 | - "printf 'packages: \"hedgehog-fn-*/*.cabal\"\\n' >> cabal.project" 94 | - "printf 'write-ghc-environment-files: always\\n' >> cabal.project" 95 | - touch cabal.project.local 96 | - "for pkg in $($HCPKG list --simple-output); do echo $pkg | sed 's/-[^-]*$//' | grep -vE -- '^(hedgehog-fn)$' | sed 's/^/constraints: /' | sed 's/$/ installed/' >> cabal.project.local; done" 97 | - cat cabal.project || true 98 | - cat cabal.project.local || true 99 | # this builds all libraries and executables (without tests/benchmarks) 100 | - ${CABAL} new-build -w ${HC} --disable-tests --disable-benchmarks all 101 | 102 | # build & run tests, build benchmarks 103 | - ${CABAL} new-build -w ${HC} ${TEST} ${BENCH} all 104 | 105 | # cabal check 106 | - (cd hedgehog-fn-* && ${CABAL} check) 107 | 108 | # haddock 109 | - ${CABAL} new-haddock -w ${HC} ${TEST} ${BENCH} all 110 | 111 | # Build without installed constraints for packages in global-db 112 | - rm -f cabal.project.local; ${CABAL} new-build -w ${HC} --disable-tests --disable-benchmarks all 113 | 114 | # REGENDATA ["hedgehog-fn.cabal","-o",".travis.yml"] 115 | # EOF 116 | -------------------------------------------------------------------------------- /ChangeLog.md: -------------------------------------------------------------------------------- 1 | 1.0 - 2019-05-17 2 | 3 | * Drop support for GHC < 8 4 | * Upgrade to hedgehog-1.0 5 | 6 | 0.6 7 | 8 | * hedgehog-0.6 compatibility 9 | 10 | 0.5 11 | 12 | * Initial release 13 | -------------------------------------------------------------------------------- /LICENCE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2017, Commonwealth Scientific and Industrial Research Organisation 2 | (CSIRO) ABN 41 687 119 230. 3 | 4 | All rights reserved. 5 | 6 | Redistribution and use in source and binary forms, with or without 7 | modification, are permitted provided that the following conditions are met: 8 | 9 | * Redistributions of source code must retain the above copyright 10 | notice, this list of conditions and the following disclaimer. 11 | 12 | * Redistributions in binary form must reproduce the above 13 | copyright notice, this list of conditions and the following 14 | disclaimer in the documentation and/or other materials provided 15 | with the distribution. 16 | 17 | * Neither the name of Data61 nor the names of other 18 | contributors may be used to endorse or promote products derived 19 | from this software without specific prior written permission. 20 | 21 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 22 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 23 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 24 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 25 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 26 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 27 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 28 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 29 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 30 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 31 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 32 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # hedgehog-fn 2 | 3 | Function generation for Hedgehog 4 | 5 | ![CSIRO's Data61 Logo](https://raw.githubusercontent.com/qfpl/assets/master/data61-transparent-bg.png) 6 | 7 | ## Contribution 8 | 9 | Feel free to file an issue or pull request on Github, or contact us at: 10 | * IRC - #qfpl on Freenode 11 | * Email - 12 | -------------------------------------------------------------------------------- /default.nix: -------------------------------------------------------------------------------- 1 | { nixpkgs ? import {}, compiler ? "ghc822" }: 2 | 3 | let 4 | 5 | inherit (nixpkgs) pkgs; 6 | 7 | f = import ./hedgehog-fn.nix; 8 | 9 | haskellPackages = if compiler == "default" 10 | then pkgs.haskellPackages 11 | else pkgs.haskell.packages.${compiler}; 12 | 13 | drv = haskellPackages.callPackage f {}; 14 | 15 | in 16 | 17 | drv 18 | -------------------------------------------------------------------------------- /example/Example.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RankNTypes #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | {-# LANGUAGE TemplateHaskell #-} 4 | {-# LANGUAGE TypeApplications #-} 5 | 6 | module Main where 7 | 8 | import Hedgehog 9 | import qualified Hedgehog.Gen as Gen 10 | import qualified Hedgehog.Range as Range 11 | import Hedgehog.Function 12 | 13 | funIdempotent 14 | :: forall m a 15 | . (Monad m, Arg a, Vary a, Eq a, Show a) 16 | => Gen a 17 | -> PropertyT m () 18 | funIdempotent genA = do 19 | a <- forAll genA 20 | f <- forAllFn $ fn @a genA 21 | f a === f (f a) 22 | 23 | prop_unit_funIdempotent :: Property 24 | prop_unit_funIdempotent = 25 | property $ 26 | funIdempotent $ Gen.choice [Right <$> Gen.bool :: Gen (Either () Bool)] 27 | 28 | funCongEquality 29 | :: forall m a 30 | . (Monad m, Arg a, Vary a, Eq a, Show a) 31 | => Gen a 32 | -> Gen a 33 | -> PropertyT m () 34 | funCongEquality genA genB = do 35 | a <- forAll genA 36 | b <- forAll genB 37 | f <- forAllFn $ fn @a genA 38 | if a == b 39 | then f a === f b 40 | else pure () 41 | 42 | prop_funCongEquality :: Property 43 | prop_funCongEquality = 44 | property $ 45 | funCongEquality (Gen.int (Range.linear 1 10)) (Gen.int (Range.linear 1 10)) 46 | 47 | -- | map (f . g) xs = map f (map g xs) 48 | mapCompose 49 | :: forall f a b c 50 | . ( Functor f 51 | , Show (f a) 52 | , Show a, Arg a, Vary a 53 | , Show b, Arg b, Vary b 54 | , Show c 55 | , Eq (f c) 56 | , Show (f c) 57 | ) 58 | => (forall x. Gen x -> Gen (f x)) 59 | -> Gen a 60 | -> Gen b 61 | -> Gen c 62 | -> Property 63 | mapCompose genF genA genB genC = 64 | property $ do 65 | g <- forAllFn $ fn @a genB 66 | f <- forAllFn $ fn @b genC 67 | xs <- forAll $ genF genA 68 | fmap (f . g) xs === fmap f (fmap g xs) 69 | 70 | prop_map_list :: Property 71 | prop_map_list = 72 | mapCompose 73 | (Gen.list (Range.constant 0 100)) 74 | Gen.bool 75 | Gen.bool 76 | Gen.bool 77 | 78 | main :: IO Bool 79 | main = checkParallel $$discover 80 | -------------------------------------------------------------------------------- /hedgehog-fn.cabal: -------------------------------------------------------------------------------- 1 | -- Initial hedgehog-fn.cabal generated by cabal init. For further documentation, 2 | -- see http://haskell.org/cabal/users-guide/ 3 | 4 | name: hedgehog-fn 5 | version: 1.0 6 | synopsis: Function generation for `hedgehog` 7 | description: Generating shrinkable, showable functions with `hedgehog`. See 8 | `Hedgehog.Function` for example usages. 9 | license: BSD3 10 | -- Must be spelled with a 'C' for nix 11 | license-file: LICENCE 12 | author: Isaac Elliott 13 | maintainer: Queensland Functional Programming Lab 14 | homepage: https://github.com/qfpl/hedgehog-fn 15 | bug-reports: https://github.com/qfpl/hedgehog-fn/issues 16 | category: Testing 17 | build-type: Simple 18 | cabal-version: >=1.10 19 | extra-source-files: ChangeLog.md 20 | tested-with: GHC==8.0.2, GHC==8.2.2, GHC==8.4.3, GHC==8.6.5 21 | 22 | source-repository head 23 | type: git 24 | location: git@github.com:qfpl/hedgehog-fn.git 25 | 26 | flag build-examples 27 | description: Build the example executables 28 | default: False 29 | 30 | library 31 | exposed-modules: Hedgehog.Function 32 | , Hedgehog.Function.Internal 33 | build-depends: base >=4.8 && <5 34 | , contravariant >=1.4 && <1.6 35 | , hedgehog >=1.0 && <1.6 36 | , transformers >=0.4.2 && <0.7 37 | hs-source-dirs: src 38 | default-language: Haskell2010 39 | 40 | executable example 41 | main-is: Example.hs 42 | if flag(build-examples) && impl(ghc>=8.0) 43 | buildable: True 44 | else 45 | buildable: False 46 | hs-source-dirs: example 47 | build-depends: base 48 | , hedgehog 49 | , hedgehog-fn 50 | default-language: Haskell2010 51 | -------------------------------------------------------------------------------- /hedgehog-fn.nix: -------------------------------------------------------------------------------- 1 | { mkDerivation, base, contravariant, hedgehog, stdenv, transformers 2 | }: 3 | mkDerivation { 4 | pname = "hedgehog-fn"; 5 | version = "0.1.0.0"; 6 | src = ./.; 7 | libraryHaskellDepends = [ 8 | base contravariant hedgehog transformers 9 | ]; 10 | license = stdenv.lib.licenses.bsd3; 11 | } 12 | -------------------------------------------------------------------------------- /shell.nix: -------------------------------------------------------------------------------- 1 | { nixpkgs ? import {}, compiler ? "ghc822" }: 2 | 3 | let 4 | 5 | drv = import ./default.nix { inherit nixpkgs compiler; }; 6 | 7 | in 8 | 9 | drv.env 10 | -------------------------------------------------------------------------------- /src/Hedgehog/Function.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- The general procedure for generating functions of type @A -> B@ looks something like this: 3 | -- 4 | -- @ 5 | -- {-\# language DeriveGeneric \#-} 6 | -- {-\# language TypeApplications \#-} 7 | -- 8 | -- import Hedgehog 9 | -- import Hedgehog.Function 10 | -- 11 | -- data A = ... 12 | -- deriving (Generic, ...) 13 | -- 14 | -- instance Arg A 15 | -- instance Vary A 16 | -- 17 | -- genB :: MonadGen m => m B 18 | -- genB = ... 19 | -- 20 | -- prop_test :: Property 21 | -- prop_test = 22 | -- property $ do 23 | -- f <- forAllFn $ fn @A genB 24 | -- ... 25 | -- @ 26 | -- 27 | -- Here's an example of how to use the library to test the "fmap composition" law. 28 | -- 29 | -- @ScopedTypeVariables@ and @TypeApplications@ are recommended for ease of use. @RankNTypes@ 30 | -- is only necessary for this example. 31 | -- 32 | -- @ 33 | -- {-\# language RankNTypes \#-} 34 | -- {-\# language ScopedTypeVariables, TypeApplications \#-} 35 | -- 36 | -- import Hedgehog 37 | -- import Hedgehog.Function 38 | -- import qualified Hedgehog.Gen as Gen 39 | -- import qualified Hedgehog.Range as Range 40 | -- 41 | -- map_compose 42 | -- :: forall f a b c 43 | -- . ( Functor f 44 | -- , Show (f a) 45 | -- , Show a, Arg a, Vary a 46 | -- , Show b, Arg b, Vary b 47 | -- , Show c 48 | -- , Eq (f c) 49 | -- , Show (f c) 50 | -- ) 51 | -- => (forall x. Gen x -> Gen (f x)) 52 | -- -> Gen a 53 | -- -> Gen b 54 | -- -> Gen c 55 | -- -> Property 56 | -- map_compose genF genA genB genC = 57 | -- property $ do 58 | -- g <- forAllFn $ fn \@a genB 59 | -- f <- forAllFn $ fn \@b genC 60 | -- xs <- forAll $ genF genA 61 | -- fmap (f . g) xs === fmap f (fmap g xs) 62 | -- 63 | -- prop_map_list :: Property 64 | -- prop_map_list = 65 | -- map_compose 66 | -- (Gen.list (Range.constant 0 100)) 67 | -- Gen.bool 68 | -- Gen.bool 69 | -- Gen.bool 70 | -- @ 71 | 72 | module Hedgehog.Function 73 | ( module GHC.Generics 74 | , Fn 75 | -- * Generation 76 | , forAllFn 77 | , apply 78 | , fn 79 | , fnWith 80 | -- * Building 81 | , gbuild 82 | , via 83 | , buildIntegral 84 | , Arg(..) 85 | -- * Varying 86 | , module Data.Functor.Contravariant 87 | , module Data.Functor.Contravariant.Divisible 88 | , CoGenT 89 | , CoGen 90 | , gvary 91 | , varyIntegral 92 | , Vary(..) 93 | ) 94 | where 95 | 96 | import GHC.Generics 97 | import Data.Functor.Contravariant 98 | import Data.Functor.Contravariant.Divisible 99 | import Hedgehog.Function.Internal 100 | -------------------------------------------------------------------------------- /src/Hedgehog/Function/Internal.hs: -------------------------------------------------------------------------------- 1 | {-# language GADTs, RankNTypes #-} 2 | {-# language FlexibleContexts, DefaultSignatures #-} 3 | {-# language TypeOperators #-} 4 | {-# language LambdaCase #-} 5 | {-# language EmptyCase #-} 6 | module Hedgehog.Function.Internal where 7 | 8 | import Control.Monad.Trans.Maybe (MaybeT(..)) 9 | import Data.Bifunctor (first) 10 | import Data.Functor.Contravariant (Contravariant(..)) 11 | import Data.Functor.Contravariant.Divisible (Divisible(..), Decidable(..)) 12 | import Data.Functor.Identity (Identity(..)) 13 | import Data.Int (Int8, Int16, Int32, Int64) 14 | import Data.Maybe (fromJust) 15 | import Data.Void (Void, absurd) 16 | import Data.Word (Word8, Word64) 17 | import Hedgehog.Internal.Gen (GenT(..), Gen, runGenT) 18 | import Hedgehog.Internal.Seed (Seed(..)) 19 | import Hedgehog.Internal.Tree (TreeT(..), NodeT(..)) 20 | import Hedgehog.Internal.Property (PropertyT, forAll) 21 | 22 | import GHC.Generics 23 | 24 | import qualified Hedgehog.Internal.Tree as Tree 25 | 26 | infixr 5 :-> 27 | 28 | -- | Shrinkable, showable functions 29 | -- 30 | -- Claessen, K. (2012, September). Shrinking and showing functions:(functional pearl). 31 | -- In ACM SIGPLAN Notices (Vol. 47, No. 12, pp. 73-80). ACM. 32 | data a :-> c where 33 | Unit :: c -> () :-> c 34 | Nil :: a :-> c 35 | Pair :: a :-> b :-> c -> (a, b) :-> c 36 | Sum :: a :-> c -> b :-> c -> Either a b :-> c 37 | Map :: (a -> b) -> (b -> a) -> b :-> c -> a :-> c 38 | 39 | instance Functor ((:->) r) where 40 | fmap f (Unit c) = Unit $ f c 41 | fmap _ Nil = Nil 42 | fmap f (Pair a) = Pair $ fmap (fmap f) a 43 | fmap f (Sum a b) = Sum (fmap f a) (fmap f b) 44 | fmap f (Map a b c) = Map a b (fmap f c) 45 | 46 | -- | Tabulate the function 47 | table :: a :-> c -> [(a, c)] 48 | table (Unit c) = [((), c)] 49 | table Nil = [] 50 | table (Pair f) = do 51 | (a, bc) <- table f 52 | (b, c) <- table bc 53 | pure ((a, b), c) 54 | table (Sum a b) = 55 | [(Left x, c) | (x, c) <- table a] ++ 56 | [(Right x, c) | (x, c) <- table b] 57 | table (Map _ g a) = first g <$> table a 58 | 59 | class GArg a where 60 | gbuild' :: (a x -> c) -> a x :-> c 61 | 62 | -- | Reify a function whose domain has an instance of 'Generic' 63 | gbuild :: (Generic a, GArg (Rep a)) => (a -> c) -> a :-> c 64 | gbuild = gvia from to 65 | 66 | -- | @instance Arg A where@ allows functions which take @A@s to be reified 67 | class Arg a where 68 | build :: (a -> c) -> a :-> c 69 | default build :: (Generic a, GArg (Rep a)) => (a -> c) -> a :-> c 70 | build = gbuild 71 | 72 | variant :: Word64 -> GenT m b -> GenT m b 73 | variant n (GenT f) = GenT $ \sz sd -> f sz (sd { seedValue = seedValue sd + n}) 74 | 75 | variant' :: Word64 -> CoGenT m b -> CoGenT m b 76 | variant' n (CoGenT f) = 77 | CoGenT $ \a -> variant n . f a 78 | 79 | class GVary a where 80 | gvary' :: CoGenT m (a x) 81 | 82 | instance GVary V1 where 83 | gvary' = conquer 84 | 85 | instance GVary U1 where 86 | gvary' = conquer 87 | 88 | instance (GVary a, GVary b) => GVary (a :+: b) where 89 | gvary' = 90 | choose 91 | (\case; L1 a -> Left a; R1 a -> Right a) 92 | (variant' 0 gvary') 93 | (variant' 1 gvary') 94 | 95 | instance (GVary a, GVary b) => GVary (a :*: b) where 96 | gvary' = 97 | divide 98 | (\(a :*: b) -> (a, b)) 99 | (variant' 0 gvary') 100 | (variant' 1 gvary') 101 | 102 | instance GVary c => GVary (M1 a b c) where 103 | gvary' = contramap unM1 gvary' 104 | 105 | instance Vary b => GVary (K1 a b) where 106 | gvary' = contramap unK1 vary 107 | 108 | -- | Build a co-generator for a type which has a 'Generic' instance 109 | gvary :: (Generic a, GVary (Rep a)) => CoGenT m a 110 | gvary = CoGenT $ \a -> applyCoGenT gvary' (from a) 111 | 112 | -- | 'Vary' provides a canonical co-generator for a type. 113 | -- 114 | -- While technically there are many possible co-generators for a given type, we don't get any 115 | -- benefit from caring. 116 | class Vary a where 117 | vary :: CoGenT m a 118 | default vary :: (Generic a, GVary (Rep a)) => CoGenT m a 119 | vary = gvary 120 | 121 | -- | Build a co-generator for an 'Integral' type 122 | varyIntegral :: Integral a => CoGenT m a 123 | varyIntegral = CoGenT $ variant . fromIntegral 124 | 125 | -- | 126 | -- A @'CoGenT' m a@ is used to perturb a @'GenT' m b@ based on the value of the @a@. This way, 127 | -- the generated function will have a varying (but still deterministic) right hand side. 128 | -- 129 | -- Co-generators can be built using 'Divisible' and 'Decidable', but it is recommended to 130 | -- derive 'Generic' and use the default instance of the 'Vary' type class. 131 | -- 132 | -- @'CoGenT' m ~ 'Data.Functor.Contravariabe.Op' ('Data.Monoid.Endo' ('GenT' m b))@ 133 | newtype CoGenT m a = CoGenT { applyCoGenT :: forall b. a -> GenT m b -> GenT m b } 134 | type CoGen = CoGenT Identity 135 | 136 | instance Contravariant (CoGenT m) where 137 | contramap f (CoGenT g) = CoGenT (g . f) 138 | 139 | instance Divisible (CoGenT m) where 140 | divide f (CoGenT gb) (CoGenT gc) = 141 | CoGenT $ \a -> 142 | let (b, c) = f a in gc c . gb b 143 | conquer = CoGenT $ const id 144 | 145 | instance Decidable (CoGenT m) where 146 | choose f (CoGenT gb) (CoGenT gc) = 147 | CoGenT $ \a -> 148 | case f a of 149 | Left b -> gb b . variant 0 150 | Right c -> gc c . variant 1 151 | lose f = CoGenT $ \a -> absurd (f a) 152 | 153 | instance (Show a, Show b) => Show (a :-> b) where 154 | show = show . table 155 | 156 | -- | Evaluate a possibly partial function 157 | apply' :: a :-> b -> a -> Maybe b 158 | apply' (Unit c) () = Just c 159 | apply' Nil _ = Nothing 160 | apply' (Pair f) (a, b) = do 161 | f' <- apply' f a 162 | apply' f' b 163 | apply' (Sum f _) (Left a) = apply' f a 164 | apply' (Sum _ g) (Right a) = apply' g a 165 | apply' (Map f _ g) a = apply' g (f a) 166 | 167 | -- | Evaluate a total function. Unsafe. 168 | unsafeApply :: a :-> b -> a -> b 169 | unsafeApply f = fromJust . apply' f 170 | 171 | -- | The type of randomly-generated functions 172 | {- 173 | The lone 'b' here is important; we need is as a fall-through case so that we 174 | can have finitely-sized showable functions. If we didn't have it, then we'd 175 | never be able to render functions that have an infinitely-sized argument 176 | (like functions on Integers). 177 | -} 178 | data Fn a b = Fn b (a :-> TreeT (MaybeT Identity) b) 179 | 180 | 181 | -- | Extract the root value from a 'TreeT'. Unsafe. 182 | unsafeFromTree :: Functor m => TreeT (MaybeT m) a -> m a 183 | unsafeFromTree = 184 | fmap (maybe (error "empty generator in function") nodeValue) . 185 | runMaybeT . 186 | runTreeT 187 | 188 | instance (Show a, Show b) => Show (Fn a b) where 189 | show (Fn b a) = 190 | "\\case\n" ++ 191 | case table a of 192 | [] -> " _ -> " ++ show b 193 | ta -> showTable ta ++ " _ -> " ++ show b 194 | where 195 | showTable :: (Show a, Show b) => [(a, TreeT (MaybeT Identity) b)] -> String 196 | showTable [] = " \n" 197 | showTable (x : xs) = unlines (showCase <$> x : xs) 198 | where 199 | showCase (lhs, rhs) = 200 | " " ++ show lhs ++ " -> " ++ show (runIdentity $ unsafeFromTree rhs) 201 | 202 | -- | Shrink the function 203 | shrinkFn :: (b -> [b]) -> a :-> b -> [a :-> b] 204 | shrinkFn shr (Unit a) = Unit <$> shr a 205 | shrinkFn _ Nil = [] 206 | shrinkFn shr (Pair f) = 207 | (\case; Nil -> Nil; a -> Pair a) <$> shrinkFn (shrinkFn shr) f 208 | shrinkFn shr (Sum a b) = 209 | fmap (\case; Sum Nil Nil -> Nil; x -> x) $ 210 | [ Sum a Nil | notNil b ] ++ 211 | [ Sum Nil b | notNil a ] ++ 212 | fmap (`Sum` b) (shrinkFn shr a) ++ 213 | fmap (a `Sum`) (shrinkFn shr b) 214 | where 215 | notNil Nil = False 216 | notNil _ = True 217 | shrinkFn shr (Map f g a) = (\case; Nil -> Nil; x -> Map f g x) <$> shrinkFn shr a 218 | 219 | shrinkTree :: Monad m => TreeT (MaybeT m) a -> m [TreeT (MaybeT m) a] 220 | shrinkTree (Tree.TreeT m) = do 221 | a <- runMaybeT m 222 | case a of 223 | Nothing -> pure [] 224 | Just (Tree.NodeT _ cs) -> pure cs 225 | 226 | -- | Evaluate an 'Fn' 227 | apply :: Fn a b -> a -> b 228 | apply (Fn b f) = maybe b (runIdentity . unsafeFromTree) . apply' f 229 | 230 | -- | Generate a function using the user-supplied co-generator 231 | fnWith :: Arg a => CoGen a -> Gen b -> Gen (Fn a b) 232 | fnWith cg gb = 233 | Fn <$> 234 | gb <*> 235 | genFn (\a -> applyCoGenT cg a gb) 236 | where 237 | genFn :: Arg a => (a -> Gen b) -> Gen (a :-> TreeT (MaybeT Identity) b) 238 | genFn g = 239 | GenT $ \sz sd -> 240 | Tree.unfold (shrinkFn $ runIdentity . shrinkTree) . 241 | fmap (runGenT sz sd) $ build g 242 | 243 | -- | Generate a function 244 | fn :: (Arg a, Vary a) => Gen b -> Gen (Fn a b) 245 | fn = fnWith vary 246 | 247 | -- | Run the function generator to retrieve a function 248 | forAllFn :: (Show a, Show b, Monad m) => Gen (Fn a b) -> PropertyT m (a -> b) 249 | forAllFn = fmap apply . forAll 250 | 251 | instance Vary () 252 | instance (Vary a, Vary b) => Vary (Either a b) 253 | instance (Vary a, Vary b) => Vary (a, b) 254 | instance Vary Void 255 | instance Vary Bool 256 | instance Vary Ordering 257 | instance Vary a => Vary (Maybe a) 258 | instance Vary a => Vary [a] 259 | instance Vary Int8 where; vary = varyIntegral 260 | instance Vary Int16 where; vary = varyIntegral 261 | instance Vary Int32 where; vary = varyIntegral 262 | instance Vary Int64 where; vary = varyIntegral 263 | instance Vary Int where; vary = varyIntegral 264 | instance Vary Integer where; vary = varyIntegral 265 | instance Vary Word8 where; vary = varyIntegral 266 | 267 | -- | Reify a function via an isomorphism. 268 | -- 269 | -- If your function's domain has no instance of 'Generic' then you can still reify it using 270 | -- an isomorphism to a better domain type. For example, the 'Arg' instance for 'Integral' 271 | -- uses an isomorphism from @Integral a => a@ to @(Bool, [Bool])@, where the first element 272 | -- is the sign, and the second element is the bit-string. 273 | -- 274 | -- Note: @via f g@ will only be well-behaved if @g . f = id@ and @f . g = id@ 275 | via :: Arg b => (a -> b) -> (b -> a) -> (a -> c) -> a :-> c 276 | via a b f = Map a b . build $ f . b 277 | 278 | instance Arg Void where 279 | build _ = Nil 280 | 281 | instance Arg () where 282 | build f = Unit $ f () 283 | 284 | instance (Arg a, Arg b) => Arg (a, b) where 285 | build f = Pair . build $ \a -> build $ \b -> f (a, b) 286 | 287 | instance (Arg a, Arg b) => Arg (Either a b) where 288 | build f = Sum (build $ f . Left) (build $ f . Right) 289 | 290 | gvia :: GArg b => (a -> b x) -> (b x -> a) -> (a -> c) -> a :-> c 291 | gvia a b f = Map a b . gbuild' $ f . b 292 | 293 | instance GArg V1 where 294 | gbuild' _ = Nil 295 | 296 | instance GArg U1 where 297 | gbuild' f = Map (\U1 -> ()) (\() -> U1) (Unit $ f U1) 298 | 299 | instance (GArg a, GArg b) => GArg (a :*: b) where 300 | gbuild' f = Map fromPair toPair $ Pair . gbuild' $ \a -> gbuild' $ \b -> f (a :*: b) 301 | where 302 | fromPair (a :*: b) = (a, b) 303 | toPair (a, b) = (a :*: b) 304 | 305 | instance (GArg a, GArg b) => GArg (a :+: b) where 306 | gbuild' f = Map fromSum toSum $ Sum (gbuild' $ f . L1) (gbuild' $ f . R1) 307 | where 308 | fromSum = \case; L1 a -> Left a; R1 a -> Right a 309 | toSum = either L1 R1 310 | 311 | instance GArg c => GArg (M1 a b c) where 312 | gbuild' = gvia unM1 M1 313 | 314 | instance Arg b => GArg (K1 a b) where 315 | gbuild' f = Map unK1 K1 . build $ f . K1 316 | 317 | -- | Reify a function on 'Integral's 318 | buildIntegral :: (Arg a, Integral a) => (a -> c) -> (a :-> c) 319 | buildIntegral = via toBits fromBits 320 | where 321 | toBits :: Integral a => a -> (Bool, [Bool]) 322 | toBits n 323 | | n >= 0 = (True, go n) 324 | | otherwise = (False, go $ -n - 1) 325 | where 326 | go 0 = [] 327 | go m = 328 | let 329 | (q, r) = quotRem m 2 330 | in 331 | (r == 1) : go q 332 | 333 | fromBits :: Integral a => (Bool, [Bool]) -> a 334 | fromBits (pos, bts) 335 | | pos = go bts 336 | | otherwise = negate $ go bts + 1 337 | where 338 | go [] = 0 339 | go (x:xs) = (if x then 1 else 0) + 2 * go xs 340 | 341 | instance Arg Bool 342 | instance Arg Ordering 343 | instance Arg a => Arg (Maybe a) 344 | instance Arg a => Arg [a] 345 | instance Arg Int8 where; build = buildIntegral 346 | instance Arg Int16 where; build = buildIntegral 347 | instance Arg Int32 where; build = buildIntegral 348 | instance Arg Int64 where; build = buildIntegral 349 | instance Arg Int where; build = buildIntegral 350 | instance Arg Integer where; build = buildIntegral 351 | --------------------------------------------------------------------------------