├── .gitignore ├── LICENSE ├── README.md ├── RELEASES.md ├── Setup.hs ├── StrictCheck.cabal ├── default.nix ├── nix ├── sources.json └── sources.nix ├── shell.nix ├── src └── Test │ ├── StrictCheck.hs │ └── StrictCheck │ ├── Consume.hs │ ├── Curry.hs │ ├── Demand.hs │ ├── Examples │ ├── Lists.hs │ └── Map.hs │ ├── Internal │ ├── Inputs.hs │ ├── Omega.hs │ ├── Shrink.hs │ └── Unevaluated.hs │ ├── Observe.hs │ ├── Observe │ └── Unsafe.hs │ ├── Produce.hs │ ├── Shaped.hs │ ├── Shaped │ └── Flattened.hs │ └── TH.hs ├── stack.yaml └── tests ├── RefTrans.hs ├── Specs.hs └── Tests.hs /.gitignore: -------------------------------------------------------------------------------- 1 | .stack-work/ 2 | TAGS 3 | .#* -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) 2018 Kenneth Foner, Hengchu Zhang, and Leonidas Lampropoulos 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # StrictCheck: Keep Your Laziness In Check 2 | 3 | StrictCheck is a property-based random testing framework for 4 | observing, specifying, and testing the strictness behaviors of Haskell 5 | functions. Strictness behavior is traditionally considered a non-functional 6 | property; StrictCheck allows it to be tested as if it were one, by reifying 7 | demands on data structures so they can be manipulated and examined within 8 | Haskell. 9 | 10 | For details, see the library on Hackage: . 11 | -------------------------------------------------------------------------------- /RELEASES.md: -------------------------------------------------------------------------------- 1 | # Releases 2 | 3 | All notable changes to this project will be documented in this file. 4 | 5 | The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.0.0/), 6 | and this project adheres to the [Haskell Package Versioning Policy](https://pvp.haskell.org/). 7 | 8 | ## [0.2.0] - 2018-10-08 9 | 10 | ### Added 11 | 12 | - Expose instrumentation of data structures as a safe interface in the `IO` monad. 13 | - Add monadic folds and unfolds `translateA`, `foldM`, `unfoldM`, and `unzipWithM` to `Test.StrictCheck.Shaped`. 14 | 15 | ### Removed 16 | 17 | - Remove the referentially opaque observation primitives in `Test.StrictCheck.Unsafe`. 18 | 19 | ### Changed 20 | 21 | - Improve type inference by making `Shape` an injective type family. 22 | 23 | ## [0.1.1] - 2018-10-01 24 | 25 | ### Fixed 26 | 27 | - Fix critical semantic [bug #2](https://github.com/kwf/StrictCheck/issues/2) which caused violation of referential transparency when compiling with optimizations on GHC 8.6. 28 | 29 | ## [0.1.0] - 2018-06-22 30 | 31 | First release of StrictCheck. This version matches the reviewed artifact submitted to ICFP, archived on the ACM DL, with the exception of some small documentation tweaks. 32 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /StrictCheck.cabal: -------------------------------------------------------------------------------- 1 | name: StrictCheck 2 | version: 0.3.0 3 | synopsis: StrictCheck: Keep Your Laziness In Check 4 | description: StrictCheck is a property-based random testing framework for 5 | observing, specifying, and testing the strictness behaviors of Haskell 6 | functions. Strictness behavior is traditionally considered a non-functional 7 | property; StrictCheck allows it to be tested as if it were one, by reifying 8 | demands on data structures so they can be manipulated and examined within 9 | Haskell. 10 | homepage: https://github.com/kwf/StrictCheck#readme 11 | license: MIT 12 | license-file: LICENSE 13 | author: Kenneth Foner, Hengchu Zhang, and Leo Lampropoulos 14 | maintainer: kwf@very.science 15 | copyright: (c) 2018 Kenneth Foner, Hengchu Zhang, and Leo Lampropoulos 16 | category: Testing 17 | build-type: Simple 18 | cabal-version: >=1.10 19 | extra-source-files: README.md 20 | 21 | source-repository this 22 | type: git 23 | branch: master 24 | tag: master 25 | location: https://github.com/kwf/StrictCheck 26 | 27 | library 28 | hs-source-dirs: src 29 | default-language: Haskell2010 30 | build-depends: base >= 4.7 && < 5, 31 | QuickCheck >= 2.10 && < 2.15, 32 | containers >= 0.5 && < 0.7, 33 | generics-sop >= 0.3.2 && < 0.6, 34 | bifunctors >= 5.5 && < 5.6, 35 | template-haskell >= 2.12 && < 2.19 36 | exposed-modules: Test.StrictCheck 37 | Test.StrictCheck.Curry, 38 | Test.StrictCheck.Consume, 39 | Test.StrictCheck.Produce, 40 | Test.StrictCheck.Demand, 41 | Test.StrictCheck.Observe, 42 | Test.StrictCheck.Observe.Unsafe, 43 | Test.StrictCheck.Shaped, 44 | Test.StrictCheck.Shaped.Flattened, 45 | Test.StrictCheck.Internal.Inputs, 46 | Test.StrictCheck.Internal.Unevaluated, 47 | Test.StrictCheck.Internal.Shrink, 48 | Test.StrictCheck.Internal.Omega, 49 | Test.StrictCheck.TH, 50 | Test.StrictCheck.Examples.Lists, 51 | Test.StrictCheck.Examples.Map 52 | default-extensions: DataKinds, GADTs, BangPatterns, TypeFamilies, RankNTypes, 53 | AllowAmbiguousTypes, DefaultSignatures, TypeApplications, 54 | ScopedTypeVariables, FlexibleContexts, 55 | UndecidableInstances, ConstraintKinds, DeriveFunctor, 56 | FlexibleInstances, StandaloneDeriving, DeriveGeneric, 57 | DeriveAnyClass, TypeOperators, PolyKinds, 58 | GeneralizedNewtypeDeriving, 59 | ViewPatterns, LambdaCase, TupleSections, ImplicitParams, 60 | NamedFieldPuns, PatternSynonyms 61 | ghc-options: -Wall -Wno-unticked-promoted-constructors 62 | -Wredundant-constraints 63 | 64 | test-suite test-strictcheck 65 | type: exitcode-stdio-1.0 66 | hs-source-dirs: tests 67 | main-is: Tests.hs 68 | other-modules: Specs, RefTrans 69 | default-language: Haskell2010 70 | default-extensions: DataKinds, GADTs, BangPatterns, TypeFamilies, RankNTypes, 71 | AllowAmbiguousTypes, UndecidableInstances, 72 | DefaultSignatures, TypeApplications, ScopedTypeVariables, 73 | FlexibleContexts, ConstraintKinds, DeriveFunctor, 74 | FlexibleInstances, StandaloneDeriving, DeriveGeneric, 75 | DeriveAnyClass, TypeOperators, PolyKinds, LambdaCase, 76 | TupleSections, TypeFamilyDependencies, 77 | MultiParamTypeClasses, 78 | GeneralizedNewtypeDeriving, ViewPatterns, 79 | PatternSynonyms 80 | ghc-options: -Wall -fno-warn-unused-imports -O2 81 | build-depends: base, 82 | HUnit, 83 | generics-sop, 84 | deepseq, 85 | StrictCheck, 86 | QuickCheck 87 | -------------------------------------------------------------------------------- /default.nix: -------------------------------------------------------------------------------- 1 | { compiler ? "ghc922" }: 2 | 3 | let 4 | sources = import ./nix/sources.nix; 5 | pkgs = import sources.nixpkgs { }; 6 | 7 | gitignore = pkgs.nix-gitignore.gitignoreSourcePure [ ./.gitignore ]; 8 | 9 | myHaskellPackages = pkgs.haskell.packages.${compiler}.override { 10 | overrides = hself: hsuper: { 11 | "StrictCheck" = hself.callCabal2nix "StrictCheck" (gitignore ./.) { }; 12 | }; 13 | }; 14 | 15 | shell = myHaskellPackages.shellFor { 16 | packages = p: [ p."StrictCheck" ]; 17 | buildInputs = [ 18 | myHaskellPackages.haskell-language-server 19 | pkgs.haskellPackages.cabal-install 20 | pkgs.haskellPackages.ghcid 21 | pkgs.haskellPackages.ormolu 22 | pkgs.haskellPackages.hlint 23 | pkgs.haskellPackages.hasktags 24 | pkgs.niv 25 | pkgs.nixpkgs-fmt 26 | ]; 27 | withHoogle = true; 28 | }; 29 | 30 | exe = pkgs.haskell.lib.justStaticExecutables (myHaskellPackages."StrictCheck"); 31 | 32 | docker = pkgs.dockerTools.buildImage { 33 | name = "StrictCheck"; 34 | config.Cmd = [ "${exe}/bin/StrictCheck" ]; 35 | }; 36 | in { 37 | inherit shell; 38 | inherit exe; 39 | inherit docker; 40 | inherit myHaskellPackages; 41 | "StrictCheck" = myHaskellPackages."StrictCheck"; 42 | } 43 | -------------------------------------------------------------------------------- /nix/sources.json: -------------------------------------------------------------------------------- 1 | { 2 | "nixpkgs": { 3 | "branch": "nixpkgs-unstable", 4 | "description": "Nix Packages collection", 5 | "homepage": null, 6 | "owner": "nixos", 7 | "repo": "nixpkgs", 8 | "rev": "2fdb6f2e08e7989b03a2a1aa8538d99e3eeea881", 9 | "sha256": "12wfjn35j9k28jgp8ihg96c90lqnplfm5r2v5y02pbics58lcrbw", 10 | "type": "tarball", 11 | "url": "https://github.com/nixos/nixpkgs/archive/2fdb6f2e08e7989b03a2a1aa8538d99e3eeea881.tar.gz", 12 | "url_template": "https://github.com///archive/.tar.gz" 13 | } 14 | } 15 | -------------------------------------------------------------------------------- /nix/sources.nix: -------------------------------------------------------------------------------- 1 | # This file has been generated by Niv. 2 | 3 | let 4 | 5 | # 6 | # The fetchers. fetch_ fetches specs of type . 7 | # 8 | 9 | fetch_file = pkgs: spec: 10 | if spec.builtin or true then 11 | builtins_fetchurl { inherit (spec) url sha256; } 12 | else 13 | pkgs.fetchurl { inherit (spec) url sha256; }; 14 | 15 | fetch_tarball = pkgs: name: spec: 16 | let 17 | ok = str: ! builtins.isNull (builtins.match "[a-zA-Z0-9+-._?=]" str); 18 | # sanitize the name, though nix will still fail if name starts with period 19 | name' = stringAsChars (x: if ! ok x then "-" else x) "${name}-src"; 20 | in 21 | if spec.builtin or true then 22 | builtins_fetchTarball { name = name'; inherit (spec) url sha256; } 23 | else 24 | pkgs.fetchzip { name = name'; inherit (spec) url sha256; }; 25 | 26 | fetch_git = spec: 27 | builtins.fetchGit { url = spec.repo; inherit (spec) rev ref; }; 28 | 29 | fetch_builtin-tarball = name: throw 30 | ''[${name}] The niv type "builtin-tarball" is deprecated. You should instead use `builtin = true`. 31 | $ niv modify ${name} -a type=tarball -a builtin=true''; 32 | 33 | fetch_builtin-url = name: throw 34 | ''[${name}] The niv type "builtin-url" will soon be deprecated. You should instead use `builtin = true`. 35 | $ niv modify ${name} -a type=file -a builtin=true''; 36 | 37 | # 38 | # Various helpers 39 | # 40 | 41 | # The set of packages used when specs are fetched using non-builtins. 42 | mkPkgs = sources: 43 | let 44 | sourcesNixpkgs = 45 | import (builtins_fetchTarball { inherit (sources.nixpkgs) url sha256; }) {}; 46 | hasNixpkgsPath = builtins.any (x: x.prefix == "nixpkgs") builtins.nixPath; 47 | hasThisAsNixpkgsPath = == ./.; 48 | in 49 | if builtins.hasAttr "nixpkgs" sources 50 | then sourcesNixpkgs 51 | else if hasNixpkgsPath && ! hasThisAsNixpkgsPath then 52 | import {} 53 | else 54 | abort 55 | '' 56 | Please specify either (through -I or NIX_PATH=nixpkgs=...) or 57 | add a package called "nixpkgs" to your sources.json. 58 | ''; 59 | 60 | # The actual fetching function. 61 | fetch = pkgs: name: spec: 62 | 63 | if ! builtins.hasAttr "type" spec then 64 | abort "ERROR: niv spec ${name} does not have a 'type' attribute" 65 | else if spec.type == "file" then fetch_file pkgs spec 66 | else if spec.type == "tarball" then fetch_tarball pkgs name spec 67 | else if spec.type == "git" then fetch_git spec 68 | else if spec.type == "builtin-tarball" then fetch_builtin-tarball name 69 | else if spec.type == "builtin-url" then fetch_builtin-url name 70 | else 71 | abort "ERROR: niv spec ${name} has unknown type ${builtins.toJSON spec.type}"; 72 | 73 | # Ports of functions for older nix versions 74 | 75 | # a Nix version of mapAttrs if the built-in doesn't exist 76 | mapAttrs = builtins.mapAttrs or ( 77 | f: set: with builtins; 78 | listToAttrs (map (attr: { name = attr; value = f attr set.${attr}; }) (attrNames set)) 79 | ); 80 | 81 | # https://github.com/NixOS/nixpkgs/blob/0258808f5744ca980b9a1f24fe0b1e6f0fecee9c/lib/lists.nix#L295 82 | range = first: last: if first > last then [] else builtins.genList (n: first + n) (last - first + 1); 83 | 84 | # https://github.com/NixOS/nixpkgs/blob/0258808f5744ca980b9a1f24fe0b1e6f0fecee9c/lib/strings.nix#L257 85 | stringToCharacters = s: map (p: builtins.substring p 1 s) (range 0 (builtins.stringLength s - 1)); 86 | 87 | # https://github.com/NixOS/nixpkgs/blob/0258808f5744ca980b9a1f24fe0b1e6f0fecee9c/lib/strings.nix#L269 88 | stringAsChars = f: s: concatStrings (map f (stringToCharacters s)); 89 | concatStrings = builtins.concatStringsSep ""; 90 | 91 | # fetchTarball version that is compatible between all the versions of Nix 92 | builtins_fetchTarball = { url, name, sha256 }@attrs: 93 | let 94 | inherit (builtins) lessThan nixVersion fetchTarball; 95 | in 96 | if lessThan nixVersion "1.12" then 97 | fetchTarball { inherit name url; } 98 | else 99 | fetchTarball attrs; 100 | 101 | # fetchurl version that is compatible between all the versions of Nix 102 | builtins_fetchurl = { url, sha256 }@attrs: 103 | let 104 | inherit (builtins) lessThan nixVersion fetchurl; 105 | in 106 | if lessThan nixVersion "1.12" then 107 | fetchurl { inherit url; } 108 | else 109 | fetchurl attrs; 110 | 111 | # Create the final "sources" from the config 112 | mkSources = config: 113 | mapAttrs ( 114 | name: spec: 115 | if builtins.hasAttr "outPath" spec 116 | then abort 117 | "The values in sources.json should not have an 'outPath' attribute" 118 | else 119 | spec // { outPath = fetch config.pkgs name spec; } 120 | ) config.sources; 121 | 122 | # The "config" used by the fetchers 123 | mkConfig = 124 | { sourcesFile ? ./sources.json 125 | , sources ? builtins.fromJSON (builtins.readFile sourcesFile) 126 | , pkgs ? mkPkgs sources 127 | }: rec { 128 | # The sources, i.e. the attribute set of spec name to spec 129 | inherit sources; 130 | 131 | # The "pkgs" (evaluated nixpkgs) to use for e.g. non-builtin fetchers 132 | inherit pkgs; 133 | }; 134 | in 135 | mkSources (mkConfig {}) // { __functor = _: settings: mkSources (mkConfig settings); } 136 | -------------------------------------------------------------------------------- /shell.nix: -------------------------------------------------------------------------------- 1 | (import ./default.nix { }).shell 2 | -------------------------------------------------------------------------------- /src/Test/StrictCheck.hs: -------------------------------------------------------------------------------- 1 | {-| The top-level interface to the StrictCheck library for random strictness 2 | testing. 3 | 4 | __Quick Start:__ 5 | 6 | Want to explore the strictness of functions before you write specifications? 7 | Go to "Test.StrictCheck.Observe" and look at the functions 'observe1' and 8 | 'observe'. 9 | 10 | Want to check the strictness of a function against a specification of its 11 | strictness? 12 | 13 | 1. Write a 'Spec' describing your expectation of the function's behavior. 14 | See "Test.StrictCheck.Demand" for more on working with demands, and 15 | "Test.StrictCheck.Examples.Lists" for examples of some specifications of 16 | functions on lists. 17 | 2. Check your function using 'strictCheckSpecExact', like so: 18 | 19 | > strictCheckSpecExact spec function 20 | 21 | If your function passes testing, you'll get a success message just like in 22 | "Test.QuickCheck"; if a counterexample to your specification is found, you 23 | will see a pretty Unicode box diagram describing the mismatch. 24 | 25 | __Hint:__ StrictCheck, just like QuickCheck, doesn't work with polymorphic 26 | functions. If you get baffling type errors, first make sure that all your 27 | types are totally concrete. 28 | -} 29 | 30 | {-# language DerivingStrategies #-} 31 | 32 | module Test.StrictCheck 33 | ( -- * Specifying demand behavior 34 | Spec(..) 35 | , getSpec 36 | -- * Checking specifications 37 | , StrictCheck 38 | , strictCheckSpecExact 39 | , strictCheckWithResults 40 | -- * Providing arguments for 'strictCheckWithResults' 41 | , genViaProduce 42 | , Shrink(..) 43 | , shrinkViaArbitrary 44 | , Strictness 45 | , strictnessViaSized 46 | -- * Representing individual evaluations of functions 47 | , Evaluation(..) 48 | , evaluationForall 49 | , shrinkEvalWith 50 | -- * Comparing demands 51 | , DemandComparison(..) 52 | , compareToSpecWith 53 | , equalToSpec 54 | -- * Re-exported n-ary products from "Generics.SOP" 55 | , NP(..), I(..), All 56 | -- * Re-exports of the rest of the library 57 | , module Test.StrictCheck.Demand 58 | , module Test.StrictCheck.Observe 59 | , module Test.StrictCheck.Produce 60 | , module Test.StrictCheck.Consume 61 | , module Test.StrictCheck.Shaped 62 | ) 63 | where 64 | 65 | import Test.StrictCheck.Curry as Curry 66 | import Test.StrictCheck.Produce 67 | import Test.StrictCheck.Consume 68 | import Test.StrictCheck.Observe 69 | import Test.StrictCheck.Demand 70 | import Test.StrictCheck.Shaped 71 | 72 | import Test.StrictCheck.Internal.Omega 73 | import Test.StrictCheck.Internal.Shrink 74 | ( Shrink(..), axialShrinks, fairInterleave ) 75 | 76 | import Generics.SOP hiding (Shape) 77 | 78 | import Test.QuickCheck as Exported hiding (Args, Result, function) 79 | import qualified Test.QuickCheck as QC 80 | 81 | import Data.List 82 | import Data.Maybe 83 | import Data.IORef 84 | import Type.Reflection 85 | 86 | -- | The default comparison of demands: exact equality 87 | compareEquality :: All Shaped xs => NP DemandComparison xs 88 | compareEquality = hcpure (Proxy @Shaped) (DemandComparison (==)) 89 | 90 | -- | The default way to generate inputs: via 'Produce' 91 | genViaProduce :: All Produce xs => NP Gen xs 92 | genViaProduce = hcpure (Proxy @Produce) (freely produce) 93 | 94 | -- | The default way to shrink inputs: via 'shrink' (from "Test.QuickCheck"'s 95 | -- 'Arbitrary' typeclass) 96 | shrinkViaArbitrary :: All Arbitrary xs => NP Shrink xs 97 | shrinkViaArbitrary = hcpure (Proxy @Arbitrary) (Shrink shrink) 98 | 99 | -- | The default way to generate random strictnesses: uniformly choose between 100 | -- 1 and the test configuration's @size@ parameter 101 | strictnessViaSized :: Gen Strictness 102 | strictnessViaSized = 103 | Strictness <$> (choose . (1,) =<< getSize) 104 | 105 | -- | A newtype for wrapping a comparison on demands 106 | -- 107 | -- This is useful when constructing an 'NP' n-ary product of such comparisons. 108 | newtype DemandComparison a = 109 | DemandComparison (Demand a -> Demand a -> Bool) 110 | 111 | -- | A demand specification for some function @f@ is itself a function which 112 | -- manipulates demand values for some function's arguments and results 113 | -- 114 | -- A @Spec@ for @f@ wraps a function which takes, in order: 115 | -- 116 | -- * a continuation @predict@ which accepts all of @f@'s argument types in order, 117 | -- * an implicit representation of a demand on @f@'s result (embedded in @f@'s 118 | -- actual result type using special bottom values, see the documentation for 119 | -- "Test.StrictCheck.Demand" for details), and 120 | -- * all of @f@'s original arguments in order 121 | -- 122 | -- The intention is that the @Spec@ will call @predict@ on some set of demands 123 | -- representing the demands it predicts that @f@ will exert on its inputs, 124 | -- given the provided demand on @f@'s outputs. 125 | -- 126 | -- For example, here is a correct @Spec@ for 'take': 127 | -- 128 | -- > take_spec :: Spec '[Int, [a]] [a] 129 | -- > take_spec = 130 | -- > Spec $ \predict d n xs -> 131 | -- > predict n (if n > length xs then d else d ++ thunk) 132 | -- 133 | -- See the documentation for "Test.StrictCheck.Demand" for information about how 134 | -- to manipulate these implicit demand representations when writing @Spec@s, and 135 | -- see the documentation for "Test.StrictCheck.Examples.Lists" for more examples 136 | -- of writing specifications. 137 | newtype Spec (args :: [*]) (result :: *) 138 | = Spec (forall r. (args ⋯-> r) -> result -> args ⋯-> r) 139 | 140 | -- | Unwrap a @Spec@ constructor, returning the contained CPS-ed specification 141 | -- 142 | -- Conceptually, this is the inverse to the @Spec@ constructor, but because 143 | -- @Spec@ is variadic, @getSpec . Spec@ and @Spec . getSpec@ don't typecheck 144 | -- without additional type annotation. 145 | getSpec 146 | :: forall r args result. 147 | Spec args result 148 | -> (args ⋯-> r) 149 | -> result 150 | -> args ⋯-> r 151 | getSpec (Spec s) k d = s @r k d 152 | 153 | -- | Given a list of ways to compare demands, a demand specification, and an 154 | -- evaluation of a particular function, determine if the function met the 155 | -- specification, as decided by the comparisons. If so, return the prediction 156 | -- of the specification. 157 | compareToSpecWith 158 | :: forall args result. 159 | (All Shaped args, Curry args, Shaped result) 160 | => NP DemandComparison args 161 | -> Spec args result 162 | -> Evaluation args result 163 | -> Maybe (NP Demand args) 164 | compareToSpecWith comparisons spec (Evaluation inputs inputsD resultD) = 165 | let prediction = 166 | Curry.uncurry 167 | (getSpec @(NP Demand args) 168 | spec 169 | collectDemands 170 | (fromDemand $ E resultD)) 171 | inputs 172 | correct = 173 | all id . hcollapse $ 174 | hcliftA3 (Proxy @Shaped) 175 | (\(DemandComparison c) iD iD' -> K $ iD `c` iD') 176 | comparisons 177 | inputsD 178 | prediction 179 | in if correct then Nothing else Just prediction 180 | where 181 | collectDemands :: args ⋯-> NP Demand args 182 | collectDemands = 183 | curryCollect @args (hcmap (Proxy @Shaped) (toDemand . unI)) 184 | 185 | curryCollect 186 | :: forall (xs :: [*]) r. Curry xs => (NP I xs -> r) -> xs ⋯-> r 187 | curryCollect k = Curry.curry @xs k 188 | 189 | -- | Checks if a given 'Evaluation' exactly matches the prediction of a given 190 | -- 'Spec', returning the prediction of that @Spec@ if not 191 | -- 192 | -- __Note:__ In the case of __success__ this returns @Nothing@; in the case of 193 | -- __failure__ this returns @Just@ the incorrect prediction. 194 | equalToSpec 195 | :: forall args result. 196 | (All Shaped args, Shaped result, Curry args) 197 | => Spec args result 198 | -> Evaluation args result 199 | -> Maybe (NP Demand args) 200 | equalToSpec spec e = 201 | compareToSpecWith compareEquality spec e 202 | 203 | -- | A @Strictness@ represents (roughly) how strict a randomly generated 204 | -- function or evaluation context should be 205 | -- 206 | -- An evaluation context generated with some strictness @s@ (i.e. through 207 | -- 'evaluationForall') will consume at most @s@ constructors of its input, 208 | -- although it might consume fewer. 209 | newtype Strictness 210 | = Strictness Int 211 | deriving stock (Eq, Ord) 212 | deriving newtype (Show, Num) 213 | 214 | -- | A function can be checked against a specification if it meets the 215 | -- @StrictCheck@ constraint 216 | type StrictCheck function = 217 | ( Shaped (Result function) 218 | , Consume (Result function) 219 | , Curry (Args function) 220 | , All Typeable (Args function) 221 | , All Shaped (Args function) ) 222 | 223 | -- | The most general function for random strictness testing: all of the more 224 | -- convenient such functions can be derived from this one 225 | -- 226 | -- Given some function @f@, this takes as arguments: 227 | -- 228 | -- * A 'QC.Args' record describing arguments to pass to the underlying 229 | -- QuickCheck engine 230 | -- * An 'NP' n-ary product of 'Shrink' shrinkers, one for each argument of @f@ 231 | -- * An 'NP' n-ary product of 'Gen' generators, one for each argument of @f@ 232 | -- * A 'Gen' generator for strictnesses to be tested 233 | -- * A predicate on 'Evaluation's: if the 'Evaluation' passes the predicate, 234 | -- it should return @Nothing@; otherwise, it should return @Just@ some 235 | -- @evidence@ representing the failure (when checking 'Spec's, this evidence 236 | -- comes in the form of a @Spec@'s (incorrect) prediction) 237 | -- * the function @f@ to be tested 238 | -- 239 | -- If all tests succeed, @(Nothing, result)@ is returned, where @result@ is the 240 | -- underlying 'QC.Result' type from "Test.QuickCheck". If there is a test 241 | -- failure, it also returns @Just@ the failed 'Evaluation' as well as whatever 242 | -- @evidence@ was produced by the predicate. 243 | strictCheckWithResults :: 244 | forall function evidence. 245 | StrictCheck function 246 | => QC.Args 247 | -> NP Shrink (Args function) -- TODO: allow dependent shrinking 248 | -> NP Gen (Args function) -- TODO: allow dependent generation 249 | -> Gen Strictness 250 | -> (Evaluation (Args function) (Result function) -> Maybe evidence) 251 | -> function 252 | -> IO ( Maybe ( Evaluation (Args function) (Result function) 253 | , evidence ) 254 | , QC.Result ) 255 | strictCheckWithResults 256 | qcArgs shrinks gens strictness predicate function = do 257 | ref <- newIORef Nothing 258 | result <- 259 | quickCheckWithResult qcArgs{chatty = False{-, maxSuccess = 10000-}} $ 260 | forAllShrink 261 | (evaluationForall @function gens strictness function) 262 | (shrinkEvalWith @function shrinks function) $ 263 | \example -> 264 | case predicate example of 265 | Nothing -> 266 | property True 267 | Just evidence -> 268 | whenFail (writeIORef ref $ Just (example, evidence)) False 269 | readIORef ref >>= \case 270 | Nothing -> pure (Nothing, result) 271 | Just example -> pure (Just example, result) 272 | 273 | -- | Check a function to see whether it exactly meets a strictness specification 274 | -- 275 | -- If the function fails to meet the specification, a counterexample is 276 | -- pretty-printed in a box-drawn diagram illustrating how the specification 277 | -- failed to match the real observed behavior of the function. 278 | strictCheckSpecExact 279 | :: forall function. 280 | ( StrictCheck function 281 | , All Arbitrary (Args function) 282 | , All Produce (Args function) 283 | ) => Spec (Args function) (Result function) 284 | -> function 285 | -> IO () 286 | strictCheckSpecExact spec function = 287 | do (maybeExample, result) <- 288 | strictCheckWithResults 289 | stdArgs 290 | shrinkViaArbitrary 291 | genViaProduce 292 | strictnessViaSized 293 | (equalToSpec spec) 294 | function 295 | (putStrLn . head . lines) (output result) 296 | case maybeExample of 297 | Nothing -> return () 298 | Just example -> 299 | putStrLn (Prelude.uncurry displayCounterSpec example) 300 | 301 | ------------------------------------------------------------ 302 | -- An Evaluation is what we generate when StrictCheck-ing -- 303 | ------------------------------------------------------------ 304 | 305 | -- | A snapshot of the observed strictness behavior of a function 306 | -- 307 | -- An @Evaluation@ contains the 'inputs' at which a function was called, the 308 | -- 'inputDemands' which were induced upon those inputs, and the 'resultDemand' 309 | -- which induced that demand on the inputs. 310 | data Evaluation args result = 311 | Evaluation 312 | { inputs :: NP I args -- ^ Inputs to a function 313 | , inputDemands :: NP Demand args -- ^ Demands on the input 314 | , resultDemand :: PosDemand result -- ^ Demand on the result 315 | } 316 | 317 | instance (All Typeable args, Typeable result) 318 | => Show (Evaluation args result) where 319 | show _ = 320 | " :: Evaluation" 321 | ++ " '[" ++ intercalate ", " argTypes ++ "]" 322 | ++ " " ++ show (typeRep :: TypeRep result) 323 | where 324 | argTypes :: [String] 325 | argTypes = 326 | hcollapse 327 | $ hliftA (K . show) 328 | $ (hcpure (Proxy @Typeable) typeRep :: NP TypeRep args) 329 | 330 | 331 | ----------------------------------- 332 | -- Generating random evaluations -- 333 | ----------------------------------- 334 | 335 | -- | Given a list of generators for a function's arguments and a generator for 336 | -- random strictnesses (measured in number of constructors evaluated), create 337 | -- a generator for random 'Evaluation's of that function in random contexts 338 | evaluationForall 339 | :: forall f. 340 | ( Curry (Args f) 341 | , Consume (Result f) 342 | , Shaped (Result f) 343 | , All Shaped (Args f) 344 | ) => NP Gen (Args f) 345 | -> Gen Strictness 346 | -> f 347 | -> Gen (Evaluation (Args f) (Result f)) 348 | evaluationForall gens strictnessGen function = do 349 | inputs <- hsequence gens 350 | strictness <- strictnessGen 351 | toOmega <- freely produce 352 | return (go strictness toOmega inputs) 353 | where 354 | -- If context is fully lazy, increase strictness until it forces something 355 | go :: Strictness 356 | -> (Result f -> Omega) 357 | -> NP I (Args f) 358 | -> Evaluation (Args f) (Result f) 359 | go (Strictness s) tO is = 360 | let (resultD, inputsD) = 361 | observeNP (forceOmega s . tO) (uncurryAll @f function) is 362 | in case resultD of 363 | T -> go (Strictness s + 1) tO is 364 | E posResultD -> 365 | Evaluation is inputsD posResultD 366 | 367 | 368 | --------------------------- 369 | -- Shrinking evaluations -- 370 | --------------------------- 371 | 372 | -- | Given a shrinker for each of the arguments of a function, the function 373 | -- itself, and some 'Evaluation' of that function, produce a list of smaller 374 | -- @Evaluation@s of that function 375 | shrinkEvalWith 376 | :: forall f. 377 | ( Curry (Args f) 378 | , Shaped (Result f) 379 | , All Shaped (Args f) 380 | ) => NP Shrink (Args f) 381 | -> f 382 | -> Evaluation (Args f) (Result f) 383 | -> [Evaluation (Args f) (Result f)] 384 | shrinkEvalWith 385 | shrinks (uncurryAll -> function) (Evaluation inputs _ resultD) = 386 | let shrunkDemands = shrinkDemand @(Result f) resultD 387 | shrunkInputs = fairInterleave (axialShrinks shrinks inputs) 388 | shrinkingDemand = mapMaybe (reObserve inputs) shrunkDemands 389 | shrinkingInputs = mapMaybe (flip reObserve resultD) shrunkInputs 390 | in fairInterleave [ shrinkingDemand, shrinkingInputs ] 391 | where 392 | reObserve 393 | :: NP I (Args f) 394 | -> PosDemand (Result f) 395 | -> Maybe (Evaluation (Args f) (Result f)) 396 | reObserve is rD = 397 | let (rD', isD) = observeNP (evaluateDemand rD) function is 398 | in fmap (Evaluation is isD) $ 399 | case rD' of 400 | T -> Nothing 401 | E pos -> Just pos 402 | 403 | 404 | -- | Render a counter-example to a specification (that is, an 'Evaluation' 405 | -- paired with some expected input demands it doesn't match) as a Unicode 406 | -- box-drawing sketch 407 | displayCounterSpec 408 | :: forall args result. 409 | (Shaped result, All Shaped args) 410 | => Evaluation args result 411 | -> NP Demand args 412 | -> String 413 | displayCounterSpec (Evaluation inputs inputsD resultD) predictedInputsD = 414 | beside inputBox (" " : "───" : repeat " ") resultBox 415 | ++ (flip replicate ' ' $ 416 | (2 `max` (subtract 2 $ (lineMax [inputString] `div` 2)))) 417 | ++ "🡓 🡓 🡓\n" 418 | ++ beside 419 | actualBox 420 | (" " : " " : " ═╱═ " : repeat " ") 421 | predictedBox 422 | where 423 | inputBox = 424 | box "┌" '─' "┐" 425 | "│" inputHeader "├" 426 | "├" '─' "┤" 427 | "│" inputString "│" 428 | "└" '─' "┘" 429 | 430 | resultBox = 431 | box "┌" '─' "┐" 432 | "┤" resultHeader "│" 433 | "├" '─' "┤" 434 | "│" resultString "│" 435 | "└" '─' "┘" 436 | 437 | actualBox = 438 | box "┌" '─' "┐" 439 | "│" actualHeader "│" 440 | "├" '─' "┤" 441 | "│" actualDemandString "│" 442 | "└" '─' "┘" 443 | 444 | predictedBox = 445 | box "┌" '─' "┐" 446 | "│" predictedHeader "│" 447 | "├" '─' "┤" 448 | "│" predictedDemandString "│" 449 | "└" '─' "┘" 450 | 451 | inputHeader = " Input" ++ plural 452 | resultHeader = " Demand on result" 453 | actualHeader = " Actual input demand" ++ plural 454 | predictedHeader = " Spec's input demand" ++ plural 455 | 456 | inputString = 457 | showBulletedNPWith @Shaped (prettyDemand . interleave Eval . unI) inputs 458 | resultString = " " ++ prettyDemand @result (E resultD) 459 | actualDemandString = 460 | showBulletedNPWith @Shaped prettyDemand inputsD 461 | predictedDemandString = 462 | showBulletedNPWith @Shaped prettyDemand predictedInputsD 463 | 464 | rule w l c r = frame w l (replicate w c) r ++ "\n" 465 | 466 | frame w before str after = 467 | before ++ str 468 | ++ (replicate (w - length str) ' ') 469 | ++ after 470 | 471 | frames w before para after = 472 | unlines $ map (\str -> frame w before str after) (lines para) 473 | 474 | beside l cs r = 475 | unlines . take (length ls `max` length rs) $ 476 | zipWith3 477 | (\x c y -> x ++ c ++ y) 478 | (ls ++ repeat (replicate (lineMax [l]) ' ')) 479 | cs 480 | (rs ++ repeat "") 481 | where 482 | ls = lines l 483 | rs = lines r 484 | 485 | box top_l top top_r 486 | header_l header header_r 487 | div_l div_c div_r 488 | body_l body body_r 489 | bottom_l bottom bottom_r = 490 | let w = lineMax [header, body] 491 | in rule w top_l top top_r 492 | ++ frames w header_l header header_r 493 | ++ rule w div_l div_c div_r 494 | ++ frames w body_l body body_r 495 | ++ rule w bottom_l bottom bottom_r 496 | 497 | lineMax strs = 498 | (maximum . map 499 | (\(lines -> ls) -> maximum (map length ls) + 1) $ strs) 500 | 501 | plural = case inputs of 502 | (_ :* Nil) -> "" 503 | _ -> "s" 504 | 505 | showBulletedNPWith 506 | :: forall c g xs. All c xs 507 | => (forall x. c x => g x -> String) -> NP g xs -> String 508 | -- showBulletedNPWith display (x :* Nil) = " " ++ display x ++ "\n" 509 | showBulletedNPWith display list = showNPWith' list 510 | where 511 | showNPWith' :: forall ys. All c ys => NP g ys -> String 512 | showNPWith' Nil = "" 513 | showNPWith' (y :* ys) = 514 | " • " ++ display y ++ "\n" ++ showNPWith' ys 515 | -------------------------------------------------------------------------------- /src/Test/StrictCheck/Consume.hs: -------------------------------------------------------------------------------- 1 | {-| This module defines the 'Consume' typeclass, used for incrementally 2 | destructing inputs to random non-strict functions. 3 | 4 | Calling 'consume' on some value lazily returns an abstract type of 'Input', 5 | which contains all the entropy present in the original value. Paired with 6 | 'Test.StrictCheck.Produce', these @Input@ values can be used to generate 7 | random non-strict functions, whose strictness behavior is dependent on the 8 | values given to them. 9 | -} 10 | module Test.StrictCheck.Consume 11 | ( -- * Incrementally consuming input 12 | Input 13 | , Inputs 14 | , Consume(..) 15 | -- * Manually writing 'Consume' instances 16 | , constructor 17 | , normalize 18 | , consumeTrivial 19 | , consumePrimitive 20 | -- * Generically deriving 'Consume' instances 21 | , GConsume 22 | , gConsume 23 | ) where 24 | 25 | import Test.QuickCheck 26 | import Generics.SOP 27 | import Generics.SOP.NS 28 | 29 | import Test.StrictCheck.Internal.Inputs 30 | 31 | import Data.Complex 32 | 33 | import Data.Foldable as Fold 34 | import Data.List.NonEmpty (NonEmpty(..)) 35 | import Data.Tree as Tree 36 | import Data.Set as Set 37 | import Data.Map as Map 38 | import Data.Sequence as Seq 39 | import Data.IntMap as IntMap 40 | import Data.IntSet as IntSet 41 | 42 | 43 | -- | Lazily monomorphize some input value, by converting it into an @Input@. 44 | -- This is an incremental version of QuickCheck's @CoArbitrary@ typeclass. 45 | -- It can also be seen as a generalization of the @NFData@ class. 46 | -- 47 | -- Instances of @Consume@ can be derived automatically for any type implementing 48 | -- the @Generic@ class from "GHC.Generics". Using the @DeriveAnyClass@ 49 | -- extension, we can say: 50 | -- 51 | -- > import GHC.Generics as GHC 52 | -- > import Generics.SOP as SOP 53 | -- > 54 | -- > data D x y 55 | -- > = A 56 | -- > | B (x, y) 57 | -- > deriving (GHC.Generic, SOP.Generic, Consume) 58 | -- 59 | -- This automatic derivation follows these rules, which you can follow too if 60 | -- you're manually writing an instance for some type which is not @Generic@: 61 | -- 62 | -- For each distinct constructor, make a single call to 'constructor' with 63 | -- a distinct @Int@, and a list of @Input@s, each created by recursively calling 64 | -- 'consume' on every field in that constructor. For abstract types (e.g. sets), 65 | -- the same procedure can be used upon an extracted list representation of the 66 | -- contents. 67 | class Consume a where 68 | -- | Convert an @a@ into an @Input@ by recursively destructing it using calls 69 | -- to @consume@ 70 | consume :: a -> Input 71 | default consume :: GConsume a => a -> Input 72 | consume = gConsume 73 | 74 | -- | Reassemble pieces of input into a larger Input: this is to be called on the 75 | -- result of @consume@-ing subparts of input 76 | constructor :: Int -> [Input] -> Input 77 | constructor n !is = 78 | Input (Variant (variant n)) is 79 | 80 | -- | Use the CoArbitrary instance for a type to consume it 81 | -- 82 | -- This should only be used for "flat" types, i.e. those which contain no 83 | -- interesting consumable substructure, as it's fully strict (non-incremental) 84 | consumePrimitive :: CoArbitrary a => a -> Input 85 | consumePrimitive !a = 86 | Input (Variant (coarbitrary a)) [] 87 | 88 | -- | Consume a type which has no observable structure whatsoever 89 | -- 90 | -- This should only be used for types for which there is only one inhabitant, or 91 | -- for which inhabitants cannot be distinguished at all. 92 | consumeTrivial :: a -> Input 93 | consumeTrivial !_ = 94 | Input mempty [] 95 | 96 | -- | Fully normalize something which can be consumed 97 | normalize :: Consume a => a -> () 98 | normalize (consume -> input) = go input 99 | where 100 | go (Input _ is) = Fold.foldr seq () (fmap go is) 101 | 102 | -------------------------------------------- 103 | -- Deriving Consume instances generically -- 104 | -------------------------------------------- 105 | 106 | -- | The constraints necessary to generically @consume@ something 107 | type GConsume a = (Generic a, All2 Consume (Code a)) 108 | 109 | -- | Generic 'consume' 110 | gConsume :: GConsume a => a -> Input 111 | gConsume !(from -> sop) = 112 | constructor (index_SOP sop) 113 | . hcollapse 114 | . hcliftA (Proxy @Consume) (K . consume . unI) 115 | $ sop 116 | 117 | 118 | --------------- 119 | -- Instances -- 120 | --------------- 121 | 122 | instance Consume (a -> b) where consume = consumeTrivial 123 | instance Consume (Proxy p) where consume = consumeTrivial 124 | 125 | instance Consume Char where consume = consumePrimitive 126 | instance Consume Word where consume = consumePrimitive 127 | instance Consume Int where consume = consumePrimitive 128 | instance Consume Double where consume = consumePrimitive 129 | instance Consume Float where consume = consumePrimitive 130 | instance Consume Rational where consume = consumePrimitive 131 | instance Consume Integer where consume = consumePrimitive 132 | instance (CoArbitrary a, RealFloat a) => Consume (Complex a) where 133 | consume = consumePrimitive 134 | 135 | instance Consume () 136 | instance Consume Bool 137 | instance Consume Ordering 138 | instance Consume a => Consume (Maybe a) 139 | instance (Consume a, Consume b) => Consume (Either a b) 140 | instance Consume a => Consume [a] 141 | 142 | 143 | instance Consume a => Consume (NonEmpty a) where 144 | consume (a :| as) = constructor 0 [consume a, consume as] 145 | 146 | instance Consume a => Consume (Tree a) where 147 | consume (Node a as) = constructor 0 [consume a, consume as] 148 | 149 | instance Consume v => Consume (Map k v) where 150 | consume = constructor 0 . fmap (consume . snd) . Map.toList 151 | 152 | consumeContainer :: (Consume a, Foldable t) => t a -> Input 153 | consumeContainer = constructor 0 . fmap consume . Fold.toList 154 | 155 | instance Consume v => Consume (Seq v) where consume = consumeContainer 156 | instance Consume v => Consume (Set v) where consume = consumeContainer 157 | instance Consume v => Consume (IntMap v) where consume = consumeContainer 158 | instance Consume IntSet where 159 | consume = consumeContainer . IntSet.toList 160 | 161 | -- TODO: instances for the rest of Containers 162 | 163 | instance (Consume a, Consume b) => Consume (a, b) 164 | instance (Consume a, Consume b, Consume c) => Consume (a, b, c) 165 | instance (Consume a, Consume b, Consume c, Consume d) => Consume (a, b, c, d) 166 | instance ( Consume a, Consume b, Consume c, Consume d, Consume e 167 | ) => Consume 168 | (a, b, c, d, e) 169 | instance ( Consume a, Consume b, Consume c, Consume d, Consume e, Consume f 170 | ) => Consume 171 | (a, b, c, d, e, f) 172 | instance ( Consume a, Consume b, Consume c, Consume d, Consume e, Consume f 173 | , Consume g 174 | ) => Consume 175 | (a, b, c, d, e, f, g) 176 | instance ( Consume a, Consume b, Consume c, Consume d, Consume e, Consume f 177 | , Consume g, Consume h 178 | ) => Consume 179 | (a, b, c, d, e, f, g, h) 180 | instance ( Consume a, Consume b, Consume c, Consume d, Consume e, Consume f 181 | , Consume g, Consume h, Consume i 182 | ) => Consume 183 | (a, b, c, d, e, f, g, h, i) 184 | instance ( Consume a, Consume b, Consume c, Consume d, Consume e, Consume f 185 | , Consume g, Consume h, Consume i, Consume j 186 | ) => Consume 187 | (a, b, c, d, e, f, g, h, i, j) 188 | instance ( Consume a, Consume b, Consume c, Consume d, Consume e, Consume f 189 | , Consume g, Consume h, Consume i, Consume j, Consume k 190 | ) => Consume 191 | (a, b, c, d, e, f, g, h, i, j, k) 192 | instance ( Consume a, Consume b, Consume c, Consume d, Consume e, Consume f 193 | , Consume g, Consume h, Consume i, Consume j, Consume k, Consume l 194 | ) => Consume 195 | (a, b, c, d, e, f, g, h, i, j, k, l) 196 | instance ( Consume a, Consume b, Consume c, Consume d, Consume e, Consume f 197 | , Consume g, Consume h, Consume i, Consume j, Consume k, Consume l 198 | , Consume m 199 | ) => Consume 200 | (a, b, c, d, e, f, g, h, i, j, k, l, m) 201 | instance ( Consume a, Consume b, Consume c, Consume d, Consume e, Consume f 202 | , Consume g, Consume h, Consume i, Consume j, Consume k, Consume l 203 | , Consume m, Consume n 204 | ) => Consume 205 | (a, b, c, d, e, f, g, h, i, j, k, l, m, n) 206 | instance ( Consume a, Consume b, Consume c, Consume d, Consume e, Consume f 207 | , Consume g, Consume h, Consume i, Consume j, Consume k, Consume l 208 | , Consume m, Consume n, Consume o 209 | ) => Consume 210 | (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o) 211 | instance ( Consume a, Consume b, Consume c, Consume d, Consume e, Consume f 212 | , Consume g, Consume h, Consume i, Consume j, Consume k, Consume l 213 | , Consume m, Consume n, Consume o, Consume p 214 | ) => Consume 215 | (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p) 216 | instance ( Consume a, Consume b, Consume c, Consume d, Consume e, Consume f 217 | , Consume g, Consume h, Consume i, Consume j, Consume k, Consume l 218 | , Consume m, Consume n, Consume o, Consume p, Consume q 219 | ) => Consume 220 | (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q) 221 | instance ( Consume a, Consume b, Consume c, Consume d, Consume e, Consume f 222 | , Consume g, Consume h, Consume i, Consume j, Consume k, Consume l 223 | , Consume m, Consume n, Consume o, Consume p, Consume q, Consume r 224 | ) => Consume 225 | (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r) 226 | instance ( Consume a, Consume b, Consume c, Consume d, Consume e, Consume f 227 | , Consume g, Consume h, Consume i, Consume j, Consume k, Consume l 228 | , Consume m, Consume n, Consume o, Consume p, Consume q, Consume r 229 | , Consume s 230 | ) => Consume 231 | (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s) 232 | instance ( Consume a, Consume b, Consume c, Consume d, Consume e, Consume f 233 | , Consume g, Consume h, Consume i, Consume j, Consume k, Consume l 234 | , Consume m, Consume n, Consume o, Consume p, Consume q, Consume r 235 | , Consume s, Consume t 236 | ) => Consume 237 | (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t) 238 | instance ( Consume a, Consume b, Consume c, Consume d, Consume e, Consume f 239 | , Consume g, Consume h, Consume i, Consume j, Consume k, Consume l 240 | , Consume m, Consume n, Consume o, Consume p, Consume q, Consume r 241 | , Consume s, Consume t, Consume u 242 | ) => Consume 243 | (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u) 244 | instance ( Consume a, Consume b, Consume c, Consume d, Consume e, Consume f 245 | , Consume g, Consume h, Consume i, Consume j, Consume k, Consume l 246 | , Consume m, Consume n, Consume o, Consume p, Consume q, Consume r 247 | , Consume s, Consume t, Consume u, Consume v 248 | ) => Consume 249 | (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v) 250 | instance ( Consume a, Consume b, Consume c, Consume d, Consume e, Consume f 251 | , Consume g, Consume h, Consume i, Consume j, Consume k, Consume l 252 | , Consume m, Consume n, Consume o, Consume p, Consume q, Consume r 253 | , Consume s, Consume t, Consume u, Consume v, Consume w 254 | ) => Consume 255 | (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w) 256 | instance ( Consume a, Consume b, Consume c, Consume d, Consume e, Consume f 257 | , Consume g, Consume h, Consume i, Consume j, Consume k, Consume l 258 | , Consume m, Consume n, Consume o, Consume p, Consume q, Consume r 259 | , Consume s, Consume t, Consume u, Consume v, Consume w, Consume x 260 | ) => Consume 261 | (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x) 262 | instance ( Consume a, Consume b, Consume c, Consume d, Consume e, Consume f 263 | , Consume g, Consume h, Consume i, Consume j, Consume k, Consume l 264 | , Consume m, Consume n, Consume o, Consume p, Consume q, Consume r 265 | , Consume s, Consume t, Consume u, Consume v, Consume w, Consume x 266 | , Consume y 267 | ) => Consume 268 | (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y) 269 | instance ( Consume a, Consume b, Consume c, Consume d, Consume e, Consume f 270 | , Consume g, Consume h, Consume i, Consume j, Consume k, Consume l 271 | , Consume m, Consume n, Consume o, Consume p, Consume q, Consume r 272 | , Consume s, Consume t, Consume u, Consume v, Consume w, Consume x 273 | , Consume y, Consume z 274 | ) => Consume 275 | (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z) 276 | -------------------------------------------------------------------------------- /src/Test/StrictCheck/Curry.hs: -------------------------------------------------------------------------------- 1 | {-| This module defines a flexible and efficient way to curry and uncurry 2 | functions of any arity. This is useful in the context of StrictCheck to 3 | provide a lightweight interface to test developers which does not require 4 | them to directly work with heterogeneous lists. 5 | -} 6 | module Test.StrictCheck.Curry 7 | ( -- * Computing the types of curried functions 8 | type (⋯->) 9 | , type (-..->) 10 | , Args 11 | , Result 12 | -- * Currying functions at all arities 13 | , Curry(..) 14 | , curryAll 15 | , uncurryAll 16 | , withCurryIdentity 17 | -- * Generalized to any heterogeneous list 18 | , List(..) 19 | ) where 20 | 21 | 22 | import Prelude hiding (curry, uncurry) 23 | 24 | import Data.Type.Equality 25 | import qualified Unsafe.Coerce as UNSAFE 26 | 27 | import qualified Generics.SOP as SOP 28 | 29 | 30 | ------------------------------------------------- 31 | -- Manipulating the types of curried functions -- 32 | ------------------------------------------------- 33 | 34 | -- | Given a function type, return a list of all its argument types 35 | -- 36 | -- For example: 37 | -- 38 | -- > Args (Int -> Bool -> Char) ~ [Int, Bool] 39 | type family Args (f :: *) :: [*] where 40 | Args (a -> rest) = a : Args rest 41 | Args x = '[] 42 | 43 | -- | Given a list of argument types and the "rest" of a function type, return a 44 | -- curried function type which takes the specified argument types in order, 45 | -- before returning the given rest 46 | -- 47 | -- For example: 48 | -- 49 | -- > [Int, Bool] ⋯-> Char ~ Int -> Bool -> Char 50 | -- 51 | -- This infix unicode symbol is meant to evoke a function arrow with an 52 | -- ellipsis. 53 | type family (args :: [*]) ⋯-> (rest :: *) :: * where 54 | '[] ⋯-> rest = rest 55 | (a : args) ⋯-> rest = a -> args ⋯-> rest 56 | 57 | -- | For those who don't want to type in unicode, we provide this ASCII synonym 58 | -- for the ellipsis function arrow @(⋯->)@ 59 | type args -..-> rest = args ⋯-> rest 60 | 61 | -- | Strip all arguments from a function type, yielding its (non-function-type) 62 | -- result 63 | -- 64 | -- For example: 65 | -- 66 | -- > Result (Int -> Bool -> Char) ~ Char 67 | type family Result (f :: *) :: * where 68 | Result (a -> rest) = Result rest 69 | Result r = r 70 | 71 | curryIdentity :: forall function. 72 | function :~: (Args function ⋯-> Result function) 73 | curryIdentity = UNSAFE.unsafeCoerce (Refl :: () :~: ()) 74 | 75 | -- | For any function type @function@, it is always true that 76 | -- 77 | -- > function ~ (Args function ⋯-> Result function) 78 | -- 79 | -- GHC doesn't know this, however, so @withCurryIdentity@ provides this proof to 80 | -- the enclosed computation, by discharging this wanted equality constraint. 81 | withCurryIdentity :: forall function r. 82 | (function ~ (Args function ⋯-> Result function) => r) -> r 83 | withCurryIdentity r = 84 | case curryIdentity @function of Refl -> r 85 | 86 | 87 | ------------------------ 88 | -- Partial uncurrying -- 89 | ------------------------ 90 | 91 | -- | This currying mechanism is agnostic to the concrete heterogeneous list type 92 | -- used to carry arguments. The @List@ class abstracts over the nil and cons 93 | -- operations of a heterogeneous list: to use your own, just define an instance. 94 | class List (list :: [*] -> *) where 95 | nil :: list '[] 96 | cons :: x -> list xs -> list (x : xs) 97 | uncons :: list (x : xs) -> (x, list xs) 98 | 99 | -- | The Curry class witnesses that for any list of arguments, it is always 100 | -- possible to curry/uncurry at that arity 101 | class Curry (args :: [*]) where 102 | uncurry 103 | :: forall result list. 104 | List list => (args ⋯-> result) -> list args -> result 105 | curry 106 | :: forall result list. 107 | List list => (list args -> result) -> args ⋯-> result 108 | 109 | instance Curry '[] where 110 | uncurry x = \(!_) -> x 111 | curry f = f nil 112 | 113 | instance Curry xs => Curry (x : xs) where 114 | uncurry f = \(uncons -> (x, xs)) -> uncurry (f x) xs 115 | curry f = \x -> curry (\xs -> f (cons x xs)) 116 | 117 | 118 | -------------------------------------------------------- 119 | -- Variadic uncurrying/currying, aka (un)curryAll-ing -- 120 | -------------------------------------------------------- 121 | 122 | -- | Uncurry all arguments to a function type 123 | -- 124 | -- This is a special case of 'uncurry', and may ease type inference. 125 | uncurryAll 126 | :: forall function list. (List list, Curry (Args function)) 127 | => function -> (list (Args function) -> Result function) 128 | uncurryAll = withCurryIdentity @function uncurry 129 | 130 | -- | Curry all arguments to a function from a heterogeneous list to a result 131 | -- 132 | -- This is a special case of 'curry', and may ease type inference. 133 | curryAll 134 | :: forall args result list. (List list, Curry args) 135 | => (list args -> result) 136 | -> (args ⋯-> result) 137 | curryAll = curry 138 | 139 | 140 | -------------------------- 141 | -- Instances for HLists -- 142 | -------------------------- 143 | 144 | instance List (SOP.NP SOP.I) where 145 | nil = SOP.Nil 146 | cons x xs = SOP.I x SOP.:* xs 147 | uncons (SOP.I x SOP.:* xs) = (x, xs) 148 | -------------------------------------------------------------------------------- /src/Test/StrictCheck/Demand.hs: -------------------------------------------------------------------------------- 1 | {-| A 'Demand' on some value of type @T@ is shaped like a @T@, but possibly 2 | truncated, to represent partial evaluation. This module defines the type of 3 | demands, and functions to manipulate them for the purpose of constructing 4 | demand specifications. 5 | 6 | A demand for some type @T@ can be represented one of two interconvertible 7 | ways: 8 | 9 | * explicitly, as a recursively interleaved @Shape@ of @T@ 10 | * implicitly, as a value of @T@ with specially-tagged bottom values 11 | which represent un-evaluated portions of that value 12 | 13 | The explicit representation is useful for writing traversals and other such 14 | manipulations of demand values, while the implicit representation can prove 15 | convenient for writing demand specifications. The implicit representation is 16 | the default when writing specifications, but through the use of 'toDemand' 17 | and 'fromDemand', either representation can be used wherever it is most 18 | appropriate. 19 | -} 20 | module Test.StrictCheck.Demand 21 | ( -- * The explicit @Demand@ interface 22 | Thunk(..) 23 | , Demand, PosDemand 24 | , pattern E, pattern T 25 | -- ** Manipulating explicit @Demand@s 26 | , evaluateDemand 27 | , shrinkDemand 28 | , prettyDemand, printDemand 29 | , eqDemand 30 | , showPrettyFieldThunkS 31 | -- * The implicit @Demand@ interface 32 | , thunk, isThunk 33 | -- * Converting between explicit and implicit representations 34 | , toDemand, fromDemand 35 | ) where 36 | 37 | import qualified Control.Exception as Exception 38 | import qualified GHC.Generics as GHC 39 | import Control.Applicative 40 | import Data.Bifunctor 41 | import System.IO.Unsafe 42 | import Data.Monoid ( Endo(..) ) 43 | import Generics.SOP hiding (Shape) 44 | 45 | import Test.StrictCheck.Shaped 46 | import Test.StrictCheck.Internal.Unevaluated 47 | 48 | -------------------------------------------------------- 49 | -- The basic types which make up a demand description -- 50 | -------------------------------------------------------- 51 | 52 | -- | A @Thunk a@ is either an @a@ or a @Thunk@ 53 | -- 54 | -- When we interleave this type into the @Shape@ of some type, we get the type 55 | -- of demands on that type. 56 | -- 57 | -- @Thunk a@ is isomorphic to a (strict) @Maybe a@. 58 | data Thunk a 59 | = Eval !a 60 | | Thunk 61 | deriving (Eq, Ord, Show, Functor, GHC.Generic) 62 | 63 | instance Applicative Thunk where 64 | pure = Eval 65 | Thunk <*> _ = Thunk 66 | _ <*> Thunk = Thunk 67 | Eval f <*> Eval a = Eval (f a) 68 | 69 | instance Num a => Num (Thunk a) where 70 | (+) = liftA2 (+) 71 | (-) = liftA2 (-) 72 | (*) = liftA2 (*) 73 | abs = fmap abs 74 | signum = fmap signum 75 | fromInteger = Eval . fromInteger 76 | 77 | -- | A @Demand@ on some type @a@ is the same shape as that original @a@, but with 78 | -- possible @Thunk@s interleaved into it 79 | type Demand 80 | = (%) Thunk 81 | 82 | -- | A @PosDemand@ is a "strictly positive" demand, i.e. one where the topmost 83 | -- level of the demanded value has definitely been forced 84 | -- 85 | -- This is the one-level unwrapping of @Demand@, and is useful to express some 86 | -- invariants in specifications 87 | type PosDemand a 88 | = Shape a Demand 89 | 90 | {-# COMPLETE E, T #-} 91 | 92 | -- | Pattern synonym to abbreviate demand manipulation: @E a = Wrap (Eval a)@ 93 | pattern E :: Shape a Demand -> Demand a 94 | pattern E a = Wrap (Eval a) 95 | 96 | -- | Pattern synonym to abbreviate demand manipulation: @T = Wrap Thunk@ 97 | pattern T :: Demand a 98 | pattern T = Wrap Thunk 99 | 100 | 101 | ------------------------ 102 | -- Implicit interface -- 103 | ------------------------ 104 | 105 | 106 | -- | A bottom value (inhabiting all types) which StrictCheck interprets as 107 | -- an unevaluated subpart of a data structure 108 | -- 109 | -- > toDemand thunk == T 110 | -- > fromDemand T == thunk 111 | thunk :: forall a. a 112 | thunk = Exception.throw Unevaluated 113 | 114 | -- | Tests if a particular value is an implicit 'thunk' 115 | -- 116 | -- In order to work, this function evaluates its input to weak-head normal form; 117 | -- keep this in mind if you care about laziness. 118 | isThunk :: Shaped a => a -> Bool 119 | isThunk a = 120 | case toDemand a of 121 | T -> True 122 | _ -> False 123 | 124 | -- | Given an @a@ whose substructures may contain 'thunk's (i.e. an implicit 125 | -- demand representation), convert it to an explicit 'Demand' 126 | -- 127 | -- Inverse to 'fromDemand'. 128 | toDemand :: Shaped a => a -> Demand a 129 | toDemand = interleave toThunk 130 | where 131 | {-# NOINLINE toThunk #-} 132 | toThunk :: a -> Thunk a 133 | toThunk a = unsafePerformIO $ 134 | Exception.catch 135 | (let !_ = a in return (Eval a)) 136 | (\(_ :: Unevaluated) -> return Thunk) 137 | 138 | -- | Given an explicit @Demand@ for some type @a@, convert it to a value of type 139 | -- @a@, substituting a 'thunk' for each 'T' found in the explicit demand 140 | -- 141 | -- Inverse to 'toDemand'. 142 | fromDemand :: Shaped a => Demand a -> a 143 | fromDemand = fuse fromThunk 144 | where 145 | {-# NOINLINE fromThunk #-} 146 | fromThunk :: Thunk a -> a 147 | fromThunk (Eval a) = a 148 | fromThunk Thunk = 149 | Exception.throw Unevaluated 150 | 151 | ----------------------- 152 | -- Shrinking demands -- 153 | ----------------------- 154 | 155 | -- | Shrink a non-zero demand (analogous to QuickCheck's @shrink@) 156 | -- 157 | -- While QuickCheck's typical @shrink@ instances reduce the size of a value by 158 | -- slicing off the top-most structure, @shrinkDemand@ reduces the size of a 159 | -- demand by pruning it's deepest /leaves/. This ensures that all resultant 160 | -- shrunken demands are strict sub-demands of the original. 161 | shrinkDemand :: forall a. Shaped a => PosDemand a -> [PosDemand a] 162 | shrinkDemand d = 163 | match @a d d $ \(Flattened un flat) _ -> 164 | un <$> shrinkOne flat 165 | where 166 | shrinkOne :: All Shaped xs => NP Demand xs -> [NP Demand xs] 167 | shrinkOne Nil = [] 168 | shrinkOne (T :* xs) = 169 | (T :*) <$> shrinkOne xs 170 | shrinkOne ((E f :: Demand x) :* xs) = 171 | fmap ((:* xs) . E) (shrinkDemand @x f) 172 | ++ fmap (E f :* ) (shrinkOne xs) 173 | 174 | 175 | ------------------------------------ 176 | -- Evaluating demands as contexts -- 177 | ------------------------------------ 178 | 179 | -- | Evaluate some value of type @a@ to the degree specified by the given demand 180 | -- 181 | -- If the demand and the value diverge (they pick a different side of a sum), 182 | -- evaluation will stop at this point. Usually, @evaluateDemand@ is only called 183 | -- on demands which are known to be structurally-compatible with the 184 | -- accompanying value, although nothing really goes wrong if this is not true. 185 | evaluateDemand :: forall a. Shaped a => PosDemand a -> a -> () 186 | evaluateDemand demand value = 187 | go @a (E demand) (I % value) 188 | where 189 | go :: forall x. Shaped x => Thunk % x -> I % x -> () 190 | go T _ = () 191 | go (E d) (Wrap (I v)) = 192 | match @x d v $ 193 | \(Flattened _ fieldsD) -> maybe () $ 194 | \(Flattened _ fieldsV) -> 195 | foldr seq () . hcollapse $ 196 | hcliftA2 (Proxy @Shaped) ((K .) . go) fieldsD fieldsV 197 | 198 | 199 | ----------------------------- 200 | -- Pretty-printing demands -- 201 | ----------------------------- 202 | 203 | -- | A very general 'showsPrec' style function for printing demands 204 | -- 205 | -- @showPrettyFieldThunkS q t p r@ returns a function @(String -> String)@ which 206 | -- appends its input to a pretty-printed representation of a demand. 207 | -- 208 | -- Specifically: 209 | -- * @q@ is a boolean flag determining if names should be printed 210 | -- as qualified 211 | -- * @t@ is a string which is to be printed when a thunk is encountered 212 | -- * @p@ is the precedence context of this function call 213 | -- * @r@ is the 'Rendered Thunk' representing some demand 214 | -- 215 | -- This is very general, but we expose it in its complexity just in case some 216 | -- person wants to build a different pretty-printer. 217 | -- 218 | -- The precedence-aware pretty-printing algorithm used here is adapted from a 219 | -- solution given by Brian Huffman on StackOverflow: 220 | -- . 221 | showPrettyFieldThunkS 222 | :: Bool -> String -> Int -> Rendered Thunk -> String -> String 223 | showPrettyFieldThunkS _ t _ (RWrap Thunk) = (t ++) 224 | showPrettyFieldThunkS qualifyNames t prec (RWrap (Eval pd)) = 225 | case pd of 226 | ConstructorD name fields -> 227 | showParen (prec > 10 && length fields > 0) $ 228 | showString (qualify name) 229 | . flip foldMapCompose fields 230 | (((' ' :) .) . showPrettyFieldThunkS qualifyNames t 11) 231 | RecordD name recfields -> 232 | showParen (prec > 10) $ 233 | showString (qualify name) 234 | . flip foldMapCompose recfields 235 | (\(fName, x) -> 236 | ((((" " ++ qualify fName ++ " = ") ++) .) $ 237 | showPrettyFieldThunkS qualifyNames t 11 x)) 238 | InfixD name assoc fixity l r -> 239 | showParen (prec > fixity) $ 240 | let (lprec, rprec) = 241 | case assoc of 242 | LeftAssociative -> (fixity, fixity + 1) 243 | RightAssociative -> (fixity + 1, fixity) 244 | NotAssociative -> (fixity + 1, fixity + 1) 245 | in showPrettyFieldThunkS qualifyNames t lprec l 246 | . showString (" " ++ qualify name ++ " ") 247 | . showPrettyFieldThunkS qualifyNames t rprec r 248 | CustomD fixity list -> 249 | showParen (prec > fixity) $ 250 | foldr (.) id $ flip fmap list $ 251 | extractEither 252 | . bimap (showString . qualifyEither) 253 | (\(f, pf) -> showPrettyFieldThunkS qualifyNames t f pf) 254 | where 255 | qualify (m, _, n) = 256 | if qualifyNames then (m ++ "." ++ n) else n 257 | 258 | qualifyEither (Left s) = s 259 | qualifyEither (Right (m, n)) = 260 | if qualifyNames then (m ++ "." ++ n) else n 261 | 262 | extractEither (Left x) = x 263 | extractEither (Right x) = x 264 | 265 | foldMapCompose :: (a -> (b -> b)) -> [a] -> (b -> b) 266 | foldMapCompose f = appEndo . foldMap (Endo . f) 267 | 268 | -- | Pretty-print a demand for display, given the precendence context 269 | prettyDemandPrec :: Shaped a => Int -> Demand a -> ShowS 270 | prettyDemandPrec prec d = 271 | showPrettyFieldThunkS False "_" prec (renderfold d) 272 | 273 | -- | Pretty-print a demand for display 274 | prettyDemand :: Shaped a => Demand a -> String 275 | prettyDemand d = prettyDemandPrec 0 d "" 276 | 277 | -- | Print a demand to standard output 278 | -- 279 | -- > printDemand = putStrLn . prettyDemand 280 | printDemand :: Shaped a => Demand a -> IO () 281 | printDemand = putStrLn . prettyDemand 282 | 283 | instance Shaped a => Show (Demand a) where 284 | showsPrec = prettyDemandPrec 285 | 286 | -- TODO: Comparisons module? 287 | 288 | -- | Determine if two demands are exactly equal 289 | -- 290 | -- This relies on the @match@ method from the @Shaped@ instance for the two 291 | -- demands, and does not require the underlying types to have @Eq@ instances. 292 | -- However, this means that types whose @match@ methods are more coarse than 293 | -- their equality will be compared differently by @eqDemand@. In particular, 294 | -- the demand representations of functions will all be compared to be equal. 295 | eqDemand :: forall a. Shaped a => Demand a -> Demand a -> Bool 296 | eqDemand T T = True 297 | eqDemand T (E _) = False 298 | eqDemand (E _) T = False 299 | eqDemand (E d1) (E d2) = 300 | match @a d1 d2 $ 301 | \(Flattened _ flatD1) -> maybe False $ 302 | \(Flattened _ flatD2) -> 303 | all id . hcollapse $ 304 | hcliftA2 (Proxy @Shaped) 305 | ((K .) . eqDemand) flatD1 flatD2 306 | 307 | -- | 'Demand's are compared for equality using 'eqDemand'; see its documentation 308 | -- for details 309 | instance Shaped a => Eq (Demand a) where 310 | (==) = eqDemand 311 | -------------------------------------------------------------------------------- /src/Test/StrictCheck/Examples/Lists.hs: -------------------------------------------------------------------------------- 1 | {-| This module defines a variety of specifications for functions on lists, 2 | demonstrating the specification interface of StrictCheck. See the 3 | documentation of "Test.StrictCheck" (specifically 'strictCheckSpecExact') 4 | for details on how to test these specifications. 5 | 6 | This module's primary utility is to teach how specifications work. Because 7 | Haddock omits the definitions of values, you'll learn the most by viewing 8 | the source of this module. 9 | -} 10 | module Test.StrictCheck.Examples.Lists where 11 | 12 | import Test.StrictCheck 13 | import Data.Functor 14 | 15 | -- * Specifying some simple functions on lists 16 | 17 | -- | A correct specification for 'length' 18 | length_spec :: Spec '[[a]] Int 19 | length_spec = 20 | Spec $ \predict _ xs -> 21 | predict (xs $> thunk) 22 | 23 | -- | A naive specification for 'take', which is wrong 24 | take_spec_too_easy :: Spec '[Int, [a]] [a] 25 | take_spec_too_easy = 26 | Spec $ \predict _d n xs -> 27 | predict n xs 28 | 29 | -- | A correct specification for 'take' 30 | take_spec :: Spec '[Int, [a]] [a] 31 | take_spec = 32 | Spec $ \predict d n xs -> 33 | predict n (if n > length xs then d else d ++ thunk) 34 | 35 | -- | A functionally correct implementation of 'take' which has subtly different 36 | -- strictness properties 37 | -- 38 | -- This will fail when tested against 'take_spec'. 39 | take' :: Int -> [a] -> [a] 40 | take' _ [] = [] 41 | take' n (x : xs) 42 | | n > 0 = x : take' (n-1) xs 43 | | otherwise = [] 44 | 45 | -- | A correct specification of '(++)' 46 | append_spec :: Shaped a => Spec '[[a], [a]] [a] 47 | append_spec = 48 | Spec $ \predict d ls rs -> 49 | let spineLen = length . cap $ d ++ [undefined] -- number of spine thunks forced 50 | overLs = spineLen > length ls -- forced all of ls? 51 | overRs = spineLen > length ls + length rs -- forced all of bs? 52 | (ls', rs') = splitAt (length ls) (cap d) 53 | in predict 54 | (ls' ++ if overLs then [] else thunk) 55 | (rs' ++ if overRs then [] else thunk) 56 | 57 | -- | A correct specification of 'reverse' 58 | reverse_spec :: Shaped a => Spec '[[a]] [a] 59 | reverse_spec = 60 | Spec $ \predict d xs -> 61 | let padLen = length xs - length (cap d) 62 | spinePad = replicate padLen thunk 63 | in predict $ spinePad ++ (reverse (cap d)) 64 | 65 | -- | A correct specification for 'zip' 66 | zip_spec :: (Shaped a, Shaped b) => Spec '[[a], [b]] [(a, b)] 67 | zip_spec = 68 | Spec $ \predict d as bs -> 69 | let (d_as, d_bs) = unzip d 70 | in predict 71 | (if length (cap d_bs) > length as 72 | && not (length (cap d_as) > length bs) 73 | then d_as 74 | else d_as ++ thunk) 75 | (if length (cap d_as) > length bs 76 | && not (length (cap d_bs) > length as) 77 | then d_bs 78 | else d_bs ++ thunk) 79 | 80 | -- | A functionally correct implementation of 'zip' which has subtly different 81 | -- strictness properties 82 | -- 83 | -- This will fail when tested against 'zip_spec'. 84 | zip' :: [a] -> [b] -> [(a, b)] 85 | zip' [ ] [ ] = [] 86 | zip' (_ : as) [ ] = zip' as [] 87 | zip' [ ] (_ : bs) = zip' [] bs 88 | zip' (a : as) (b : bs) = (a, b) : zip' as bs 89 | 90 | -- | A correct specification for 'map', demonstrating specifications for 91 | -- higher-order functions 92 | map_spec 93 | :: forall a b. (Shaped a, Shaped b) 94 | => Spec '[a -> b, [a]] [b] 95 | map_spec = 96 | Spec $ \predict d f xs -> 97 | predict 98 | (if all isThunk (cap d) then thunk else f) 99 | (zipWith (specify1 f) d xs) 100 | 101 | -- * Specifying the productive rotate function from Okasaki's purely functional 102 | -- queue implementation (see paper for more details) 103 | 104 | -- | Given three lists @xs@, @ys@, and @zs@, compute @xs ++ reverse ys ++ zs@, 105 | -- but with more uniform strictness 106 | -- 107 | -- Specifically, if @ys@ is shorter than @xs@, the work necessary to reverse it 108 | -- will have already occurred by the time @xs@ is traversed. 109 | rotate :: [a] -> [a] -> [a] -> [a] 110 | rotate [ ] [ ] as = as 111 | rotate [ ] (b : bs) as = rotate [] bs (b : as) 112 | rotate (f : fs) [ ] as = f : rotate fs [] as 113 | rotate (f : fs) (b : bs) as = f : rotate fs bs (b : as) 114 | 115 | -- | Specialization of 'rotate': @rot xs ys = rotate xs ys []@ 116 | rot :: [a] -> [a] -> [a] 117 | rot fs bs = rotate fs bs [] 118 | 119 | -- | The naive version of 'rot': @rot' xs ys = xs ++ reverse ys@ 120 | -- 121 | -- This is functionally equivalent to 'rot' but not equivalent in strictness 122 | -- behavior. 123 | rot' :: [a] -> [a] -> [a] 124 | rot' fs bs = fs ++ reverse bs 125 | 126 | -- | A previous iteration of `rot_spec'`, this one is also correct, but may be 127 | -- less readable. 128 | rot_spec :: Shaped a => Spec '[[a], [a]] [a] 129 | rot_spec = 130 | Spec $ \predict d fs bs -> 131 | let (fs', bs') = splitAt (length fs) (cap d) 132 | spineLen = length (cap (d ++ [undefined])) -- # of spine thunks forced 133 | overflow = spineLen > length fs -- begun taking from bs? 134 | overrot = length (cap d) > length bs -- forced all of bs? 135 | padLength = 136 | length bs `min` 137 | if overflow 138 | then length bs - length bs' 139 | else length (cap d) 140 | spinePad = replicate padLength thunk 141 | in predict 142 | ( fs' ++ if overflow then [] else thunk) 143 | (spinePad ++ reverse bs' ++ if overflow || overrot then [] else thunk) 144 | 145 | -- | A correct specification of `rot`, this is also the version we presented in 146 | -- the paper. 147 | rot_spec' :: Shaped a => Spec '[[a], [a]] [a] 148 | rot_spec' = 149 | Spec $ \predict d fs bs -> 150 | let demandOnFs 151 | | length (cap d) > length fs = 152 | take (length fs) (cap d) 153 | | otherwise = d 154 | demandOnBs 155 | | length (cap $ d ++ [undefined]) > length fs = 156 | reverse $ take (length bs) 157 | $ drop (length fs) (cap d) ++ repeat thunk 158 | | length (cap d) > length bs = 159 | reverse $ drop (length fs) (cap d) ++ replicate (length bs) thunk 160 | | otherwise = 161 | (reverse $ drop (length fs) (cap d) ++ replicate (length (cap d)) thunk) ++ thunk 162 | in predict demandOnFs demandOnBs 163 | -- where predictedFsDemand 164 | -- | outputDemandLength < length fs = 165 | -- outputDemand ++ thunk 166 | -- | otherwise = 167 | -- fsPartOfOutDemand 168 | -- predictedBsDemand 169 | -- | outputDemandLength < length bs = 170 | -- 171 | -- | otherwise = 172 | -- 173 | -- let (fs', bs') = splitAt (length fs) (cap d) 174 | -- spineLen = length (cap (d ++ [undefined])) -- # of spine thunks forced 175 | -- overflow = spineLen > length fs -- begun taking from bs? 176 | -- overrot = length (cap d) > length bs -- forced all of bs? 177 | -- padLength = 178 | -- length bs `min` 179 | -- if overflow 180 | -- then length bs - length bs' 181 | -- else length (cap d) 182 | -- spinePad = replicate padLength thunk 183 | -- in predict 184 | -- ( fs' ++ if overflow then [] else thunk) 185 | -- (spinePad ++ reverse bs' ++ if overflow || overrot then [] else thunk) 186 | 187 | --rot_spec' :: Shaped a => Spec '[[a], [a]] [a] 188 | --rot_spec' = rot_spec 189 | 190 | -- | An incorrect specification for `rot` that miscalculates the number of cells 191 | -- forced. 192 | rot_simple_spec :: Shaped a => Spec '[[a], [a]] [a] 193 | rot_simple_spec = 194 | Spec $ \predict d fs bs -> 195 | let demandOnFs 196 | | length (cap d) > length fs = 197 | take (length fs) d 198 | | otherwise = d 199 | demandOnBs 200 | | length (cap d) > length fs || 201 | (null bs && length fs == length (cap d) && length fs /= length (cap $ d ++ [thunk])) = 202 | reverse $ take (length bs) $ (drop (length fs) (cap d)) ++ repeat thunk 203 | | otherwise = 204 | thunk 205 | in predict demandOnFs demandOnBs 206 | 207 | test_rot :: [Int] -> [Int] -> [Int] -> IO () 208 | test_rot d xs ys = 209 | (\(x :* y :* Nil) -> printDemand x >> printDemand y) 210 | . snd $ observe (toContext d) (rot @Int) xs ys 211 | 212 | -- * Utilities for working with demands over lists 213 | 214 | -- | If the tail of the second list is 'thunk', replace it with the first list 215 | replaceThunk :: Shaped a => [a] -> [a] -> [a] 216 | replaceThunk r xs | isThunk xs = r 217 | replaceThunk _ [ ] = [] 218 | replaceThunk r (x : xs) = x : replaceThunk r xs 219 | 220 | -- | If the tail of the list is 'thunk', replace it with @[]@ 221 | -- 222 | -- This is a special case of 'replaceThunk'. 223 | cap :: Shaped a => [a] -> [a] 224 | cap = replaceThunk [] 225 | 226 | -- | Lift an ordinary function to apply to explicit 'Demand's 227 | -- 228 | -- It is true that @Demand@s are a functor, but they can't be a Haskell 229 | -- 'Functor' because they're a type family 230 | (%$) :: (Shaped a, Shaped b) => (a -> b) -> Demand a -> Demand b 231 | (%$) f = toDemand . f . fromDemand 232 | 233 | -- | Apply a 'Demand' on a function to a 'Demand' on a value 234 | -- 235 | -- It is true that @Demand@s are an applicative functor, but they can't be a 236 | -- Haskell 'Functor' because they're a type family 237 | (%*) :: (Shaped a, Shaped b) => Demand (a -> b) -> Demand a -> Demand b 238 | f %* a = toDemand $ fromDemand f (fromDemand a) 239 | 240 | -- TODO: make n-ary version of this (CPS-ed) 241 | -- | Given a unary function, an implicit demand on its result, and its input, 242 | -- compute its actual demand on its input in that context 243 | -- 244 | -- This demand is calculated using 'observe1', so it is guaranteed to be 245 | -- correct. 246 | specify1 :: forall a b. (Shaped a, Shaped b) 247 | => (a -> b) -> b -> a -> a 248 | specify1 f b a = 249 | fromDemand . snd $ observe1 (toContext b) f a 250 | 251 | -- | Given an implicit demand, convert it to an evaluation context 252 | -- 253 | -- That is, @toContext d a@ evaluates @a@ to the degree that @d@ is a defined 254 | -- value. This uses the function 'evaluateDemand'; refer to its documentation 255 | -- for details about how demands are used to evaluate values. 256 | toContext :: Shaped b => b -> b -> () 257 | toContext b = 258 | case toDemand b of 259 | T -> const () 260 | E b' -> evaluateDemand b' 261 | 262 | -- | Assert at runtime that a value is /not/ a 'thunk', failing with an error 263 | -- if it is 264 | expectTotal :: Shaped a => a -> a 265 | expectTotal a = 266 | if isThunk a then error "expectTotal: given thunk" else a 267 | -------------------------------------------------------------------------------- /src/Test/StrictCheck/Examples/Map.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell, BangPatterns, DerivingStrategies #-} 2 | 3 | {- | This module showcases another type of specification different from those in 4 | "Test.StrictCheck.Examples.Lists". Here, we demonstrate that StrictCheck is 5 | able to distinguish value-lazy maps from value-strict maps. 6 | 7 | In this module, we first develop the solution of the Knapsack dynamic 8 | programming problem by taking the fixpoint of a step function of the solution 9 | table. We represent the solution table with a map, and write a specification 10 | that is critical for the termination of this solution. 11 | -} 12 | module Test.StrictCheck.Examples.Map where 13 | 14 | import Prelude hiding (lookup) 15 | import Debug.Trace 16 | 17 | import qualified GHC.Generics as GHC 18 | import Generics.SOP (Generic, HasDatatypeInfo, NS(..), hd, tl) 19 | 20 | import Test.StrictCheck 21 | import Test.StrictCheck.TH 22 | 23 | import Data.Maybe 24 | import Data.Function 25 | 26 | import Test.QuickCheck 27 | 28 | -- | We roll our own map type to avoid dealing with abstract types. 29 | data Map k v = Bin (Map k v) k v (Map k v) -- ^ A node that contains a key value pair 30 | | Empty -- ^ An empty node 31 | deriving stock (GHC.Generic, Show, Eq, Ord) 32 | deriving anyclass (Generic, HasDatatypeInfo, Consume, Shaped) 33 | 34 | -- | A specialized map useful for knapsack. The pair of ints represent the two 35 | -- parameters to each knapsack sub-problem solved along the way. These two 36 | -- parameters determine the subsequence of items each sub-problem is concerned 37 | -- with, and the weight limit. 38 | type KMap = Map (Int, Int) Int 39 | 40 | $(derivePatternSynonyms ''Map) 41 | 42 | -- | This replaces the thunk in a map partial value with the `r` parameter. This 43 | -- is very similar to the `cap` function in the lists example. 44 | replaceThunk :: (Shaped k, Shaped v) => Map k v -> Map k v -> Map k v 45 | replaceThunk r m | isThunk m = r 46 | replaceThunk _ Empty = Empty 47 | replaceThunk r (Bin ml k v mr) = Bin (replaceThunk r ml) k v (replaceThunk r mr) 48 | 49 | -- | A helper for building a map from a list of values. 50 | fromList :: [((Int, Int), Int)] -> KMap 51 | fromList = foldr (\(k, v) acc -> insert k v acc) Empty 52 | 53 | -- | A simplified insert that ignores rebalancing since rebalancing is not 54 | -- important for the spec we will write. 55 | insert :: (Ord k) => k -> v -> Map k v -> Map k v 56 | insert key value Empty = Bin Empty key value Empty 57 | insert key value (Bin ml k v mr) | key < k = Bin (insert key value ml) k v mr 58 | | key > k = Bin ml k v (insert key value mr) 59 | | otherwise = Bin ml key value mr 60 | 61 | -- | The lookup function specialized for knapsack. 62 | lookup :: KMap -> (Int, Int) -> Maybe Int 63 | lookup Empty _ = Nothing 64 | lookup (Bin ml k' v mr) k | k == k' = Just v 65 | | k < k' = lookup ml k 66 | | otherwise = lookup mr k 67 | 68 | -- | This function extracts all of the keys of a map. 69 | keys :: Map k v -> [k] 70 | keys Empty = [] 71 | keys (Bin ml k _ mr) = keys ml ++ [k] ++ keys mr 72 | 73 | -- | A lookup function that returns the default value `0` for keys that are not 74 | -- in the map. This saves us from doing repeated pattern matching when querying 75 | -- the solution table. 76 | (!) :: KMap -> (Int, Int) -> Int 77 | (!) m k = case lookup m k of 78 | Nothing -> 0 79 | Just v -> v 80 | 81 | -- | Weight parameters to the knapsack problem. 82 | weights :: [Int] 83 | weights = [10, 20, 30] 84 | 85 | -- | Value parameters to the knapsack problem, note that this must be the same 86 | -- length as `weights`. 87 | values :: [Int] 88 | values = [60, 100, 120] 89 | 90 | -- | The weight limit of the knapsack problem. 91 | limit :: Int 92 | limit = 50 93 | 94 | -- | One step of the knapsack computation. This is a direct translation from the 95 | -- recurrence relation of the knapsack problem. 96 | solutionStep :: Map (Int, Int) Int -> Map (Int, Int) Int 97 | solutionStep soln = 98 | fromList [((j, k), knapsack j k) | j <- [0 .. length weights-1], k <- [0 .. limit]] 99 | where 100 | knapsack j k = if j - 1 < 0 || k - weights !! j < 0 101 | then if j >= 0 && weights !! j <= k then values !! j else 0 102 | else max (soln ! (j-1, k)) 103 | (soln ! (j-1, k - weights !! j) + values !! j) 104 | 105 | -- | The fixpoint of the recurrence relation, which is also the solution for the 106 | -- knapsack problem. 107 | solution :: Map (Int, Int) Int 108 | solution = fix solutionStep 109 | 110 | -- | A pattern synonym for extracting demands of each component from the demand 111 | -- of a pair. 112 | pattern Pair' :: Demand a -> Demand b -> Demand (a, b) 113 | pattern Pair' x y = Wrap (Eval (GS (Z (x :* y :* Nil)))) 114 | 115 | -- | This function computes the nth pre-fixpoint of the knapsack solution, and 116 | -- looks up the value at the specified cell from the pre-fixpoint. 117 | iterSolution :: (Int, Int) -> Int -> Map (Int, Int) Int -> Maybe Int 118 | iterSolution k n soln = lookup m k 119 | where m | n <= 0 = soln 120 | | otherwise = (iterate solutionStep soln) !! n 121 | 122 | -- | This is the same as `iterSolution`, but uses a newtype wrapper for the 123 | -- index into the map since we want to write a customized `Arbitrary` instance 124 | -- for `Key`. 125 | iterSolutionWithKey :: Key -> Int -> Map (Int, Int) Int -> Maybe Int 126 | iterSolutionWithKey (Key k) = iterSolution k 127 | 128 | -- | The newtype wrapper of index into the knapsack solution table. 129 | newtype Key = Key { getKey :: (Int, Int) } 130 | deriving stock (GHC.Generic, Show, Eq, Ord) 131 | deriving anyclass (Generic, HasDatatypeInfo, Consume, Shaped) 132 | 133 | -- | The customized generator for `Key` that only generates valid keys given the 134 | -- problem parameters. 135 | instance Arbitrary Key where 136 | -- Just to make sure keys are within the parameters of the problem 137 | arbitrary = fmap Key $ 138 | (,) <$> elements [0 .. length weights - 1] <*> elements [0 .. limit] 139 | 140 | -- | The customized generator for solution tables that only generates valid 141 | -- pre-fixpoints. 142 | instance Arbitrary KMap where 143 | -- I need to generate only valid pre-fixpoints, which is either 144 | -- Empty (iterated 0 times), or iterate once on Empty, or twice, and 145 | -- so on 146 | arbitrary = do 147 | NonNegative n <- arbitrary 148 | return $ (iterate solutionStep Empty) !! n 149 | 150 | -- | A dummy produce instance for the solution table. 151 | instance Produce KMap where 152 | -- I don't need lazy functions on KMaps. Since the spec only checks 153 | -- whether a particular entry in the KMap is evaluated or not. 154 | produce = arbitrary 155 | 156 | -- | A dummy produce instance for the index into the solution table. 157 | instance Produce Key where 158 | -- I don't need lazy functions on keys either. 159 | produce = arbitrary 160 | 161 | -- | This IO action ties the spec together with everything built so far, and 162 | -- runs the StrictCheck randomized testing framework. 163 | runMapTest :: IO () 164 | runMapTest = strictCheckWithResults 165 | stdArgs{maxSize=100, maxSuccess=1000} 166 | shrinkViaArbitrary 167 | genViaProduce 168 | strictnessViaSized 169 | iterSolution_spec 170 | iterSolutionWithKey >>= print 171 | 172 | -- | This is the specification that establishes a property important for the 173 | -- termination of `solution`: given any pre-fixpoint of `pre-solution`, forcing 174 | -- the value at pre-solution[i][j] should not induce a demand at the (i, j) cell 175 | -- of the input that steps to pre-solution, since otherwise this would be an 176 | -- infinite loop in the fixpoint. 177 | -- The value-lazy `Map` defined in this module satisfies this property. However, 178 | -- if we make this `Map` value-strict using BangPatterns, StrictCheck will 179 | -- report a failure when `runMapTest` is executed. 180 | iterSolution_spec :: Evaluation '[Key, Int, KMap] (Maybe Int) -> Maybe (Int, Int) 181 | iterSolution_spec (Evaluation args demands dOut) = 182 | let I (Key evalK) = hd args 183 | I nIter = hd (tl args) 184 | dInM = hd (tl (tl demands)) 185 | inM = replaceThunk Empty (fromDemand @KMap dInM) 186 | evalV = lookup inM evalK 187 | in if (inM == Empty) || 188 | isBaseCase evalK || 189 | nIter <= 0 || 190 | isThunk evalV || 191 | isNothing evalV 192 | then Nothing 193 | else trace ("KeyD: " ++ show evalK) $ 194 | trace ("InD: " ++ prettyDemand dInM) $ 195 | trace ("OutD: " ++ prettyDemand @(Maybe Int) (E dOut)) $ 196 | trace ("isT: " ++ (show . isThunk $ lookup inM evalK)) $ 197 | Just evalK 198 | where isBaseCase (j, k) = j - 1 < 0 || k - weights !! j < 0 199 | -------------------------------------------------------------------------------- /src/Test/StrictCheck/Internal/Inputs.hs: -------------------------------------------------------------------------------- 1 | {-| __Internal module__: This module does not make any stability guarantees, and 2 | may not adhere to the PVP. 3 | 4 | This module implements the rose-tree data structure used by StrictCheck to 5 | monomorphize inputs to functions. We decouple the consumption of input from 6 | the production of output by converting any input to an @Input@: a lazily 7 | constructed rose tree with nodes each containing a @(Gen a -> Gen a)@ which 8 | captures a random perturbation associated with the shape of the value 9 | consumed. The tree-shape of an @Input@ matches that of the entire consumed 10 | value, and evaluating any subpart of it forces the evaluation of the 11 | corresponding part of the original value. 12 | -} 13 | module Test.StrictCheck.Internal.Inputs 14 | ( Variant(..) 15 | , Input(..) 16 | , Inputs(..) 17 | , draw 18 | , destruct 19 | ) where 20 | 21 | import Test.QuickCheck (Gen) 22 | 23 | 24 | -------------------------------------------------- 25 | -- The core user-facing types: Input and Inputs -- 26 | -------------------------------------------------- 27 | 28 | -- | A variant which can be applied to any generator--kept in a newtype to get 29 | -- around lack of impredicativity. 30 | newtype Variant 31 | = Variant { vary :: forall a. Gen a -> Gen a } 32 | 33 | instance Semigroup Variant where 34 | v <> w = Variant (vary v . vary w) 35 | 36 | instance Monoid Variant where 37 | mappend = (<>) 38 | mempty = Variant id 39 | 40 | -- | A tree representing all possible destruction sequences for a value 41 | -- Unfolding the contained lists forces a particular random control path 42 | -- for destructing the datatype. 43 | data Input 44 | = Input Variant [Input] -- ^ Not exposed in safe API 45 | 46 | -- | A list of inputs given to a function, in abstract form. This lazy structure 47 | -- is evaluated piecewise during the course of producing a function, thus 48 | -- triggering the partial evaluation of the original input to the function. 49 | newtype Inputs 50 | = Inputs [Input] -- ^ Not exposed in safe API 51 | 52 | -- | Extract the list of @Input@s from an @Inputs@ 53 | destruct :: Inputs -> [Input] 54 | destruct (Inputs is) = is 55 | 56 | -- | Extract the entropy and subfield-@Input@s from a given @Input@ 57 | draw :: Input -> (Variant, [Input]) 58 | draw (Input v is) = (v, is) 59 | -------------------------------------------------------------------------------- /src/Test/StrictCheck/Internal/Omega.hs: -------------------------------------------------------------------------------- 1 | {-| __Internal module__: This module does not make any stability guarantees, and 2 | may not adhere to the PVP. 3 | 4 | This module defines the 'Omega' type, which has only one inhabitant: the 5 | infinite chain of successors. Any function which consumes an @Omega@ is 6 | functionally equivalent to any other; likewise for those which produce an 7 | @Omega@. However, they may have radically differing strictness behaviors. It 8 | is for this reason that we have use for this type in the course of random 9 | example generation. 10 | -} 11 | module Test.StrictCheck.Internal.Omega 12 | ( Omega(..) 13 | , forceOmega 14 | ) where 15 | 16 | import Test.StrictCheck.Produce 17 | import Test.StrictCheck.Shaped 18 | 19 | import qualified GHC.Generics as GHC 20 | import Generics.SOP 21 | 22 | -- | The type with one inhabitant: the infinite chain of successors 23 | data Omega = Succ Omega 24 | deriving (GHC.Generic, Generic, HasDatatypeInfo, Shaped) 25 | 26 | instance Produce Omega where 27 | produce = Succ <$> recur 28 | 29 | -- | Evaluate @n@ constructors of a given @Omega@ value, returning unit 30 | forceOmega :: Int -> Omega -> () 31 | forceOmega n o 32 | | n <= 0 33 | = () 34 | | Succ o' <- o 35 | = forceOmega (n - 1) o' 36 | -------------------------------------------------------------------------------- /src/Test/StrictCheck/Internal/Shrink.hs: -------------------------------------------------------------------------------- 1 | {-| __Internal module__: This module does not make any stability guarantees, and 2 | may not adhere to the PVP. 3 | 4 | This module defines several utilities useful for shrinking demands and 5 | evaluations. 6 | 7 | Of these, only 'axialShrinks' and 'fairInterleave' are used by StrictCheck; 8 | nevertheless, we expose the 'DZipper' type and its associated functions in 9 | this internal module just in case. 10 | -} 11 | module Test.StrictCheck.Internal.Shrink 12 | ( Shrink(..) 13 | , axialShrinks 14 | , fairInterleave 15 | -- * CPS-based zippers through heterogeneous products 16 | , DZipper(..) 17 | , next 18 | , positions 19 | , dzipper 20 | , dzip 21 | ) where 22 | 23 | import Generics.SOP 24 | import Data.Functor.Product 25 | 26 | -- Fair n-ary axial shrinking (a.k.a. *fair* generalization of shrink on tuples) 27 | 28 | -- | Newtype allowing us to construct 'NP' n-ary products of shrinkers 29 | newtype Shrink a 30 | = Shrink (a -> [a]) 31 | 32 | -- | A @DZipper@ is a suspended traversal through a non-empty 'NP' n-ary product 33 | -- 34 | -- The position of the traversal within that product is existentially 35 | -- quantified. 36 | data DZipper f whole where 37 | DZipper :: (NP f (c : rs) -> NP f whole) 38 | -> f c 39 | -> NP f rs 40 | -> DZipper f whole 41 | 42 | -- | Step one to the right in a @DZipper@, returning @Nothing@ if this is not 43 | -- possible 44 | next :: DZipper f whole -> Maybe (DZipper f whole) 45 | next (DZipper _ _ Nil) = Nothing 46 | next (DZipper ls c (r :* rs')) = 47 | Just $ DZipper (ls . (c :*)) r rs' 48 | 49 | -- | Given an n-ary product of @xs@, get a list of @DZipper@s, each focused in 50 | -- sequence on the values of the input product 51 | -- 52 | -- This is similar to the @duplicate@ operation on comonads. 53 | positions :: NP f xs -> [DZipper f xs] 54 | positions (dzipper -> mstart) = 55 | maybe [] go mstart 56 | where 57 | go start = start : maybe [] go (next start) 58 | 59 | -- | Convert an n-ary product into a @DZipper@, returning @Nothing@ if the 60 | -- input product is empty 61 | dzipper :: NP f xs -> Maybe (DZipper f xs) 62 | dzipper Nil = Nothing 63 | dzipper (c :* rs) = Just $ DZipper id c rs 64 | 65 | -- | Collapse a @DZipper@ back into the n-ary product it represents 66 | dzip :: DZipper f xs -> NP f xs 67 | dzip (DZipper ls c rs) = ls (c :* rs) 68 | 69 | -- | Given a list of shrinkers and a list of values-to-be-shrunk, generate 70 | -- a list of shrunken lists-of-values, each inner list being one potential 71 | -- "axis" for shrinking 72 | -- 73 | -- That is, the first element of the result is all the ways the original 74 | -- product could be shrunken by /only/ shrinking its first component, etc. 75 | axialShrinks :: SListI xs => NP Shrink xs -> NP I xs -> [[NP I xs]] 76 | axialShrinks shrinks xs = 77 | fmap (hliftA (\(Pair _ v) -> v) . dzip) 78 | . centerIter <$> positions withShrinks 79 | where 80 | iter (Pair (Shrink s) (I v)) = 81 | Pair (Shrink s) . I <$> (s v) 82 | 83 | centerIter (DZipper ls c rs) = 84 | map (\c' -> DZipper ls c' rs) (iter c) 85 | 86 | withShrinks = 87 | hliftA2 Pair shrinks xs 88 | 89 | -- | Fairly interleave a list of lists in a round-robin fashion 90 | fairInterleave :: [[a]] -> [a] 91 | fairInterleave = roundRobin id 92 | where 93 | roundRobin k ((x : xs) : xss) = x : roundRobin (k . (xs :)) xss 94 | roundRobin k ([ ] : xss) = roundRobin k xss 95 | roundRobin k [ ] = 96 | case k [] of 97 | [ ] -> [] 98 | xss -> roundRobin id xss 99 | -------------------------------------------------------------------------------- /src/Test/StrictCheck/Internal/Unevaluated.hs: -------------------------------------------------------------------------------- 1 | {-| __Internal module__: This module does not make any stability guarantees, and 2 | may not adhere to the PVP. 3 | 4 | This module defines the internal exception type used to implement the 5 | to/from-Demand methods in "Test.StrictCheck.Demand". We don't export this 6 | type from the library to discourage users from interacting with this 7 | mechanism. 8 | -} 9 | 10 | module Test.StrictCheck.Internal.Unevaluated 11 | ( Unevaluated(..) 12 | ) where 13 | 14 | import Control.Exception 15 | 16 | -- | In @fromDemand@, this exception is (purely, lazily) thrown whenever a 17 | -- @Thunk@ is encountered. In @toDemand@, it is caught and converted back to a 18 | -- @Thunk@. 19 | data Unevaluated 20 | = Unevaluated 21 | deriving Show 22 | 23 | instance Exception Unevaluated 24 | -------------------------------------------------------------------------------- /src/Test/StrictCheck/Observe.hs: -------------------------------------------------------------------------------- 1 | {-| This module implements the core "trick" of StrictCheck: observing the 2 | demand behavior of a function in a purely functional way. 3 | 4 | All the functions in this module are safe and referentially transparent. 5 | 6 | Observing the evaluation of a function using these functions incurs at most 7 | a small constant multiple of overhead compared to just executing the function 8 | with no observation. 9 | -} 10 | module Test.StrictCheck.Observe 11 | ( observe1 12 | , observe 13 | , observeNP 14 | ) where 15 | 16 | import Data.Bifunctor 17 | import Data.Functor.Product 18 | 19 | import Generics.SOP hiding (Shape) 20 | 21 | import Test.StrictCheck.Curry hiding (curry, uncurry) 22 | import Test.StrictCheck.Shaped 23 | import Test.StrictCheck.Observe.Unsafe 24 | import Test.StrictCheck.Demand 25 | 26 | ------------------------------------------------------ 27 | -- Observing demand behavior of arbitrary functions -- 28 | ------------------------------------------------------ 29 | 30 | -- | Observe the demand behavior 31 | -- 32 | -- * in a given evaluation context, 33 | -- * of a given __unary function__, 34 | -- * called upon a given input, 35 | -- 36 | -- returning a pair of 37 | -- 38 | -- * the demand on its output exerted by the evaluation context, and 39 | -- * the demand on its input this induced 40 | -- 41 | -- Suppose we want to see how strict @reverse@ is when we evaluate its result 42 | -- to weak-head normal form: 43 | -- 44 | -- >>> (b, a) = observe1 (`seq` ()) (reverse @Int) [1, 2, 3] 45 | -- >>> printDemand b -- output demand 46 | -- _ : _ 47 | -- >>> printDemand a -- input demand 48 | -- _ : _ : _ : _ : [] 49 | -- 50 | -- This tells us that our context did indeed evaluate the result of @reverse@ 51 | -- to force only its first constructor, and that doing so required the entire 52 | -- spine of the list to be evaluated, but did not evaluate any of its elements. 53 | {-# NOINLINE observe1 #-} 54 | observe1 55 | :: (Shaped a, Shaped b) 56 | => (b -> ()) -> (a -> b) -> a -> (Demand b, Demand a) 57 | observe1 context function input = 58 | let (input', inputD) = 59 | instrument input -- (1) 60 | (result', resultD) = 61 | instrument (function input') -- (2) 62 | in let !_ = context result' -- (3) 63 | in (resultD, inputD) -- (4) 64 | 65 | -- NOTE: The observation function: 66 | -- (1) instruments the input 67 | -- (2) instruments the result of the function applied to the input 68 | -- (3) evaluates the instrumented result of the function in the context, and 69 | -- (4) returns the observed demands on the result and the input. 70 | 71 | -- | Observe the demand behavior 72 | -- 73 | -- * in a given evaluation context 74 | -- * of a given __uncurried n-ary function__ (taking as input an n-ary 75 | -- product of inputs represented as an 'NP' 'I' from "Generics.SOP") 76 | -- * called upon all of its inputs (provided as curried ordinary inputs), 77 | -- 78 | -- returning a pair of 79 | -- 80 | -- * the demand on its output exerted by the evaluation context, and 81 | -- * the demands on its inputs this induced, represented as an 'NP' 'Demand' 82 | -- from "Generics.SOP" 83 | -- 84 | -- This is mostly useful for implementing the internals of StrictCheck; 85 | -- 'observe' is more ergonomic for exploration by end-users. 86 | {-# NOINLINE observeNP #-} 87 | observeNP 88 | :: (All Shaped inputs, Shaped result) 89 | => (result -> ()) 90 | -> (NP I inputs -> result) 91 | -> NP I inputs 92 | -> ( Demand result 93 | , NP Demand inputs ) 94 | observeNP context function inputs = 95 | let entangled = 96 | hcliftA 97 | (Proxy @Shaped) 98 | (uncurry Pair . first I . instrument . unI) 99 | inputs 100 | (inputs', inputsD) = 101 | (hliftA (\(Pair r _) -> r) entangled, 102 | hliftA (\(Pair _ l) -> l) entangled) 103 | (result', resultD) = instrument (function inputs') 104 | in let !_ = context result' 105 | in (resultD, inputsD) 106 | 107 | -- | Observe the demand behavior 108 | -- 109 | -- * in a given evaluation context 110 | -- * of a given __curried n-ary function__ 111 | -- * called upon all of its inputs (provided as curried ordinary inputs), 112 | -- 113 | -- returning a pair of 114 | -- 115 | -- * the demand on its output exerted by the evaluation context, and 116 | -- * the demands on its inputs this induced, represented as an 'NP' 'Demand' 117 | -- from "Generics.SOP" 118 | -- 119 | -- This function is variadic and curried: it takes @n + 2@ arguments, where 120 | -- @n@ is the total number of arguments taken by the observed function. 121 | -- 122 | -- Suppose we want to see how strict @zipWith (*)@ is when we evaluate its 123 | -- result completely (to normal form): 124 | -- 125 | -- >>> productZip = zipWith ((*) @Int) 126 | -- >>> (zs, (xs :* ys :* Nil)) = observe normalize productZip [10, 20] [30, 40] 127 | -- >>> printDemand zs -- output demand 128 | -- 300 : 800 : [] 129 | -- >>> printDemand xs -- input demand #1 130 | -- 10 : 20 : [] 131 | -- >>> printDemand ys -- input demand #2 132 | -- 30 : 40 : _ 133 | -- 134 | -- If you haven't thought very carefully about the strictness behavior of @zip@, 135 | -- this may be a surprising result; this is part of the fun! 136 | observe 137 | :: ( All Shaped (Args function) 138 | , Shaped (Result function) 139 | , Curry (Args function) ) 140 | => (Result function -> ()) 141 | -> function 142 | -> Args function 143 | ⋯-> ( Demand (Result function) 144 | , NP Demand (Args function) ) 145 | observe context function = 146 | curryAll (observeNP context (uncurryAll function)) 147 | 148 | -- NOTE: We don't need a NOINLINE annotation here because this wraps observeNP. 149 | -------------------------------------------------------------------------------- /src/Test/StrictCheck/Observe/Unsafe.hs: -------------------------------------------------------------------------------- 1 | {-| This module defines the underlying __unsafe__ primitives StrictCheck uses 2 | to implement purely functional observation of evaluation. 3 | 4 | The "functions" in this module are __not referentially transparent__! 5 | -} 6 | module Test.StrictCheck.Observe.Unsafe where 7 | 8 | import System.IO.Unsafe 9 | import Data.IORef 10 | 11 | import Data.Bifunctor 12 | import Generics.SOP (I(..), unI) 13 | 14 | import Test.StrictCheck.Shaped 15 | import Test.StrictCheck.Demand 16 | 17 | -- | From some value of any type, produce a pair: a copy of the original value, 18 | -- and a 'Thunk' of that same type, with their values determined by the 19 | -- /order/ in which their values themselves are evaluated 20 | -- 21 | -- If the copy of the value is evaluated to weak-head normal form before the 22 | -- returned @Thunk@, then any future inspection of the @Thunk@ will show that it 23 | -- is equal to the original value wrapped in an @Eval@. However, if the copy of 24 | -- the value is /not/ evaluated by the time the @Thunk@ is evaluated, any future 25 | -- inspection of the @Thunk@ will show that it is equal to @Thunk@. 26 | -- 27 | -- A picture may be worth 1000 words: 28 | -- 29 | -- >>> x = "hello," ++ " world" 30 | -- >>> (x', t) = entangle x 31 | -- >>> x' 32 | -- "hello, world" 33 | -- >>> t 34 | -- Eval "hello, world" 35 | -- 36 | -- >>> x = "hello," ++ " world" 37 | -- >>> (x', t) = entangle x 38 | -- >>> t 39 | -- Thunk 40 | -- >>> x' 41 | -- "hello, world" 42 | -- >>> t 43 | -- Thunk 44 | {-# NOINLINE entangle #-} 45 | entangle :: forall a. a -> (a, Thunk a) 46 | entangle a = 47 | unsafePerformIO $ do 48 | ref <- newIORef Thunk 49 | return ( unsafePerformIO $ do 50 | writeIORef ref (Eval a) 51 | return a 52 | , unsafePerformIO $ readIORef ref ) 53 | 54 | -- | Recursively 'entangle' an @a@, producing not merely a @Thunk@, but an 55 | -- entire @Demand@ which is piecewise entangled with that value. Whatever 56 | -- portion of the entangled value is evaluated before the corresponding portion 57 | -- of the returned @Demand@ will be represented in the shape of that @Demand@. 58 | -- However, any part of the returned @Demand@ which is evaluated before the 59 | -- corresponding portion of the entangled value will be forever equal to 60 | -- @Thunk@. 61 | -- 62 | -- The behavior of this function is even more tricky to predict than that of 63 | -- 'entangle', especially when evaluation of the entangled value and the 64 | -- corresponding @Demand@ happen at the same time. In StrictCheck, all 65 | -- evaluation of the entangled value occurs before any evaluation of the 66 | -- @Demand@; we never interleave their evaluation. 67 | {-# NOINLINE instrument #-} 68 | instrument :: Shaped a => a -> (a, Demand a) 69 | instrument = 70 | first (fuse unI) 71 | . unzipWith entangle' 72 | . interleave I 73 | where 74 | entangle' :: I x -> (I x, Thunk x) 75 | entangle' = 76 | first I . entangle . unI 77 | -------------------------------------------------------------------------------- /src/Test/StrictCheck/Produce.hs: -------------------------------------------------------------------------------- 1 | {-| This module defines the 'Produce' typeclass, used for generating random 2 | values for testing in StrictCheck. 3 | 4 | 'Produce' is a strict generalization of "Test.QuickCheck"'s 'Arbitrary' 5 | typeclass. Paired with 'Consume' (a generalization of 'CoArbitrary') it can 6 | be used to create random non-strict functions, whose strictness behavior is 7 | dependent on the values given to them. 8 | -} 9 | 10 | module Test.StrictCheck.Produce 11 | ( Produce(..) 12 | -- * Tools for writing 'Produce' instances 13 | , recur 14 | , build 15 | -- * Producing non-strict functions 16 | , returning 17 | , variadic 18 | -- * Integration with "Test.QuickCheck"'s @Arbitrary@ 19 | , Lazy(..) 20 | , freely 21 | -- * Abstract types representing input to a function 22 | , Input 23 | , Inputs 24 | -- * The traversal distribution for processing @Input@s 25 | , draws 26 | ) where 27 | 28 | import Test.QuickCheck hiding (variant) 29 | import Test.QuickCheck.Gen.Unsafe 30 | 31 | import Test.StrictCheck.Internal.Inputs 32 | import Test.StrictCheck.Consume 33 | import Test.StrictCheck.Curry 34 | 35 | import Generics.SOP 36 | import Data.Complex 37 | import Data.Monoid ((<>)) 38 | 39 | 40 | ------------------------------------------------------- 41 | -- The user interface for creating Produce instances -- 42 | ------------------------------------------------------- 43 | 44 | -- TODO: parameterize over destruction pattern? 45 | 46 | -- | Produce an arbitrary value of type @b@, such that destructing that value 47 | -- incrementally evaluates some input to a function. 48 | -- 49 | -- Writing instances of @Produce@ is very similar to writing instances of 50 | -- QuickCheck's 'Arbitrary'. The distinction: when making a recursive call to 51 | -- produce a subfield of a structure, __always__ use 'build' or 'recur', and 52 | -- __never__ a direct call to 'produce' itself. This ensures that the input can 53 | -- potentially be demanded at any step of evaluation of the produced value. 54 | -- 55 | -- If, in the course of generating a value of type @b@, you need to generate a 56 | -- random value of some other type, which is /not/ going to be a subpart of the 57 | -- resultant @b@ (e.g. a length or depth), use a direct call to @arbitrary@ or 58 | -- some other generator which does not consume input. 59 | -- 60 | -- An example instance of @Produce@: 61 | -- 62 | -- > data D a 63 | -- > = X a 64 | -- > | Y [Int] 65 | -- > 66 | -- > instance Produce a => Produce (D a) where 67 | -- > produce = 68 | -- > oneof [ fmap X recur 69 | -- > , fmap Y recur 70 | -- > ] 71 | class Produce b where 72 | produce :: (?inputs::Inputs) => Gen b 73 | 74 | theInputs :: (?inputs::Inputs) => [Input] 75 | theInputs = destruct ?inputs 76 | 77 | -- | Given an input-consuming producer, wrap it in an outer layer of input 78 | -- consumption, so that this consumption can be interleaved when the producer is 79 | -- called recursively to generate a subfield of a larger produced datatype. 80 | build :: (?inputs::Inputs) => ((?inputs::Inputs) => Gen a) -> Gen a 81 | build gen = do 82 | (v, is') <- draws theInputs 83 | vary v $ let ?inputs = Inputs is' in gen 84 | 85 | -- | Destruct some inputs to generate an output. This function handles the 86 | -- interleaving of input destruction with output construction. When producing a 87 | -- data type, it should be called to produce each subfield -- *not* produce 88 | -- itself. 89 | recur :: (Produce a, ?inputs::Inputs) => Gen a 90 | recur = build produce 91 | 92 | 93 | --------------------------------------- 94 | -- How to make random lazy functions -- 95 | --------------------------------------- 96 | 97 | -- NOTE: This instance must be defined in this module, as it has to break the 98 | -- abstraction of the Inputs type. No other instance needs to break this. 99 | -- Incidentally, it also must break Gen's abstraction barrier, because it needs 100 | -- to use promote to make a function. 101 | 102 | instance (Consume a, Produce b) => Produce (a -> b) where 103 | produce = returning produce 104 | 105 | -- | Create an input-consuming producer of input-consuming functions, given an 106 | -- input-consuming producer for results of that function. 107 | returning 108 | :: (Consume a, ?inputs::Inputs) 109 | => ((?inputs::Inputs) => Gen b) 110 | -> Gen (a -> b) 111 | returning out = 112 | promote $ \a -> 113 | let ?inputs = Inputs (consume a : theInputs) 114 | in build out 115 | 116 | -- | Create an input-consuming producer of input-consuming functions, of any 117 | -- arity. This will usually be used in conjuntion with type application, to 118 | -- specify the type(s) of the argument(s) to the function. 119 | variadic :: 120 | forall args result. 121 | (All Consume args, Curry args, ?inputs::Inputs) 122 | => ((?inputs::Inputs) => Gen result) 123 | -> Gen (args ⋯-> result) 124 | variadic out = 125 | fmap (curryAll @args @_ @(NP I)) . promote $ \args -> 126 | let ?inputs = 127 | Inputs . (++ theInputs) $ 128 | hcollapse $ hcliftA (Proxy @Consume) (K . consume . unI) args 129 | in build out 130 | 131 | 132 | ------------------------------------------------------------------------- 133 | -- Random destruction of the original input, as transformed into Input -- 134 | ------------------------------------------------------------------------- 135 | 136 | -- | Destruct a random subpart of the given 'Input's, returning the 'Variant' 137 | -- corresponding to the combined information harvested during this process, and 138 | -- the remaining "leaves" of the inputs yet to be destructed 139 | -- 140 | -- To maximize the likelihood that different random consumption paths through 141 | -- the same value will diverge (desirable when generating functions with 142 | -- interesting strictness), @draws@ destructs the forest of @Input@s as a 143 | -- depth-first random traversal with a budget sampled from a geometric 144 | -- distribution with expectation 1. 145 | draws :: [Input] -> Gen (Variant, [Input]) 146 | draws inputs = go [inputs] 147 | where 148 | -- Mutually recursive: 149 | go, inwardFrom :: [[Input]] -> Gen (Variant, [Input]) 150 | 151 | go levels = 152 | oneof -- 50% choice between: 153 | [ return (mempty, concat levels) -- stop consuming input, or 154 | , inwardFrom levels ] -- keep consuming input 155 | 156 | inwardFrom levels = 157 | case levels of 158 | [ ] -> return mempty -- if no more input: stop 159 | [ ] : outside -> inwardFrom outside -- if nothing here: backtrack 160 | here : outside -> do -- if something here: go deeper 161 | (Input v inside, here') <- pick here 162 | vary v $ do 163 | (entropy, levels') <- go (inside : here' : outside) -- back to 'go' 164 | return (v <> entropy, levels') 165 | 166 | -- Pick a random list element and the remaining list 167 | pick :: [a] -> Gen (a, [a]) 168 | pick as = do 169 | index <- choose (0, length as - 1) 170 | let (before, picked : after) = splitAt index as 171 | return (picked, before ++ after) 172 | 173 | 174 | 175 | --------------------------------------------- 176 | -- Integration with QuickCheck's Arbitrary -- 177 | --------------------------------------------- 178 | 179 | -- | We hook into QuickCheck's existing Arbitrary infrastructure by using 180 | -- a newtype to differentiate our special way of generating things. 181 | newtype Lazy a 182 | = Lazy { runLazy :: a } 183 | 184 | instance Produce a => Arbitrary (Lazy a) where 185 | arbitrary = Lazy <$> freely produce 186 | 187 | -- | Actually produce an output, given an input-consuming producer. If a 188 | -- function is to be produced, it will be almost-certainly non-strict. 189 | freely :: ((?inputs::Inputs) => Gen a) -> Gen a 190 | freely p = let ?inputs = Inputs [] in p 191 | 192 | 193 | --------------- 194 | -- Instances -- 195 | --------------- 196 | 197 | instance Produce () where produce = arbitrary 198 | instance Produce Bool where produce = arbitrary 199 | instance Produce Ordering where produce = arbitrary 200 | 201 | instance Produce Char where produce = arbitrary 202 | instance Produce Word where produce = arbitrary 203 | instance Produce Int where produce = arbitrary 204 | instance Produce Double where produce = arbitrary 205 | instance Produce Float where produce = arbitrary 206 | instance Produce Rational where produce = arbitrary 207 | instance Produce Integer where produce = arbitrary 208 | 209 | instance (Arbitrary a, RealFloat a) => Produce (Complex a) where 210 | produce = arbitrary 211 | 212 | instance Produce a => Produce (Maybe a) where 213 | produce = 214 | oneof [ return Nothing 215 | , Just <$> recur 216 | ] 217 | 218 | instance (Produce a, Produce b) => Produce (Either a b) where 219 | produce = 220 | oneof [ Left <$> recur 221 | , Right <$> recur 222 | ] 223 | 224 | instance (Produce a) => Produce [a] where 225 | produce = 226 | frequency [ (1, return []) 227 | , (1, (:) <$> recur 228 | <*> recur) 229 | ] 230 | -------------------------------------------------------------------------------- /src/Test/StrictCheck/Shaped.hs: -------------------------------------------------------------------------------- 1 | {-# language InstanceSigs, DerivingStrategies #-} 2 | {-# language PartialTypeSignatures #-} 3 | {-# OPTIONS_GHC -fno-warn-partial-type-signatures #-} 4 | {-| This module defines the 'Shaped' typeclass, which is used to generically 5 | manipulate values as fixed-points of higher-order functors in order to 6 | analyze their structure, e.g. while observing evaluation. 7 | 8 | If you just care about testing the strictness of functions over datatypes 9 | which are already instances of @Shaped@, you don't need to use this module. 10 | 11 | __Important note:__ To define new instances of 'Shaped' for types which 12 | implement 'GHC.Generic', __an empty instance will suffice__, as all the 13 | methods of 'Shaped' can be filled in by generic implementations. For 14 | example: 15 | 16 | > import GHC.Generics as GHC 17 | > import Generics.SOP as SOP 18 | > 19 | > data D = C deriving (GHC.Generic) 20 | > 21 | > instance SOP.Generic D 22 | > instance SOP.HasDatatypeInfo D 23 | > 24 | > instance Shaped D 25 | 26 | Using the @DeriveAnyClass@ extension, this can be shortened to one line: 27 | 28 | > data D = C deriving (GHC.Generic, SOP.Generic, SOP.HasDatatypeInfo, Shaped) 29 | 30 | Manual instances of 'Shaped' are necessary for types which do not or cannot 31 | implement GHC's @Generic@ typeclass, such as existential types, abstract 32 | types, and GADTs. 33 | 34 | This module is heavily based upon the approach in "Data.Functor.Foldable", 35 | which in turn is modeled after the paper "Functional Programming with 36 | Bananas, Lenses, Envelopes and Barbed Wire" (1991) by Erik Meijer, Maarten 37 | Fokkinga and Ross Paterson. If you don't yet understand recursion schemes 38 | and want to understand this module, it's probably a good idea to familiarize 39 | yourself with "Data.Functor.Foldable" before diving into this higher-order 40 | generalization. 41 | -} 42 | module Test.StrictCheck.Shaped 43 | ( Shaped(..) 44 | , module Test.StrictCheck.Shaped.Flattened 45 | -- * Fixed-points of 'Shape's 46 | , type (%)(..) 47 | -- * Folds and unfolds over fixed-points of @Shape@s 48 | , unwrap 49 | , interleave 50 | , (%) 51 | , fuse 52 | , translate 53 | , fold 54 | , unfold 55 | , unzipWith 56 | -- , reshape 57 | -- * Rendering 'Shaped' things as structured text 58 | , QName 59 | , Rendered(..) 60 | , RenderLevel(..) 61 | , renderfold 62 | -- * Tools for manually writing instances of 'Shaped' 63 | -- ** Implementing 'Shaped' for primitive types 64 | , Prim(..), unPrim 65 | , projectPrim 66 | , embedPrim 67 | , matchPrim 68 | , flatPrim 69 | , renderPrim 70 | , renderConstant 71 | -- ** Implementing 'Shaped' for container types 72 | , Containing(..) 73 | , projectContainer 74 | , embedContainer 75 | -- * Generic implementation of the methods of 'Shaped' 76 | , GShaped 77 | , GShape(..) 78 | , gProject 79 | , gEmbed 80 | , gMatch 81 | , gRender 82 | ) where 83 | 84 | import Type.Reflection 85 | import Data.Functor.Product 86 | import Data.Bifunctor 87 | import Data.Bifunctor.Flip 88 | import Data.Coerce 89 | 90 | import Generics.SOP hiding ( Shape ) 91 | 92 | import Data.Complex 93 | -- import Data.List.NonEmpty (NonEmpty(..)) 94 | 95 | import Test.StrictCheck.Shaped.Flattened 96 | 97 | -- TODO: provide instances for all of Base 98 | 99 | -- | When a type @a@ is @Shaped@, we know how to convert it into a 100 | -- representation parameterized by an arbitrary functor @f@, so that @Shape a f@ 101 | -- (the "shape of @a@ parameterized by @f@") is structurally identical to the 102 | -- topmost structure of @a@, but with @f@ wrapped around any subfields of @a@. 103 | -- 104 | -- Note that this is /not/ a recursive representation! The functor @f@ in 105 | -- question wraps the original type of the field and /not/ a @Shape@ of that 106 | -- field. 107 | -- 108 | -- For instance, the @Shape@ of @Either a b@ might be: 109 | -- 110 | -- > data EitherShape a b f 111 | -- > = LeftShape (f a) 112 | -- > | RightShape (f b) 113 | -- > 114 | -- > instance Shaped (Either a b) where 115 | -- > type Shape (Either a b) = EitherShape a b 116 | -- > ... 117 | -- 118 | -- The shape of a primitive type should be isomorphic to the primitive type, 119 | -- with the functor parameter left unused. 120 | class Typeable a => Shaped (a :: *) where 121 | -- | The @Shape@ of an @a@ is a type isomorphic to the outermost level of 122 | -- structure in an @a@, parameterized by the functor @f@, which is wrapped 123 | -- around any fields (of any type) in the original @a@. 124 | type Shape a :: (* -> *) -> * 125 | type Shape a = GShape a 126 | 127 | -- | Given a function to expand any @Shaped@ @x@ into an @f x@, expand an @a@ 128 | -- into a @Shape a f@ 129 | -- 130 | -- That is: convert the top-most level of structure in the given @a@ into a 131 | -- @Shape@, calling the provided function on each field in the @a@ to produce 132 | -- the @f x@ necessary to fill that hole in the produced @Shape a f@. 133 | -- 134 | -- Inverse to 'embed'. 135 | project :: (forall x. Shaped x => x -> f x) -> a -> Shape a f 136 | 137 | default project 138 | :: GShaped a 139 | => (forall x. Shaped x => x -> f x) 140 | -> a 141 | -> Shape a f 142 | project = gProject 143 | 144 | -- | Given a function to collapse any @f x@ into a @Shaped@ @x@, collapse a 145 | -- @Shape a f@ into merely an @a@ 146 | -- 147 | -- That is: eliminate the top-most @Shape@ by calling the provided function on 148 | -- each field in that @Shape a f@, and using the results to fill in the pieces 149 | -- necessary to build an @a@. 150 | -- 151 | -- Inverse to 'project'. 152 | embed :: (forall x. Shaped x => f x -> x) -> Shape a f -> a 153 | 154 | default embed 155 | :: GShaped a 156 | => (forall x. Shaped x => f x -> x) 157 | -> Shape a f 158 | -> a 159 | embed = gEmbed 160 | 161 | -- | Given two @Shape@s of the same type @a@ but parameterized by potentially 162 | -- different functors @f@ and @g@, pattern-match on them to expose a uniform 163 | -- view on their fields (a 'Flattened' @(Shape a)@) to a continuation which 164 | -- may operate on those fields to produce some result 165 | -- 166 | -- If the two supplied @Shape@s do not structurally match, only the fields of 167 | -- the first are given to the continuation. If they do match, the fields of 168 | -- the second are also given, along with type-level proof that the types of 169 | -- the two sets of fields align. 170 | -- 171 | -- This very general operation subsumes equality testing, mapping, zipping, 172 | -- shrinking, and many other structural operations over @Shaped@ things. 173 | -- 174 | -- It is somewhat difficult to manually write instances for this method, but 175 | -- consulting its generic implementation 'gMatch' may prove helpful. 176 | -- 177 | -- See "Test.StrictCheck.Shaped.Flattened" for more information. 178 | match :: Shape a f -> Shape a g 179 | -> (forall xs. All Shaped xs 180 | => Flattened (Shape a) f xs 181 | -> Maybe (Flattened (Shape a) g xs) 182 | -> result) 183 | -> result 184 | 185 | default match :: GShaped a 186 | => Shape a f -> Shape a g 187 | -> (forall xs. All Shaped xs 188 | => Flattened (Shape a) f xs 189 | -> Maybe (Flattened (Shape a) g xs) 190 | -> result) 191 | -> result 192 | match = gMatch 193 | 194 | -- | Convert a @Shape a@ whose fields are some unknown constant type into a 195 | -- 'RenderLevel' filled with that type 196 | -- 197 | -- This is a specialized pretty-printing mechanism which allows for displaying 198 | -- counterexamples in a structured format. See the documentation for 199 | -- 'RenderLevel'. 200 | render :: Shape a (K x) -> RenderLevel x 201 | 202 | default render :: (GShaped a, HasDatatypeInfo a) 203 | => Shape a (K x) -> RenderLevel x 204 | render = gRender 205 | 206 | 207 | 208 | -- * Fixed-points of 'Shape's 209 | 210 | -- | A value of type @f % a@ has the same structure as an @a@, but with the 211 | -- structure of the functor @f@ interleaved at every field (including ones of 212 | -- types other than @a@). Read this type aloud as "a interleaved with f's". 213 | newtype (f :: * -> *) % (a :: *) :: * where 214 | Wrap :: f (Shape a ((%) f)) -> f % a 215 | 216 | -- | Look inside a single level of an interleaved @f % a@. Inverse to the 'Wrap' 217 | -- constructor. 218 | unwrap :: f % a -> f (Shape a ((%) f)) 219 | unwrap (Wrap fs) = fs 220 | 221 | 222 | 223 | -- * Folds and unfolds over fixed-points of @Shape@s 224 | 225 | -- | Map a function across all the fields in a 'Shape' 226 | -- 227 | -- This function may change the functor over which the @Shape@ is parameterized. 228 | -- It can assume recursively that all the fields in the @Shape@ are themselves 229 | -- instances of @Shaped@ (which they should be!). This means that you can nest 230 | -- calls to @translate@ recursively. 231 | translate :: forall a f g. Shaped a 232 | => (forall x. Shaped x => f x -> g x) 233 | -> Shape a f -> Shape a g 234 | translate t d = match @a d d $ \flat _ -> 235 | unflatten $ mapFlattened @Shaped t flat 236 | 237 | -- | The equivalent of a fold (catamorphism) over recursively 'Shaped' values 238 | -- 239 | -- Given a function which folds an @f@ containing some @Shape x g@ into a @g x@, 240 | -- recursively fold any interleaved @f % a@ into a @g a@. 241 | fold :: forall a f g. (Functor f, Shaped a) 242 | => (forall x. Shaped x => f (Shape x g) -> g x) 243 | -> f % a -> g a 244 | fold alg = alg . fmap (translate @a (fold alg)) . unwrap 245 | 246 | -- | The equivalent of an unfold (anamorphism) over recursively 'Shaped' values 247 | -- 248 | -- Given a function which unfolds an @f x@ into a @g@ containing some @Shape x 249 | -- f@, corecursively unfold any @f a@ into an interleaved @g % a@. 250 | unfold :: forall a f g. (Functor g, Shaped a) 251 | => (forall x. Shaped x => f x -> g (Shape x f)) 252 | -> f a -> g % a 253 | unfold coalg = Wrap . fmap (translate @a (unfold coalg)) . coalg 254 | 255 | -- TODO: mapM, foldM, unfoldM, ... 256 | 257 | -- | Fuse the interleaved @f@-structure out of a recursively interleaved @f % 258 | -- a@, given some way of fusing a single level @f x -> x@. 259 | -- 260 | -- This is a special case of 'fold'. 261 | fuse 262 | :: (Functor f, Shaped a) 263 | => (forall x. f x -> x) 264 | -> (f % a -> a) 265 | fuse e = e . fold (fmap (embed e)) 266 | 267 | -- | Interleave an @f@-structure at every recursive level of some @a@, given 268 | -- some way of generating a single level of structure @x -> f x@. 269 | -- 270 | -- This is a special case of 'unfold'. 271 | interleave 272 | :: (Functor f, Shaped a) 273 | => (forall x. x -> f x) 274 | -> (a -> f % a) 275 | interleave p = unfold (fmap (project p)) . p 276 | 277 | -- | An infix synonym for 'interleave' 278 | (%) :: forall a f. (Functor f, Shaped a) 279 | => (forall x. x -> f x) 280 | -> a -> f % a 281 | (%) = interleave 282 | 283 | -- | A higher-kinded @unzipWith@, operating over interleaved structures 284 | -- 285 | -- Given a function splitting some @f x@ into a functor-product @Product g h x@, 286 | -- recursively split an interleaved @f % a@ into two interleaved structures: 287 | -- one built of @g@-shapes and one of @h@-shapes. 288 | -- 289 | -- Note that @Product ((%) g) ((%) h) a@ is isomorphic to @(g % a, h % a)@; to 290 | -- get the latter, pattern-match on the 'Pair' constructor of 'Product'. 291 | unzipWith 292 | :: (All Functor [f, g, h], Shaped a) 293 | => (forall x. f x -> (g x, h x)) 294 | -> (f % a -> (g % a, h % a)) 295 | unzipWith split = 296 | unPair . fold (crunch . pair . split) 297 | where 298 | crunch 299 | :: forall x g h. 300 | (Shaped x, Functor g, Functor h) 301 | => Product g h (Shape x (Product ((%) g) ((%) h))) 302 | -> Product ((%) g) ((%) h) x 303 | crunch = 304 | pair 305 | . bimap (Wrap . fmap (translate @x (fst . unPair))) 306 | (Wrap . fmap (translate @x (snd . unPair))) 307 | . unPair 308 | 309 | pair :: (l x, r x) -> Product l r x 310 | pair = uncurry Pair 311 | 312 | unPair :: Product l r x -> (l x, r x) 313 | unPair (Pair lx rx) = (lx, rx) 314 | 315 | -- | TODO: document this strange function 316 | {- 317 | reshape :: forall b a f g. (Shaped a, Shaped b, Functor f) 318 | => (f (Shape b ((%) g)) -> g (Shape b ((%) g))) 319 | -> (forall x. Shaped x => f % x -> g % x) 320 | -> f % a -> g % a 321 | reshape homo hetero d = 322 | case eqTypeRep (typeRep @a) (typeRep @b) of 323 | Nothing -> hetero d 324 | Just HRefl -> 325 | Wrap 326 | $ homo . fmap (translate @a (reshape @b homo hetero)) 327 | $ unwrap d 328 | -} 329 | 330 | ---------------------------------- 331 | -- Rendering shapes for display -- 332 | ---------------------------------- 333 | 334 | -- | Convert an @f % a@ into a structured pretty-printing representation, 335 | -- suitable for further display/processing 336 | renderfold 337 | :: forall a f. (Shaped a, Functor f) 338 | => f % a -> Rendered f 339 | renderfold = unK . fold oneLevel 340 | where 341 | oneLevel :: forall x. Shaped x 342 | => f (Shape x (K (Rendered f))) 343 | -> K (Rendered f) x 344 | oneLevel = K . RWrap . fmap (render @x) 345 | 346 | -- | A @QName@ is a qualified name 347 | -- 348 | -- Note: 349 | -- > type ModuleName = String 350 | -- > type DatatypeName = String 351 | type QName = (ModuleName, DatatypeName, String) 352 | 353 | -- | @RenderLevel@ is a functor whose outer shape contains all the information 354 | -- about how to pretty-format the outermost @Shape@ of some value. We use 355 | -- parametricity to make it difficult to construct incorrect 'render' methods, 356 | -- by asking the user merely to produce a single @RenderLevel@ and stitching 357 | -- nested @RenderLevel@s into complete 'Rendered' trees. 358 | data RenderLevel x 359 | = ConstructorD QName [x] 360 | -- ^ A prefix constructor, and a list of its fields 361 | | InfixD QName Associativity Fixity x x 362 | -- ^ An infix constructor, its associativity and fixity, and its two fields 363 | | RecordD QName [(QName, x)] 364 | -- ^ A record constructor, and a list of its field names paired with fields 365 | | CustomD Fixity 366 | [Either (Either String (ModuleName, String)) (Fixity, x)] 367 | -- ^ A custom pretty-printing representation (i.e. for abstract types), which 368 | -- records a fixity and a list of tokens of three varieties: 1) raw strings, 369 | -- 2) qualified strings (from some module), or 3) actual fields, annotated 370 | -- with their fixity 371 | deriving (Eq, Ord, Show, Functor) 372 | 373 | -- | @Rendered f@ is the fixed-point of @f@ composed with 'RenderLevel': it 374 | -- alternates between @f@ shapes and @RenderLevel@s. Usually, @f@ will be the 375 | -- identity functor 'I', but not always. 376 | data Rendered f 377 | = RWrap (f (RenderLevel (Rendered f))) 378 | 379 | 380 | ---------------------------------------------------- 381 | -- Tools for manually writing instances of Shaped -- 382 | ---------------------------------------------------- 383 | 384 | -- | The @Shape@ of a spine-strict container (i.e. a @Map@ or @Set@) is the same 385 | -- as a container of demands on its elements. However, this does not have the 386 | -- right /kind/ to be used as a @Shape@. 387 | -- 388 | -- The @Containing@ newtype solves this problem. By defining the @Shape@ of some 389 | -- container @(C a)@ to be @(C `Containing` a)@, you can use the methods 390 | -- @projectContainer@ and @embedContainer@ to implement @project@ and @embed@ 391 | -- for your container type (although you will still need to manually define 392 | -- @match@ and @render@). 393 | newtype Containing h a f 394 | = Container (h (f a)) 395 | deriving (Eq, Ord, Show) 396 | 397 | -- | Generic implementation of @project@ for any container type whose @Shape@ 398 | -- is represented as a @Containing@ newtype 399 | projectContainer :: (Functor c, Shaped a) 400 | => (forall x. Shaped x => x -> f x) 401 | -> c a -> Containing c a f 402 | projectContainer p x = Container (fmap p x) 403 | 404 | -- | Generic implementation of @embed@ for any container type whose @Shape@ 405 | -- is represented as a @Containing@ newtype 406 | embedContainer :: (Functor c, Shaped a) 407 | => (forall x. Shaped x => f x -> x) 408 | -> Containing c a f -> c a 409 | embedContainer e (Container x) = fmap e x 410 | 411 | 412 | -- TODO: helper functions for matching and prettying containers 413 | 414 | -- | The @Shape@ of a primitive type should be equivalent to the type itself. 415 | -- However, this does not have the right /kind/ to be used as a @Shape@. 416 | -- 417 | -- The @Prim@ newtype solves this problem. By defining the @Shape@ of some 418 | -- primitive type @p@ to be @Prim p@, you can use the methods @projectPrim@, 419 | -- @embedPrim@, @matchPrim@, and @prettyPrim@ to completely fill in the 420 | -- definition of the @Shaped@ class for a primitive type. 421 | -- 422 | -- __Note:__ It is only appropriate to use this @Shape@ representation when a 423 | -- type really is primitive, in that it contains no interesting substructure. 424 | -- If you use the @Prim@ representation inappropriately, StrictCheck will not be 425 | -- able to inspect the richer structure of the type in question. 426 | newtype Prim (x :: *) (f :: * -> *) 427 | = Prim x 428 | deriving (Eq, Ord, Show) 429 | deriving newtype (Num) 430 | 431 | -- | Get the wrapped @x@ out of a @Prim x f@ (inverse to the @Prim@ constructor) 432 | unPrim :: Prim x f -> x 433 | unPrim (Prim x) = x 434 | 435 | -- | Generic implementation of @project@ for any primitive type whose @Shape@ is 436 | -- is represented as a @Prim@ newtype 437 | projectPrim :: (forall x. Shaped x => x -> f x) -> a -> Prim a f 438 | projectPrim _ = Prim 439 | 440 | -- | Generic implementation of @embed@ for any primitive type whose @Shape@ is 441 | -- is represented as a @Prim@ newtype 442 | embedPrim :: (forall x. Shaped x => f x -> x) -> Prim a f -> a 443 | embedPrim _ = unPrim 444 | 445 | -- | Generic implementation of @match@ for any primitive type whose @Shape@ is 446 | -- is represented as a @Prim@ newtype with an underlying @Eq@ instance 447 | matchPrim :: Eq a => Prim a f -> Prim a g 448 | -> (forall xs. All Shaped xs 449 | => Flattened (Prim a) f xs 450 | -> Maybe (Flattened (Prim a) g xs) 451 | -> result) 452 | -> result 453 | matchPrim (Prim a) (Prim b) k = 454 | k (flatPrim a) 455 | (if a == b then (Just (flatPrim b)) else Nothing) 456 | 457 | -- | Helper for writing @match@ instances for primitive types which don't have 458 | -- @Eq@ instance 459 | -- 460 | -- This generates a @Flattened@ appropriate for using in the implementation of 461 | -- @match@. For more documentation on how to use this, see the documentation of 462 | -- 'match'. 463 | flatPrim :: a -> Flattened (Prim a) g '[] 464 | flatPrim x = Flattened (const (Prim x)) Nil 465 | 466 | -- | Generic implementation of @render@ for any primitive type whose @Shape@ is 467 | -- is represented as a @Prim@ newtype 468 | renderPrim :: Show a => Prim a (K x) -> RenderLevel x 469 | renderPrim (Prim a) = renderConstant (show a) 470 | 471 | -- | Given some @string@, generate a custom pretty-printing representation which 472 | -- just shows the string 473 | renderConstant :: String -> RenderLevel x 474 | renderConstant s = CustomD 11 [Left (Left s)] 475 | 476 | -- TODO: What about demands for abstract types with > 1 type of unbounded-count field? 477 | 478 | {- 479 | withFieldsContainer :: 480 | forall c a f result. 481 | (forall r h. 482 | c (h a) -> 483 | (forall x. Shaped x 484 | => [h x] 485 | -> (forall g. [g x] -> c (g a)) 486 | -> r) 487 | -> r) 488 | -> Containing c a f 489 | -> (forall xs. All Shaped xs 490 | => NP f xs 491 | -> (forall g. NP g xs -> Containing c a g) 492 | -> result) 493 | -> result 494 | withFieldsContainer viaContaining (Container c) cont = 495 | viaContaining c $ 496 | \list un -> 497 | withNP @Shaped list (Container . un) cont 498 | 499 | -- TODO: Make this work for any number of lists of fields, by carefully using 500 | -- unsafeCoerce to deal with unknown list lengths 501 | 502 | withFieldsViaList :: 503 | forall demand f result. 504 | (forall r h. 505 | demand h -> 506 | (forall x. Shaped x 507 | => [h x] 508 | -> (forall g. [g x] -> demand g) 509 | -> r) 510 | -> r) 511 | -> demand f 512 | -> (forall xs. All Shaped xs 513 | => NP f xs 514 | -> (forall g. NP g xs -> demand g) 515 | -> result) 516 | -> result 517 | withFieldsViaList viaList demand cont = 518 | viaList demand $ 519 | \list un -> 520 | withNP @Shaped list un cont 521 | 522 | withNP :: forall c demand result f x. c x 523 | => [f x] 524 | -> (forall g. [g x] -> demand g) 525 | -> (forall xs. All c xs 526 | => NP f xs -> (forall g. NP g xs -> demand g) -> result) 527 | -> result 528 | withNP list unList cont = 529 | withUnhomogenized @c list $ \np -> 530 | cont np (unList . homogenize) 531 | 532 | withConcatenated :: NP (NP f) xss -> (forall xs. NP f xs -> r) -> r 533 | withConcatenated pop cont = 534 | case pop of 535 | Nil -> cont Nil 536 | (xs :* xss) -> withConcatenated xss (withPrepended xs cont) 537 | where 538 | withPrepended :: 539 | NP f ys -> (forall zs. NP f zs -> r) 540 | -> (forall zs. NP f zs -> r) 541 | withPrepended pre k rest = 542 | case pre of 543 | Nil -> k rest 544 | (x :* xs) -> withPrepended xs (k . (x :*)) rest 545 | 546 | homogenize :: All ((~) a) as => NP f as -> [f a] 547 | homogenize Nil = [] 548 | homogenize (a :* as) = a : homogenize as 549 | 550 | withUnhomogenized :: forall c a f r. 551 | c a => [f a] -> (forall as. (All c as, All ((~) a) as) => NP f as -> r) -> r 552 | withUnhomogenized [] k = k Nil 553 | withUnhomogenized (a : as) k = 554 | withUnhomogenized @c as $ \np -> k (a :* np) 555 | -} 556 | 557 | 558 | --------------------------------------------------- 559 | -- Generic implementation of the Shaped methods -- 560 | --------------------------------------------------- 561 | 562 | -- | The 'Shape' used for generic implementations of 'Shaped' 563 | -- 564 | -- This wraps a sum-of-products representation from "Generics.SOP". 565 | newtype GShape a f 566 | = GS (NS (NP f) (Code a)) 567 | 568 | -- | The collection of constraints necessary for a type to be given a generic 569 | -- implementation of the 'Shaped' methods 570 | type GShaped a = 571 | ( Generic a 572 | , Shape a ~ GShape a 573 | , All2 Shaped (Code a) 574 | , SListI (Code a) 575 | , All SListI (Code a) ) 576 | 577 | -- | Generic 'project' 578 | gProject :: GShaped a 579 | => (forall x. Shaped x => x -> f x) 580 | -> a -> Shape a f 581 | gProject p !(from -> sop) = 582 | GS (unSOP (hcliftA (Proxy @Shaped) (p . unI) sop)) 583 | 584 | -- | Generic 'embed' 585 | gEmbed :: GShaped a 586 | => (forall x. Shaped x => f x -> x) 587 | -> Shape a f -> a 588 | gEmbed e !(GS d) = 589 | to (hcliftA (Proxy @Shaped) (I . e) (SOP d)) 590 | 591 | -- | Generic 'match' 592 | gMatch :: forall a f g result. GShaped a 593 | => Shape a f -> Shape a g 594 | -> (forall xs. All Shaped xs 595 | => Flattened (Shape a) f xs 596 | -> Maybe (Flattened (Shape a) g xs) 597 | -> result) 598 | -> result 599 | gMatch !(GS df) !(GS dg) cont = 600 | go @(Code a) df (Just dg) $ \flatF mflatG -> 601 | cont (flatGD flatF) (flatGD <$> mflatG) 602 | where 603 | go :: forall xss r. 604 | (All SListI xss, All2 Shaped xss) 605 | => NS (NP f) xss 606 | -> Maybe (NS (NP g) xss) 607 | -> (forall xs. All Shaped xs 608 | => Flattened (Flip SOP xss) f xs 609 | -> Maybe (Flattened (Flip SOP xss) g xs) 610 | -> r) 611 | -> r 612 | go (Z (fieldsF :: _ xs)) (Just (Z fieldsG)) k = 613 | k @xs (flatZ fieldsF) (Just (flatZ fieldsG)) 614 | go (Z (fieldsF :: _ xs)) _ k = -- Nothing | Just (S _) 615 | k @xs (flatZ fieldsF) Nothing 616 | go (S moreF) Nothing k = 617 | go moreF Nothing $ \(flatF :: _ xs) _ -> 618 | k @xs (flatS flatF) Nothing 619 | go (S moreF) (Just (Z _)) k = 620 | go moreF Nothing $ \(flatF :: _ xs) _ -> 621 | k @xs (flatS flatF) Nothing 622 | go (S moreF) (Just (S moreG)) k = 623 | go moreF (Just moreG) $ \(flatF :: _ xs) mflatG -> 624 | k @xs (flatS flatF) (flatS <$> mflatG) 625 | 626 | flatZ 627 | :: forall h xs xss. NP h xs -> Flattened (Flip SOP (xs : xss)) h xs 628 | flatZ = Flattened (Flip . SOP . Z) 629 | 630 | flatS 631 | :: forall h xs xs' xss. 632 | Flattened (Flip SOP xss) h xs 633 | -> Flattened (Flip SOP (xs' : xss)) h xs 634 | flatS (Flattened un fields) = 635 | Flattened (Flip . SOP . S . coerce . un) fields 636 | 637 | flatGD :: forall t h xs. 638 | Flattened (Flip SOP (Code t)) h xs -> Flattened (GShape t) h xs 639 | flatGD (Flattened un fields) = 640 | Flattened (GS . coerce . un) fields 641 | 642 | -- | Generic 'render' 643 | gRender :: forall a x. (HasDatatypeInfo a, GShaped a) 644 | => Shape a (K x) -> RenderLevel x 645 | gRender (GS demand) = 646 | case info of 647 | ADT m d cs s -> 648 | renderC m d demand cs 649 | Newtype m d c -> 650 | renderC m d demand (c :* Nil) 651 | where 652 | info = datatypeInfo (Proxy @a) 653 | 654 | renderC :: forall as. ModuleName -> DatatypeName 655 | -> NS (NP (K x)) as 656 | -> NP ConstructorInfo as 657 | -> RenderLevel x 658 | renderC m d subShape constructors = 659 | case (subShape, constructors) of 660 | (Z demandFields, c :* _) -> 661 | case c of 662 | Constructor name -> 663 | ConstructorD (m, d, name) $ 664 | hcollapse demandFields 665 | Infix name associativity fixity -> 666 | case demandFields of 667 | (K a :* K b :* Nil) -> 668 | InfixD (m, d, name) associativity fixity a b 669 | Record name fieldsInfo -> 670 | RecordD (m, d, name) $ 671 | zip ( hcollapse 672 | . hliftA (\(FieldInfo f) -> K (m, d, f)) 673 | $ fieldsInfo ) 674 | (hcollapse demandFields) 675 | (S another, _ :* different) -> 676 | renderC m d another different 677 | 678 | 679 | --------------- 680 | -- Instances -- 681 | --------------- 682 | 683 | instance Shaped () 684 | instance Shaped Bool 685 | instance Shaped Ordering 686 | instance Shaped a => Shaped (Maybe a) 687 | instance (Shaped a, Shaped b) => Shaped (Either a b) 688 | instance Shaped a => Shaped [a] 689 | 690 | instance (Typeable a, Typeable b) => Shaped (a -> b) where 691 | type Shape (a -> b) = Prim (a -> b) 692 | project = projectPrim 693 | embed = embedPrim 694 | match (Prim f) (Prim g) k = k (flatPrim f) (Just $ flatPrim g) 695 | render _ = renderConstant (" :: " ++ show (typeRep @(a -> b))) 696 | 697 | instance Shaped Char where 698 | type Shape Char = Prim Char 699 | project = projectPrim 700 | embed = embedPrim 701 | match = matchPrim 702 | render = renderPrim 703 | 704 | instance Shaped Word where 705 | type Shape Word = Prim Word 706 | project = projectPrim 707 | embed = embedPrim 708 | match = matchPrim 709 | render = renderPrim 710 | 711 | instance Shaped Int where 712 | type Shape Int = Prim Int 713 | project = projectPrim 714 | embed = embedPrim 715 | match = matchPrim 716 | render = renderPrim 717 | 718 | instance Shaped Double where 719 | type Shape Double = Prim Double 720 | project = projectPrim 721 | embed = embedPrim 722 | match = matchPrim 723 | render = renderPrim 724 | 725 | instance Shaped Float where 726 | type Shape Float = Prim Float 727 | project = projectPrim 728 | embed = embedPrim 729 | match = matchPrim 730 | render = renderPrim 731 | 732 | instance Shaped Rational where 733 | type Shape Rational = Prim Rational 734 | project = projectPrim 735 | embed = embedPrim 736 | match = matchPrim 737 | render = renderPrim 738 | 739 | instance Shaped Integer where 740 | type Shape Integer = Prim Integer 741 | project = projectPrim 742 | embed = embedPrim 743 | match = matchPrim 744 | render = renderPrim 745 | 746 | instance (Typeable a, Eq a, Show a) => Shaped (Complex a) where 747 | type Shape (Complex a) = Prim (Complex a) 748 | project = projectPrim 749 | embed = embedPrim 750 | match = matchPrim 751 | render = renderPrim 752 | 753 | -- instance Generic (NonEmpty a) 754 | -- instance HasDatatypeInfo (NonEmpty a) 755 | -- instance Shaped a => Shaped (NonEmpty a) where 756 | 757 | -- Tree 758 | -- Map k 759 | -- Seq 760 | -- Set 761 | -- IntMap 762 | -- IntSet 763 | 764 | instance (Shaped a, Shaped b) => Shaped (a, b) 765 | instance (Shaped a, Shaped b, Shaped c) => Shaped (a, b, c) 766 | instance (Shaped a, Shaped b, Shaped c, Shaped d) => Shaped (a, b, c, d) 767 | instance ( Shaped a, Shaped b, Shaped c, Shaped d, Shaped e 768 | ) => Shaped 769 | (a, b, c, d, e) 770 | instance ( Shaped a, Shaped b, Shaped c, Shaped d, Shaped e, Shaped f 771 | ) => Shaped 772 | (a, b, c, d, e, f) 773 | instance ( Shaped a, Shaped b, Shaped c, Shaped d, Shaped e, Shaped f 774 | , Shaped g 775 | ) => Shaped 776 | (a, b, c, d, e, f, g) 777 | -- instance ( Shaped a, Shaped b, Shaped c, Shaped d, Shaped e, Shaped f 778 | -- , Shaped g, Shaped h 779 | -- ) => Shaped 780 | -- (a, b, c, d, e, f, g, h) 781 | -- instance ( Shaped a, Shaped b, Shaped c, Shaped d, Shaped e, Shaped f 782 | -- , Shaped g, Shaped h, Shaped i 783 | -- ) => Shaped 784 | -- (a, b, c, d, e, f, g, h, i) 785 | -- instance ( Shaped a, Shaped b, Shaped c, Shaped d, Shaped e, Shaped f 786 | -- , Shaped g, Shaped h, Shaped i, Shaped j 787 | -- ) => Shaped 788 | -- (a, b, c, d, e, f, g, h, i, j) 789 | -- instance ( Shaped a, Shaped b, Shaped c, Shaped d, Shaped e, Shaped f 790 | -- , Shaped g, Shaped h, Shaped i, Shaped j, Shaped k 791 | -- ) => Shaped 792 | -- (a, b, c, d, e, f, g, h, i, j, k) 793 | -- instance ( Shaped a, Shaped b, Shaped c, Shaped d, Shaped e, Shaped f 794 | -- , Shaped g, Shaped h, Shaped i, Shaped j, Shaped k, Shaped l 795 | -- ) => Shaped 796 | -- (a, b, c, d, e, f, g, h, i, j, k, l) 797 | -- instance ( Shaped a, Shaped b, Shaped c, Shaped d, Shaped e, Shaped f 798 | -- , Shaped g, Shaped h, Shaped i, Shaped j, Shaped k, Shaped l 799 | -- , Shaped m 800 | -- ) => Shaped 801 | -- (a, b, c, d, e, f, g, h, i, j, k, l, m) 802 | -- instance ( Shaped a, Shaped b, Shaped c, Shaped d, Shaped e, Shaped f 803 | -- , Shaped g, Shaped h, Shaped i, Shaped j, Shaped k, Shaped l 804 | -- , Shaped m, Shaped n 805 | -- ) => Shaped 806 | -- (a, b, c, d, e, f, g, h, i, j, k, l, m, n) 807 | -- instance ( Shaped a, Shaped b, Shaped c, Shaped d, Shaped e, Shaped f 808 | -- , Shaped g, Shaped h, Shaped i, Shaped j, Shaped k, Shaped l 809 | -- , Shaped m, Shaped n, Shaped o 810 | -- ) => Shaped 811 | -- (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o) 812 | -- instance ( Shaped a, Shaped b, Shaped c, Shaped d, Shaped e, Shaped f 813 | -- , Shaped g, Shaped h, Shaped i, Shaped j, Shaped k, Shaped l 814 | -- , Shaped m, Shaped n, Shaped o, Shaped p 815 | -- ) => Shaped 816 | -- (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p) 817 | -- instance ( Shaped a, Shaped b, Shaped c, Shaped d, Shaped e, Shaped f 818 | -- , Shaped g, Shaped h, Shaped i, Shaped j, Shaped k, Shaped l 819 | -- , Shaped m, Shaped n, Shaped o, Shaped p, Shaped q 820 | -- ) => Shaped 821 | -- (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q) 822 | -- instance ( Shaped a, Shaped b, Shaped c, Shaped d, Shaped e, Shaped f 823 | -- , Shaped g, Shaped h, Shaped i, Shaped j, Shaped k, Shaped l 824 | -- , Shaped m, Shaped n, Shaped o, Shaped p, Shaped q, Shaped r 825 | -- ) => Shaped 826 | -- (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r) 827 | -- instance ( Shaped a, Shaped b, Shaped c, Shaped d, Shaped e, Shaped f 828 | -- , Shaped g, Shaped h, Shaped i, Shaped j, Shaped k, Shaped l 829 | -- , Shaped m, Shaped n, Shaped o, Shaped p, Shaped q, Shaped r 830 | -- , Shaped s 831 | -- ) => Shaped 832 | -- (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s) 833 | -- instance ( Shaped a, Shaped b, Shaped c, Shaped d, Shaped e, Shaped f 834 | -- , Shaped g, Shaped h, Shaped i, Shaped j, Shaped k, Shaped l 835 | -- , Shaped m, Shaped n, Shaped o, Shaped p, Shaped q, Shaped r 836 | -- , Shaped s, Shaped t 837 | -- ) => Shaped 838 | -- (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t) 839 | -- instance ( Shaped a, Shaped b, Shaped c, Shaped d, Shaped e, Shaped f 840 | -- , Shaped g, Shaped h, Shaped i, Shaped j, Shaped k, Shaped l 841 | -- , Shaped m, Shaped n, Shaped o, Shaped p, Shaped q, Shaped r 842 | -- , Shaped s, Shaped t, Shaped u 843 | -- ) => Shaped 844 | -- (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u) 845 | -- instance ( Shaped a, Shaped b, Shaped c, Shaped d, Shaped e, Shaped f 846 | -- , Shaped g, Shaped h, Shaped i, Shaped j, Shaped k, Shaped l 847 | -- , Shaped m, Shaped n, Shaped o, Shaped p, Shaped q, Shaped r 848 | -- , Shaped s, Shaped t, Shaped u, Shaped v 849 | -- ) => Shaped 850 | -- (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v) 851 | -- instance ( Shaped a, Shaped b, Shaped c, Shaped d, Shaped e, Shaped f 852 | -- , Shaped g, Shaped h, Shaped i, Shaped j, Shaped k, Shaped l 853 | -- , Shaped m, Shaped n, Shaped o, Shaped p, Shaped q, Shaped r 854 | -- , Shaped s, Shaped t, Shaped u, Shaped v, Shaped w 855 | -- ) => Shaped 856 | -- (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w) 857 | -- instance ( Shaped a, Shaped b, Shaped c, Shaped d, Shaped e, Shaped f 858 | -- , Shaped g, Shaped h, Shaped i, Shaped j, Shaped k, Shaped l 859 | -- , Shaped m, Shaped n, Shaped o, Shaped p, Shaped q, Shaped r 860 | -- , Shaped s, Shaped t, Shaped u, Shaped v, Shaped w, Shaped x 861 | -- ) => Shaped 862 | -- (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x) 863 | -- instance ( Shaped a, Shaped b, Shaped c, Shaped d, Shaped e, Shaped f 864 | -- , Shaped g, Shaped h, Shaped i, Shaped j, Shaped k, Shaped l 865 | -- , Shaped m, Shaped n, Shaped o, Shaped p, Shaped q, Shaped r 866 | -- , Shaped s, Shaped t, Shaped u, Shaped v, Shaped w, Shaped x 867 | -- , Shaped y 868 | -- ) => Shaped 869 | -- (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y) 870 | -- instance ( Shaped a, Shaped b, Shaped c, Shaped d, Shaped e, Shaped f 871 | -- , Shaped g, Shaped h, Shaped i, Shaped j, Shaped k, Shaped l 872 | -- , Shaped m, Shaped n, Shaped o, Shaped p, Shaped q, Shaped r 873 | -- , Shaped s, Shaped t, Shaped u, Shaped v, Shaped w, Shaped x 874 | -- , Shaped y, Shaped z 875 | -- ) => Shaped 876 | -- (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z) 877 | -------------------------------------------------------------------------------- /src/Test/StrictCheck/Shaped/Flattened.hs: -------------------------------------------------------------------------------- 1 | {-| The @match@ function in the typeclass 'Test.StrictCheck.Shaped.Shaped' 2 | allows you to uniformly operate over all the fields in a given piece of 3 | data--for instance, consuming them, iterating over them, counting them, 4 | etc. This module defines a uniform representation to allow this to work. 5 | 6 | This is in the nitty-gritty of how StrictCheck works: you do not need to 7 | understand this in order to use StrictCheck, unless you need to declare 8 | custom instances of @Shaped@ for a type not supported by StrictCheck's 9 | generics mechanism (i.e. GADTs, existential types, abstract types). 10 | -} 11 | 12 | module Test.StrictCheck.Shaped.Flattened where 13 | 14 | import Generics.SOP 15 | 16 | -- | The @Flattened@ type contains all the fields in a piece of data 17 | -- (represented as an n-ary product 'NP' from "Generics.SOP"), paired with a way 18 | -- to re-assemble them into a value of the original datatype. 19 | -- 20 | -- @Flattened d f xs@ can be read as "some value of type @d f@, which has been 21 | -- separated into an n-ary product @NP f xs@ and a function which can reconstruct 22 | -- a value @d h@ for any @h@, given an n-ary product with matching field types 23 | -- to the one contained here. 24 | -- 25 | -- Pay attention to the kinds! @d :: (* -> *) -> *@, @f :: * -> *@, and 26 | -- @xs :: [*]@. 27 | -- 28 | -- For types which are literally a collection of fields with no extra 29 | -- information, the reconstruction function merely converts the given list of 30 | -- fields back into a value of the original type. For types which contain extra 31 | -- information in their values (beyond what StrictCheck considers fields), this 32 | -- function should contain that information, and re-attach it to the field 33 | -- values it receives. 34 | data Flattened d f xs where 35 | Flattened 36 | :: (forall h. NP h xs -> d h) 37 | -> NP f xs 38 | -> Flattened d f xs 39 | 40 | -- | Use the re-assembly close in a @Flattened@ to yield a value of the original 41 | -- type from which it was derived. 42 | unflatten :: Flattened d f xs -> d f 43 | unflatten (Flattened u p) = u p 44 | 45 | -- | If all the fields in a @Flattened@ satisfy some constraint, map a function 46 | -- expecting that constraint across all the fields. This may change the functor 47 | -- over which the @Flattened@ value is parameterized. 48 | mapFlattened :: forall c d f g xs. All c xs 49 | => (forall x. c x => f x -> g x) -> Flattened d f xs -> Flattened d g xs 50 | mapFlattened t (Flattened u p) = 51 | Flattened u (hcliftA (Proxy @c) t p) 52 | 53 | -- | 'traverseFlattened' is to 'traverse' like 'mapFlattened' is to 'fmap'. 54 | traverseFlattened :: forall c d f g h xs. (All c xs, Applicative h) 55 | => (forall x. c x => f x -> h (g x)) -> Flattened d f xs -> h (Flattened d g xs) 56 | traverseFlattened t (Flattened u p) = 57 | Flattened u <$> hctraverse' (Proxy @c) t p 58 | -------------------------------------------------------------------------------- /src/Test/StrictCheck/TH.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | 3 | -- | Template Haskell to derive pattern synonyms for working with demands 4 | module Test.StrictCheck.TH 5 | ( derivePatternSynonyms, 6 | ) 7 | where 8 | 9 | import Control.Monad (when) 10 | import Generics.SOP (NP (..), NS (..)) 11 | import Language.Haskell.TH 12 | import Test.StrictCheck.Demand 13 | import Test.StrictCheck.Shaped 14 | 15 | -- TODO: generate COMPLETE pragmas to avoid partiality warnings 16 | 17 | -- | Generates the proper type signature for a pattern. The first 18 | -- argument is the list of constructor field types, and the second 19 | -- argument is the type of the constructor constructs. This function 20 | -- inserts '->' and 'Demand' at the correct places. 21 | patternTypeDec :: [Type] -> Type -> Type 22 | patternTypeDec [] ty = AppT (ConT ''Demand) ty 23 | patternTypeDec (arg : args) ty = 24 | AppT 25 | (AppT ArrowT $ AppT (ConT ''Demand) arg) 26 | (patternTypeDec args ty) 27 | 28 | prefixPatternDec :: Int -> Name -> [Name] -> Pat -> Dec 29 | prefixPatternDec idx patName binderNames npPat = 30 | PatSynD 31 | patName 32 | (PrefixPatSyn binderNames) 33 | ImplBidir 34 | (ConP 'Wrap [] [ConP 'Eval [] [ConP 'GS [] [sumPattern idx npPat]]]) 35 | 36 | infixPatternDec :: 37 | Int -> 38 | Name -> 39 | Name -> 40 | Name -> -- LHS then RHS 41 | Pat -> 42 | Dec 43 | infixPatternDec idx patName lhsBinder rhsBinder npPat = 44 | PatSynD 45 | patName 46 | (InfixPatSyn lhsBinder rhsBinder) 47 | ImplBidir 48 | (ConP 'Wrap [] [ConP 'Eval [] [ConP 'GS [] [sumPattern idx npPat]]]) 49 | 50 | sumPattern :: Int -> Pat -> Pat 51 | sumPattern idx p 52 | | idx <= 0 = ConP 'Z [] [p] 53 | | otherwise = ConP 'S [] [sumPattern (idx - 1) p] 54 | 55 | productPattern :: [Type] -> Q (Pat, [Name]) 56 | productPattern [] = return (ConP 'Nil [] [], []) 57 | productPattern (_ : args) = do 58 | (tailPat, names) <- productPattern args 59 | freshName <- newName "x" 60 | return (InfixP (VarP freshName) '(:*) tailPat, freshName : names) 61 | 62 | -- | Turns a constructor into its corresponding pattern synonym 63 | -- declaration. The `Int` argument is the index of the constructor. 64 | -- For example, Nil would be the 0th constructor, and Cons would be 65 | -- the 1st constructor of the type data List a = Nil | Cons a (List a). 66 | constructor2PatternDec :: Type -> Int -> Con -> Q (Dec, Dec) 67 | constructor2PatternDec ty idx (NormalC conName argTypes) = do 68 | (npPat, names) <- productPattern (map snd argTypes) 69 | return 70 | ( PatSynSigD patDecName (patternTypeDec (map snd argTypes) ty), 71 | prefixPatternDec idx patDecName names npPat 72 | ) 73 | where 74 | patDecName = mkName (nameBase conName ++ "'") 75 | constructor2PatternDec ty idx (InfixC argType1 conName argType2) = do 76 | let argTypes = [argType1, argType2] 77 | (npPat, names) <- productPattern (map snd argTypes) 78 | when (length names /= 2) $ 79 | reportError "The impossible happened: Infix Pattern have more than 2 binders" 80 | let nm1 : nm2 : _ = names 81 | return 82 | ( PatSynSigD patDecName (patternTypeDec (map snd argTypes) ty), 83 | infixPatternDec idx patDecName nm1 nm2 npPat 84 | ) 85 | where 86 | patDecName = mkName (nameBase conName ++ "%") 87 | constructor2PatternDec _ _ _ = 88 | fail "Test.StrictCheck.TH cannot derive pattern synonyms for fancy types" 89 | 90 | -- | Template Haskell splice to generate pattern synonym declarations for 91 | -- working with explicitly-represented demands on a type whose 'Shape' is 92 | -- implemented generically as a 'GShape' 93 | derivePatternSynonyms :: Name -> Q [Dec] 94 | derivePatternSynonyms name = do 95 | nameInfo <- reify name 96 | case nameInfo of 97 | TyConI (DataD _ tyName tyVars _ constrs _) -> do 98 | let tyVarTypes = 99 | map 100 | ( \tyVar -> case tyVar of 101 | PlainTV nm _ -> VarT nm 102 | KindedTV nm _ kd -> SigT (VarT nm) kd 103 | ) 104 | tyVars 105 | ty = foldl AppT (ConT tyName) tyVarTypes 106 | decs <- mapM (uncurry (constructor2PatternDec ty)) (zip [0 ..] constrs) 107 | return $ (map fst decs) ++ (map snd decs) 108 | _ -> do 109 | reportError (show name ++ " is not a data type name") 110 | return [] 111 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-12.12 2 | packages: 3 | - . 4 | extra-deps: 5 | flags: {} 6 | extra-package-dbs: [] 7 | -------------------------------------------------------------------------------- /tests/RefTrans.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GADTs #-} 2 | 3 | module RefTrans where 4 | 5 | import System.Exit 6 | import System.IO 7 | 8 | import Test.StrictCheck 9 | 10 | notEqualRefTrans :: Eq a => String -> a -> a -> IO Bool 11 | notEqualRefTrans functionName x y = 12 | if x /= y 13 | then return True 14 | else do 15 | putStrLn $ "!!! " ++ functionName ++ " referentially opaque" 16 | return False 17 | 18 | checkRefTrans :: IO () 19 | checkRefTrans = do 20 | let strict = snd (observe1 id (\() -> ()) ()) 21 | let lazy = snd (observe1 id (\_ -> ()) ()) 22 | 23 | observe1_ok <- notEqualRefTrans "observe1" strict lazy 24 | 25 | let strict' = snd (observeNP id (\(I () :* Nil) -> ()) (I () :* Nil)) 26 | let lazy' = snd (observeNP id (\(I _ :* Nil) -> ()) (I () :* Nil)) 27 | 28 | observe_ok <- notEqualRefTrans "observe" strict' lazy' 29 | 30 | let strict'' = snd (observe id (\() -> ()) ()) 31 | let lazy'' = snd (observe id (\_ -> ()) ()) 32 | 33 | observeNP_ok <- notEqualRefTrans "observeNP" strict'' lazy'' 34 | 35 | if and [observe1_ok, observe_ok, observeNP_ok] 36 | then return () 37 | else putStrLn "\n" >> hFlush stdout >> exitFailure 38 | -------------------------------------------------------------------------------- /tests/Specs.hs: -------------------------------------------------------------------------------- 1 | module Specs where 2 | 3 | import Test.QuickCheck 4 | 5 | import Test.StrictCheck 6 | import Test.StrictCheck.Examples.Lists 7 | import Test.StrictCheck.Examples.Map 8 | 9 | runSpecs :: IO () 10 | runSpecs = do 11 | putStrLn "Checking length_spec..." 12 | strictCheckSpecExact length_spec (length :: [Int] -> Int) 13 | 14 | putStrLn "Checking take_spec..." 15 | strictCheckSpecExact take_spec (take :: Int -> [Int] -> [Int]) 16 | 17 | putStrLn "Checking map_spec..." 18 | strictCheckSpecExact map_spec (map :: (Int -> [Int]) -> [Int] -> [[Int]]) 19 | 20 | putStrLn "Checking rot_spec..." 21 | strictCheckSpecExact rot_spec (rot :: [Int] -> [Int] -> [Int]) 22 | 23 | putStrLn "Checking append_spec..." 24 | strictCheckSpecExact append_spec ((++) :: [Int] -> [Int] -> [Int]) 25 | 26 | putStrLn "Checking reverse_spec..." 27 | strictCheckSpecExact reverse_spec (reverse :: [Int] -> [Int]) 28 | 29 | putStrLn "Checking knapsack..." 30 | strictCheckWithResults 31 | stdArgs{maxSize=100, maxSuccess=500} 32 | shrinkViaArbitrary 33 | genViaProduce 34 | strictnessViaSized 35 | iterSolution_spec 36 | iterSolutionWithKey >>= print 37 | 38 | return () 39 | -------------------------------------------------------------------------------- /tests/Tests.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Specs 4 | import RefTrans 5 | 6 | main :: IO () 7 | main = do 8 | -- specification unit tests 9 | runSpecs 10 | -- regression test for issue #2 (CSE breaks referential transparency) 11 | checkRefTrans 12 | --------------------------------------------------------------------------------