├── img └── dice.jpg ├── .gitignore ├── test ├── Main.purs └── Foo.purs ├── package.json ├── .jshintrc ├── .jscsrc ├── LICENSE ├── .travis.yml ├── src ├── Jack │ ├── Runner.js │ ├── Runner.purs │ ├── Gen.purs │ ├── Random.purs │ ├── Shrink.purs │ ├── Seed.purs │ ├── Tree.purs │ ├── Property.purs │ └── Combinators.purs └── Jack.purs ├── bower.json └── README.md /img/dice.jpg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/jacobstanley/purescript-jack/HEAD/img/dice.jpg -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | /bower_components/ 2 | /node_modules/ 3 | /.pulp-cache/ 4 | /output/ 5 | /.psci* 6 | /src/.webpack.js 7 | -------------------------------------------------------------------------------- /test/Main.purs: -------------------------------------------------------------------------------- 1 | module Test.Main ( 2 | main 3 | ) where 4 | 5 | import Effect (Effect) 6 | 7 | import Jack.Runner (jackMain) 8 | 9 | import Prelude 10 | 11 | main :: Effect Unit 12 | main = 13 | jackMain [ 14 | "Test.Foo" 15 | ] 16 | -------------------------------------------------------------------------------- /package.json: -------------------------------------------------------------------------------- 1 | { 2 | "private": true, 3 | "scripts": { 4 | "clean": "rimraf output && rimraf .pulp-cache", 5 | "build": "jshint src && jscs src && pulp build", 6 | "test": "pulp test" 7 | }, 8 | "devDependencies": { 9 | "jscs": "^2.8.0", 10 | "jshint": "^2.9.1", 11 | "pulp": "^12.4.0", 12 | "purescript": "^0.12.5", 13 | "purescript-psa": "^0.7.3", 14 | "rimraf": "^2.5.0" 15 | } 16 | } 17 | -------------------------------------------------------------------------------- /.jshintrc: -------------------------------------------------------------------------------- 1 | { 2 | "bitwise": true, 3 | "eqeqeq": true, 4 | "forin": true, 5 | "freeze": true, 6 | "funcscope": true, 7 | "futurehostile": true, 8 | "strict": "global", 9 | "latedef": true, 10 | "maxparams": 1, 11 | "noarg": true, 12 | "nocomma": true, 13 | "nonew": true, 14 | "notypeof": true, 15 | "singleGroups": true, 16 | "undef": true, 17 | "unused": true, 18 | "eqnull": true, 19 | "predef": ["exports", "require", "process"] 20 | } 21 | -------------------------------------------------------------------------------- /.jscsrc: -------------------------------------------------------------------------------- 1 | { 2 | "preset": "grunt", 3 | "disallowSpacesInFunctionExpression": null, 4 | "requireSpacesInFunctionExpression": { 5 | "beforeOpeningRoundBrace": true, 6 | "beforeOpeningCurlyBrace": true 7 | }, 8 | "disallowSpacesInAnonymousFunctionExpression": null, 9 | "requireSpacesInAnonymousFunctionExpression": { 10 | "beforeOpeningRoundBrace": true, 11 | "beforeOpeningCurlyBrace": true 12 | }, 13 | "disallowSpacesInsideObjectBrackets": null, 14 | "requireSpacesInsideObjectBrackets": "all", 15 | "validateQuoteMarks": "\"", 16 | "requireCurlyBraces": null 17 | } 18 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2016 Jacob Stanley 2 | 3 | Licensed under the Apache License, Version 2.0 (the "License"); 4 | you may not use this file except in compliance with the License. 5 | You may obtain a copy of the License at 6 | 7 | http://www.apache.org/licenses/LICENSE-2.0 8 | 9 | Unless required by applicable law or agreed to in writing, software 10 | distributed under the License is distributed on an "AS IS" BASIS, 11 | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 12 | See the License for the specific language governing permissions and 13 | limitations under the License. 14 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | branches: 2 | only: 3 | - master 4 | language: node_js 5 | dist: trusty 6 | sudo: required 7 | node_js: 8 8 | env: 9 | - PSC_VER=v0.11.3 10 | install: 11 | - export PATH=$HOME/purescript:$PATH 12 | - wget -O $HOME/purescript.tar.gz https://github.com/purescript/purescript/releases/download/$PSC_VER/linux64.tar.gz 13 | - tar -xvf $HOME/purescript.tar.gz -C $HOME/ 14 | - chmod a+x $HOME/purescript 15 | - npm install -g bower 16 | - npm install 17 | script: 18 | - bower install --production 19 | - npm run -s build 20 | - bower install 21 | - npm -s test 22 | after_success: 23 | - >- 24 | test $TRAVIS_TAG && 25 | echo $GITHUB_TOKEN | pulp login && 26 | echo y | pulp publish --no-push 27 | -------------------------------------------------------------------------------- /src/Jack/Runner.js: -------------------------------------------------------------------------------- 1 | "use strict"; 2 | 3 | exports.findProperties = function (module) { 4 | return function () { 5 | var properties = {}; 6 | var exports = require(module); 7 | 8 | for (var name in exports) { 9 | if (name.startsWith("prop_")) { 10 | var property = exports[name]; 11 | 12 | if (typeof property !== "object") { 13 | // not an object, so not a property test 14 | continue; 15 | } 16 | 17 | if (!property.hasOwnProperty("Property :: Gen Result")) { 18 | // 'Property :: Gen Result' field was missing, so not a property test 19 | continue; 20 | } 21 | 22 | properties[name] = property; 23 | } 24 | } 25 | 26 | return properties; 27 | }; 28 | }; 29 | 30 | exports.exit = function (code) { 31 | return function () { 32 | process.exit(code); 33 | }; 34 | }; 35 | -------------------------------------------------------------------------------- /bower.json: -------------------------------------------------------------------------------- 1 | { 2 | "name": "purescript-jack", 3 | "description": "QuickCheck with shrinking for free", 4 | "homepage": "https://github.com/jacobstanley/purescript-jack", 5 | "license": "Apache-2.0", 6 | "authors": [ 7 | "Jacob Stanley " 8 | ], 9 | "repository": { 10 | "type": "git", 11 | "url": "git://github.com/jacobstanley/purescript-jack.git" 12 | }, 13 | "ignore": [ 14 | "**/.*", 15 | "node_modules", 16 | "bower_components", 17 | "output", 18 | "test", 19 | "bower.json" 20 | ], 21 | "dependencies": { 22 | "purescript-prelude": "^4.1.0", 23 | "purescript-foldable-traversable": "^4.1.1", 24 | "purescript-int-53": "^4.0.0", 25 | "purescript-lists": "^5.4.0", 26 | "purescript-arrays": "^5.2.1", 27 | "purescript-foreign-object": "^2.0.1", 28 | "purescript-console": "^4.2.0", 29 | "purescript-random": "^4.0.0", 30 | "purescript-strings": "^4.0.1" 31 | }, 32 | "devDependencies": { 33 | "purescript-generics-rep": "^6.1.1", 34 | "purescript-psci-support": "^4.0.0" 35 | } 36 | } 37 | -------------------------------------------------------------------------------- /src/Jack.purs: -------------------------------------------------------------------------------- 1 | module Jack ( 2 | module X0 3 | , module X1 4 | , module X2 5 | , module X3 6 | , module X4 7 | , module X5 8 | ) where 9 | 10 | -- Can't import all 'as X' or we get a warning 11 | import Jack.Combinators (arrayOf, arrayOf1, arrayOfN, arrayOfN', boundedChar, boundedInt, chooseChar, chooseInt, elements, frequency, justOf, listOf, listOf1, listOfN, listOfN', maybeOf, noShrink, oneOf, oneOfRec, resize, scale, sized, suchThat, suchThatMaybe) as X0 12 | import Jack.Gen (Gen(..), mapRandom, mapTree, mkGen, mkGen_, reshrink, reshrinkLazy, runGen) as X1 13 | import Jack.Property (Property, Result(..), assertEq, assertNotEq, check, check', counterexample, forAll, forAllRender, mkProperty, printSample, printSampleTree, property, renderResult, sampleTree, unProperty, (=/=), (===)) as X2 14 | import Jack.Runner (checkModule, checkModules, jackMain) as X3 15 | import Jack.Shrink (consNub, halves, removes, sequenceShrink, sequenceShrinkList, sequenceShrinkOne, shrinkList, shrinkOne, shrinkTowards) as X4 16 | import Jack.Tree (Tree(..), expandTree, filterForest, filterTree, foldForest, foldTree, outcome, shrinks, unfoldForest, unfoldTree) as X5 17 | -------------------------------------------------------------------------------- /src/Jack/Runner.purs: -------------------------------------------------------------------------------- 1 | module Jack.Runner ( 2 | jackMain 3 | , checkModule 4 | , checkModules 5 | ) where 6 | 7 | import Data.Array as Array 8 | 9 | import Effect (Effect) 10 | import Effect.Console (log) 11 | 12 | import Foreign.Object (Object) 13 | import Foreign.Object as Object 14 | 15 | import Jack.Property (Property, check) 16 | 17 | import Prelude 18 | 19 | jackMain :: Array String -> Effect Unit 20 | jackMain modules = do 21 | ok <- checkModules modules 22 | unless ok $ exit 1 23 | 24 | checkModule :: String -> Effect Boolean 25 | checkModule moduleName = do 26 | let 27 | pyjamas b1 name prop = do 28 | log $ "=== " <> name <> " from " <> moduleName <> " ===" 29 | b2 <- check prop 30 | log $ "" 31 | pure $ b1 && b2 32 | 33 | props <- findProperties moduleName 34 | Object.foldM pyjamas true props 35 | 36 | checkModules :: Array String -> Effect Boolean 37 | checkModules modules = 38 | let 39 | loop b1 m = 40 | map (b1 && _) (checkModule m) 41 | in 42 | Array.foldM loop true modules 43 | 44 | foreign import findProperties :: String -> Effect (Object Property) 45 | 46 | foreign import exit :: Int -> Effect Unit 47 | -------------------------------------------------------------------------------- /test/Foo.purs: -------------------------------------------------------------------------------- 1 | module Test.Foo where 2 | 3 | import Control.Lazy (fix) 4 | 5 | import Data.Array as Array 6 | import Data.Foldable (elem) 7 | import Data.Generic.Rep (class Generic) 8 | import Data.Generic.Rep.Show (genericShow) 9 | import Data.Maybe (Maybe(..)) 10 | import Data.String (Pattern(..), contains) 11 | import Data.String.CodeUnits (fromCharArray, toCharArray) 12 | 13 | import Jack.Combinators (boundedInt, chooseInt, elements, oneOfRec, arrayOf) 14 | import Jack.Gen (Gen, reshrink) 15 | import Jack.Property (Property, property, forAll) 16 | 17 | import Prelude 18 | 19 | data Exp = 20 | Lit Int 21 | | Var String 22 | | Lam String Exp 23 | | App Exp Exp 24 | 25 | derive instance genericExp :: Generic Exp _ 26 | 27 | derive instance eqExp :: Eq Exp 28 | 29 | instance showExp :: Show Exp where 30 | show x = 31 | genericShow x 32 | 33 | genName :: Gen String 34 | genName = 35 | elements ["x", "y", "z", "w"] 36 | 37 | shrinkExp :: Exp -> Array Exp 38 | shrinkExp xx = 39 | case xx of 40 | Lam _ x -> 41 | [x] 42 | App x y -> 43 | [x, y] 44 | _ -> 45 | [] 46 | 47 | genExp :: Gen Exp 48 | genExp = 49 | fix $ \exp -> 50 | reshrink shrinkExp $ 51 | oneOfRec [ 52 | Lit <$> boundedInt 53 | , Var <$> genName 54 | ] [ 55 | Lam <$> genName <*> exp 56 | , App <$> exp <*> exp 57 | ] 58 | 59 | prop_example :: Property 60 | prop_example = 61 | forAll genExp \x0 -> 62 | property $ x0 /= Var "never" 63 | 64 | prop_salamander :: Property 65 | prop_salamander = 66 | forAll (chooseInt 0 5) \x -> 67 | forAll (chooseInt 6 10) \y -> 68 | property $ x /= y 69 | 70 | genAlphaNum :: Gen Char 71 | genAlphaNum = 72 | elements $ toCharArray "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789" 73 | 74 | genAlphaNumString :: Gen String 75 | genAlphaNumString = 76 | map fromCharArray $ arrayOf genAlphaNum 77 | 78 | prop_strings :: Property 79 | prop_strings = 80 | forAll genAlphaNumString \xs -> 81 | property $ not $ contains (Pattern "#") xs 82 | 83 | genEven :: Gen Int 84 | genEven = 85 | map (\x -> (x / 2) * 2) $ 86 | boundedInt 87 | 88 | genEvenString :: Gen String 89 | genEvenString = 90 | map show genEven 91 | 92 | evens :: Array Char 93 | evens = 94 | toCharArray "02468" 95 | 96 | prop_even_strings_end_with_evens :: Property 97 | prop_even_strings_end_with_evens = 98 | forAll genEvenString \str -> 99 | case Array.last $ toCharArray str of 100 | Nothing -> 101 | property false 102 | Just x -> 103 | property $ elem x evens 104 | -------------------------------------------------------------------------------- /src/Jack/Gen.purs: -------------------------------------------------------------------------------- 1 | module Jack.Gen ( 2 | Gen(..) 3 | , runGen 4 | , mkGen 5 | , mkGen_ 6 | , mapRandom 7 | , mapTree 8 | , reshrink 9 | , reshrinkLazy 10 | ) where 11 | 12 | import Control.Lazy (class Lazy, defer) 13 | 14 | import Data.List.Lazy as Lazy 15 | import Data.Tuple (Tuple(..)) 16 | 17 | import Jack.Random (Random(..), runRandom) 18 | import Jack.Seed (Seed, splitSeed) 19 | import Jack.Tree (Tree, unfoldTree, expandTree) 20 | 21 | import Prelude 22 | 23 | 24 | -- | A generator for random values of type @a@ that includes all the possible 25 | -- | shrink scenarios for @a@. 26 | newtype Gen a = 27 | Gen (Random (Tree a)) 28 | 29 | runGen :: forall a. Gen a -> Random (Tree a) 30 | runGen (Gen gen) = 31 | gen 32 | 33 | -- | Create a 'Gen' from a shrink function and a 'Random'. 34 | mkGen :: forall a. (a -> Lazy.List a) -> Random a -> Gen a 35 | mkGen shr = 36 | Gen <<< map (unfoldTree identity shr) 37 | 38 | -- | Create a non-shrinking 'Gen' from a 'Random'. 39 | mkGen_ :: forall a. Random a -> Gen a 40 | mkGen_ = 41 | mkGen $ const Lazy.nil 42 | 43 | -- | Map over the 'Random' inside of 'Gen'. 44 | mapRandom :: forall a b. (Random (Tree a) -> Random (Tree b)) -> Gen a -> Gen b 45 | mapRandom f = 46 | Gen <<< f <<< runGen 47 | 48 | -- | Map over the 'Tree' inside a 'Gen'. 49 | mapTree :: forall a b. (Tree a -> Tree b) -> Gen a -> Gen b 50 | mapTree = 51 | mapRandom <<< map 52 | 53 | -- | Apply an additional shrinker to all generated trees. 54 | reshrink :: forall a. (a -> Array a) -> Gen a -> Gen a 55 | reshrink f = 56 | reshrinkLazy (Lazy.fromFoldable <<< f) 57 | 58 | -- | Apply an additional shrinker to all generated trees. 59 | reshrinkLazy :: forall a. (a -> Lazy.List a) -> Gen a -> Gen a 60 | reshrinkLazy = 61 | mapTree <<< expandTree 62 | 63 | ------------------------------------------------------------------------ 64 | -- Instances 65 | 66 | instance functorGen :: Functor Gen where 67 | map f = 68 | Gen <<< map (map f) <<< runGen 69 | 70 | instance applyGen :: Apply Gen where 71 | apply f x = 72 | Gen $ 73 | (<*>) <$> runGen f <*> runGen x 74 | 75 | instance applicativeGen :: Applicative Gen where 76 | pure = 77 | Gen <<< pure <<< pure 78 | 79 | instance bindGen :: Bind Gen where 80 | bind m0 k0 = 81 | let 82 | bindRandom :: forall a b. Random (Tree a) -> (a -> Random (Tree b)) -> Random (Tree b) 83 | bindRandom m k = 84 | Random \seed0 size -> 85 | case splitSeed seed0 of 86 | Tuple seed1 seed2 -> 87 | let 88 | run :: forall x. Seed -> Random x -> x 89 | run seed random = 90 | runRandom seed size random 91 | in 92 | bind (run seed1 m) (run seed2 <<< k) 93 | in 94 | Gen $ bindRandom (runGen m0) (runGen <<< k0) 95 | 96 | instance monadGen :: Monad Gen 97 | 98 | instance lazyGen :: Lazy (Gen a) where 99 | defer f = 100 | Gen $ defer (runGen <<< f) 101 | -------------------------------------------------------------------------------- /src/Jack/Random.purs: -------------------------------------------------------------------------------- 1 | module Jack.Random ( 2 | Size 3 | , Random(..) 4 | , runRandom 5 | 6 | , sized 7 | , resize 8 | 9 | , chooseInt 10 | 11 | -- ** Unsafe 12 | , unsafeChooseInt53 13 | 14 | -- ** Utils 15 | , replicateRecM 16 | ) where 17 | 18 | import Control.Lazy (class Lazy) 19 | import Control.Monad.Rec.Class (class MonadRec, Step(..), tailRec, tailRecM) 20 | 21 | import Data.Int53 (Int53) 22 | import Data.Int53 as Int53 23 | import Data.List (List(..)) 24 | import Data.Tuple (Tuple(..), fst) 25 | 26 | import Jack.Seed (Seed, splitSeed, nextInt53) 27 | 28 | import Prelude 29 | 30 | 31 | -- | Tests are parameterized by the size of the randomly-generated data, 32 | -- | the meaning of which depends on the particular generator used. 33 | type Size = 34 | Int 35 | 36 | --- | A generator for random values of type @a@. 37 | newtype Random a = 38 | Random (Seed -> Size -> a) 39 | 40 | -- | Run a random generator. 41 | runRandom :: forall a. Seed -> Size -> Random a -> a 42 | runRandom seed size (Random r) = 43 | r seed size 44 | 45 | -- | Used to construct generators that depend on the size parameter. 46 | sized :: forall a. (Size -> Random a) -> Random a 47 | sized f = 48 | Random $ \seed size -> 49 | runRandom seed size (f size) 50 | 51 | -- | Overrides the size parameter. Returns a generator which uses the 52 | -- | given size instead of the runtime-size parameter. 53 | resize :: forall a. Size -> Random a -> Random a 54 | resize newSize r = 55 | Random $ \seed _ -> 56 | runRandom seed (max 1 newSize) r 57 | 58 | -- | /This is not safe when (hi - lo) > 53-bits/ 59 | unsafeChooseInt53 :: Int53 -> Int53 -> Random Int53 60 | unsafeChooseInt53 lo hi = 61 | Random $ \seed _ -> 62 | fst $ nextInt53 lo hi seed 63 | 64 | -- | Generates a random element in the given inclusive range. 65 | chooseInt :: Int -> Int -> Random Int 66 | chooseInt lo hi = 67 | map Int53.toInt $ 68 | unsafeChooseInt53 (Int53.fromInt lo) (Int53.fromInt hi) 69 | 70 | -- | Tail recursive replicate. 71 | replicateRecM :: forall m a. MonadRec m => Int -> m a -> m (List a) 72 | replicateRecM k m = 73 | let 74 | go { acc, n } = 75 | if n <= 0 then 76 | pure $ Done acc 77 | else 78 | map (\x -> Loop { acc: Cons x acc, n: n - 1 }) m 79 | in 80 | tailRecM go { acc: Nil, n: k } 81 | 82 | ------------------------------------------------------------------------ 83 | -- Instances 84 | 85 | instance functorRandom :: Functor Random where 86 | map f r = 87 | Random $ \seed size -> 88 | f (runRandom seed size r) 89 | 90 | instance applyRandom :: Apply Random where 91 | apply = 92 | ap 93 | 94 | instance applicativeRandom :: Applicative Random where 95 | pure x = 96 | Random $ \_ _ -> 97 | x 98 | 99 | instance bindRandom :: Bind Random where 100 | bind r k = 101 | Random $ \seed size -> 102 | case splitSeed seed of 103 | Tuple seed1 seed2 -> 104 | runRandom seed2 size <<< k $ 105 | runRandom seed1 size r 106 | 107 | instance monadRandom :: Monad Random 108 | 109 | instance monadRecRandom :: MonadRec Random where 110 | tailRecM k a0 = 111 | let 112 | go { seed, size, a } = 113 | case splitSeed seed of 114 | Tuple seed1 seed2 -> 115 | case runRandom seed1 size $ k a of 116 | Loop a1 -> 117 | Loop { seed: seed2, size, a: a1 } 118 | Done b -> 119 | Done b 120 | in 121 | Random $ \seed size -> 122 | tailRec go { seed, size, a: a0 } 123 | 124 | instance lazyRandom :: Lazy (Random a) where 125 | defer f = 126 | Random $ \seed size -> 127 | runRandom seed size $ f unit 128 | -------------------------------------------------------------------------------- /src/Jack/Shrink.purs: -------------------------------------------------------------------------------- 1 | module Jack.Shrink where 2 | 3 | import Data.List (List(..)) 4 | import Data.List as List 5 | import Data.List.Lazy as Lazy 6 | 7 | import Jack.Tree (Tree(..), outcome, shrinks) 8 | 9 | import Prelude 10 | 11 | -- | Shrink an integral by edging towards a destination number. 12 | shrinkTowards :: forall a. Ord a => EuclideanRing a => a -> a -> Lazy.List a 13 | shrinkTowards destination x = 14 | if destination == x then 15 | Lazy.nil 16 | else 17 | let 18 | two = 19 | one + one 20 | 21 | -- We need to halve our operands before subtracting them as they may be using 22 | -- the full range of the type (i.e. 'minBound' and 'maxBound' for 'Int32') 23 | diff = 24 | (x `div` two) - (destination `div` two) 25 | in 26 | -- We make up for halving the inputs by explicitly prepending the 27 | -- destination as the first element of the list. 28 | destination `consNub` map (\y -> x - y) (halves diff) 29 | 30 | consNub :: forall a. Eq a => a -> Lazy.List a -> Lazy.List a 31 | consNub x ys0 = 32 | case Lazy.step ys0 of 33 | Lazy.Nil -> 34 | Lazy.singleton x 35 | Lazy.Cons y ys -> 36 | if x == y then 37 | Lazy.cons y ys 38 | else 39 | Lazy.cons x $ Lazy.cons y ys 40 | 41 | -- | Turn a list of trees in to a tree of lists, opting to shrink only the 42 | -- | elements of the list (i.e. the size of the list will always be the same). 43 | sequenceShrinkOne :: forall a. List (Tree a) -> Tree (List a) 44 | sequenceShrinkOne = 45 | sequenceShrink (\xs -> shrinkOne shrinks xs) 46 | 47 | -- | Turn a list of trees in to a tree of lists, opting to shrink both the list 48 | -- | itself and the elements in the list during traversal. 49 | sequenceShrinkList :: forall a. List (Tree a) -> Tree (List a) 50 | sequenceShrinkList = 51 | sequenceShrink (\xs -> shrinkList xs <> shrinkOne shrinks xs) 52 | 53 | -- | Turn a list of trees in to a tree of lists, using the supplied function to 54 | -- | merge shrinking options. 55 | sequenceShrink :: 56 | forall a. 57 | (List (Tree a) -> Lazy.List (List (Tree a))) -> 58 | List (Tree a) -> 59 | Tree (List a) 60 | sequenceShrink merge xs = 61 | Node 62 | (map outcome xs) 63 | (map (sequenceShrink merge) $ merge xs) 64 | 65 | -- | Shrink each of the elements in input list using the supplied shrinking 66 | -- | function. 67 | shrinkOne :: forall a. (a -> Lazy.List a) -> List a -> Lazy.List (List a) 68 | shrinkOne shr xs00 = 69 | case xs00 of 70 | Nil -> 71 | Lazy.nil 72 | Cons x0 xs0 -> 73 | -- TODO refactor, was list comprehension 74 | (do x1 <- shr x0 75 | pure $ Cons x1 xs0) <> 76 | (do xs1 <- shrinkOne shr xs0 77 | pure $ Cons x0 xs1) 78 | 79 | -- | Produce a smaller permutation of the input list. 80 | shrinkList :: forall a. List a -> Lazy.List (List a) 81 | shrinkList xs = do 82 | Lazy.concatMap 83 | (\k -> removes k xs) 84 | (halves $ List.length xs) 85 | 86 | -- | Produces a list containing the results of halving a number over and over 87 | -- | again. 88 | -- | 89 | -- | > halves 30 == [30,15,7,3,1] 90 | -- | > halves 128 == [128,64,32,16,8,4,2,1] 91 | -- | > halves (-10) == [-10,-5,-2,-1] 92 | -- | 93 | halves :: forall a. Ord a => EuclideanRing a => a -> Lazy.List a 94 | halves = 95 | let 96 | two = 97 | one + one 98 | in 99 | Lazy.takeWhile (\x -> x /= zero) <<< 100 | Lazy.iterate (\x -> x `div` two) 101 | 102 | -- | Permutes a list by removing 'k' consecutive elements from it: 103 | -- | 104 | -- | > removes 2 [1,2,3,4,5,6] == [[3,4,5,6],[1,2,5,6],[1,2,3,4]] 105 | -- | 106 | removes :: forall a. Int -> List a -> Lazy.List (List a) 107 | removes k0 xs0 = 108 | let 109 | loop :: Int -> Int -> List a -> Lazy.List (List a) 110 | loop k n xs = 111 | let 112 | hd = List.take k xs 113 | tl = List.drop k xs 114 | in 115 | if k > n then 116 | Lazy.nil 117 | else if List.null tl then 118 | Lazy.singleton Nil 119 | else 120 | Lazy.cons tl $ map (\x -> hd <> x) (loop k (n - k) tl) 121 | in 122 | loop k0 (List.length xs0) xs0 123 | -------------------------------------------------------------------------------- /src/Jack/Seed.purs: -------------------------------------------------------------------------------- 1 | -- 2 | -- This is a port of GHC's System.Random implementation. 3 | -- 4 | -- This implementation uses the Portable Combined Generator of L'Ecuyer for 5 | -- 32-bit computers [1], transliterated by Lennart Augustsson. 6 | -- 7 | -- 1. Pierre L'Ecuyer 8 | -- Efficient and portable combined random number generators 9 | -- Comm ACM, 31(6), Jun 1988, pp742-749. 10 | -- 11 | module Jack.Seed ( 12 | Seed 13 | , mkSeed 14 | , randomSeed 15 | , nextMin 16 | , nextMax 17 | , nextSeed 18 | , nextInt53 19 | , splitSeed 20 | ) where 21 | 22 | import Data.Int.Bits ((.&.)) 23 | import Data.Int53 (Int53) 24 | import Data.Int53 as Int53 25 | import Data.Tuple (Tuple(..)) 26 | 27 | import Effect (Effect) 28 | import Effect.Random (randomInt) 29 | 30 | import Prelude 31 | 32 | -- | Splittable random number generator. 33 | data Seed = 34 | Seed Int Int 35 | 36 | -- | Create a new 'Seed' from a 32-bit integer. 37 | mkSeed :: Int -> Seed 38 | mkSeed s0 = 39 | let 40 | -- We want a non-negative number, but we can't just take the abs 41 | -- of s0 as -bottom == bottom. 42 | s = 43 | s0 .&. top 44 | 45 | -- The integer variables s1 and s2 must be initialized to values 46 | -- in the range [1, 2147483562] and [1, 2147483398] respectively. [1] 47 | s1 = 48 | s `mod` 2147483562 49 | 50 | q = 51 | s `div` 2147483562 52 | 53 | s2 = 54 | q `mod` 2147483398 55 | in 56 | Seed (s1 + 1) (s2 + 1) 57 | 58 | -- | Create a random 'Seed' using the system random number generator. 59 | randomSeed :: Effect Seed 60 | randomSeed = 61 | mkSeed <$> randomInt bottom top 62 | 63 | -- | The smallest possible value returned from 'next'. 64 | nextMin :: Int 65 | nextMin = 66 | 1 67 | 68 | -- | The largest possible value returned from 'next'. 69 | nextMax :: Int 70 | nextMax = 71 | 2147483562 72 | 73 | -- | Returns the next pseudo-random number in the sequence, and a new seed. 74 | nextSeed :: Seed -> Tuple Int Seed 75 | nextSeed (Seed s1 s2) = 76 | let 77 | k = 78 | s1 `div` 53668 79 | 80 | s1' = 81 | 40014 * (s1 - k * 53668) - k * 12211 82 | 83 | s1'' = 84 | if s1' < 0 then 85 | s1' + 2147483563 86 | else 87 | s1' 88 | 89 | k' = 90 | s2 `div` 52774 91 | 92 | s2' = 93 | 40692 * (s2 - k' * 52774) - k' * 3791 94 | 95 | s2'' = 96 | if s2' < 0 then 97 | s2' + 2147483399 98 | else 99 | s2' 100 | 101 | z = 102 | s1'' - s2'' 103 | 104 | z' = 105 | if z < 1 then 106 | z + 2147483562 107 | else 108 | z 109 | in 110 | Tuple z' $ Seed (s1'') (s2'') 111 | 112 | -- | Generate a random 'Int53' in the specified range. 113 | -- | /Note this is not safe when (hi - lo) > 53-bits./ 114 | nextInt53 :: Int53 -> Int53 -> Seed -> Tuple Int53 Seed 115 | nextInt53 lo hi seed = 116 | if lo > hi then 117 | nextInt53 hi lo seed 118 | else 119 | let 120 | -- 121 | -- Probabilities of the most likely and least likely result will differ 122 | -- at most by a factor of (1 +- 1/q). Assuming Seed is uniform, of 123 | -- course. 124 | -- 125 | -- On average, log q / log b more random values will be generated than 126 | -- the minimum. 127 | -- 128 | b = 129 | Int53.fromInt nextMax - Int53.fromInt nextMin + one 130 | 131 | q = 132 | Int53.fromInt 1000 133 | 134 | k = 135 | hi - lo + one 136 | 137 | magtgt = 138 | k * q 139 | 140 | -- Generate random values until we exceed the target magnitude. 141 | loop mag v0 seed0 = 142 | if mag >= magtgt then 143 | Tuple v0 seed0 144 | else 145 | case nextSeed seed of 146 | Tuple x seed1 -> 147 | let 148 | v1 = 149 | v0 * b + (Int53.fromInt x - Int53.fromInt nextMin) 150 | in 151 | loop (mag * b) v1 seed1 152 | in 153 | case loop one zero seed of 154 | Tuple v seedN -> 155 | Tuple (lo + (v `mod` k)) seedN 156 | 157 | -- | Splits a random number generator in to two. 158 | splitSeed :: Seed -> Tuple Seed Seed 159 | splitSeed seed@(Seed s1 s2) = 160 | case nextSeed seed of 161 | Tuple _ (Seed t1 t2) -> 162 | let 163 | -- no statistical foundation for this! 164 | new_s1 = 165 | if s1 == 2147483562 then 166 | 1 167 | else 168 | s1 + 1 169 | 170 | new_s2 = 171 | if s2 == 1 then 172 | 2147483398 173 | else 174 | s2 - 1 175 | in 176 | Tuple 177 | (Seed new_s1 t2) 178 | (Seed t1 new_s2) 179 | -------------------------------------------------------------------------------- /src/Jack/Tree.purs: -------------------------------------------------------------------------------- 1 | module Jack.Tree ( 2 | Tree(..) 3 | , outcome 4 | , shrinks 5 | , foldTree 6 | , foldForest 7 | , unfoldTree 8 | , unfoldForest 9 | , expandTree 10 | , filterTree 11 | , filterForest 12 | ) where 13 | 14 | import Control.Extend (class Extend) 15 | import Control.Comonad (class Comonad) 16 | 17 | import Data.Array as Array 18 | import Data.Foldable (class Foldable, foldr, foldl, foldMap) 19 | import Data.List.Lazy as Lazy 20 | import Data.Traversable (class Traversable, traverse, sequence) 21 | 22 | import Prelude 23 | 24 | 25 | -- | A rose tree which represents a random generated outcome, and all the ways 26 | -- | in which it can be made smaller. 27 | -- | 28 | -- | This tree is exactly the same as 'Data.Tree' in every way except that 29 | -- | Applicative '<*>' and Monad '>>=' walk the tree in the reverse order. This 30 | -- | modification is critical for shrinking to reach a minimal counterexample. 31 | data Tree a = 32 | Node a (Lazy.List (Tree a)) 33 | 34 | instance showTree :: Show a => Show (Tree a) where 35 | show (Node x xs) = 36 | "(Node " <> show x <> " " <> show (Array.fromFoldable xs) <> ")" 37 | 38 | -- | The generated outcome. 39 | outcome :: forall a. Tree a -> a 40 | outcome (Node x _) = 41 | x 42 | 43 | -- | All the possible shrinks of this outcome. This should be ordered 44 | -- | smallest to largest as if property still fails with the first shrink in 45 | -- | the list then we will commit to that path and none of the others will 46 | -- | be tried (i.e. there is no backtracking). 47 | shrinks :: forall a. Tree a -> Lazy.List (Tree a) 48 | shrinks (Node _ xs) = 49 | xs 50 | 51 | instance functorTree :: Functor Tree where 52 | map f (Node x xs) = 53 | Node (f x) $ map (map f) xs 54 | 55 | instance foldableTree :: Foldable Tree where 56 | foldr o b (Node x xs) = 57 | x `o` foldr (flip $ foldr o) b xs 58 | 59 | foldl o b (Node x xs) = 60 | foldl (foldl o) (b `o` x) xs 61 | 62 | foldMap f (Node x xs) = 63 | f x <> foldMap (foldMap f) xs 64 | 65 | instance traversableTree :: Traversable Tree where 66 | traverse f (Node x xs) = 67 | Node <$> f x <*> traverse (traverse f) xs 68 | 69 | sequence (Node x xs) = 70 | Node <$> x <*> traverse sequence xs 71 | 72 | instance applicativeTree :: Applicative Tree where 73 | pure x = 74 | Node x Lazy.nil 75 | 76 | instance applyTree :: Apply Tree where 77 | apply (Node f fs) x@(Node y ys) = 78 | Node (f y) $ 79 | -- Data.Tree would have: 80 | -- map (map f) ys <> 81 | -- map (flip apply x) fs 82 | map (flip apply x) fs <> 83 | map (map f) ys 84 | 85 | instance bindTree :: Bind Tree where 86 | bind (Node x xs) k = 87 | case k x of 88 | Node y ys -> 89 | Node y $ 90 | -- Data.Tree would have: ys <> map (flip bind k) xs 91 | map (flip bind k) xs <> ys 92 | 93 | instance monadTree :: Monad Tree 94 | 95 | instance extendTree :: Extend Tree where 96 | extend f = 97 | map f <<< duplicateTree 98 | 99 | -- | Comonad duplicate for a 'Tree'. 100 | duplicateTree :: forall a. Tree a -> Tree (Tree a) 101 | duplicateTree x@(Node _ ys) = 102 | Node x (map duplicateTree ys) 103 | 104 | instance comonadTree :: Comonad Tree where 105 | extract (Node x _) = 106 | x 107 | 108 | -- | Fold over a 'Tree'. 109 | foldTree :: forall a b x. (a -> x -> b) -> (Lazy.List b -> x) -> Tree a -> b 110 | foldTree f g (Node x xs) = 111 | f x (foldForest f g xs) 112 | 113 | -- | Fold over a list of trees. 114 | foldForest :: forall a b x. (a -> x -> b) -> (Lazy.List b -> x) -> Lazy.List (Tree a) -> x 115 | foldForest f g = 116 | g <<< map (foldTree f g) 117 | 118 | -- | Build a 'Tree' from an unfolding function and a seed value. 119 | unfoldTree :: forall a b. (b -> a) -> (b -> Lazy.List b) -> b -> Tree a 120 | unfoldTree f g x = 121 | Node (f x) (unfoldForest f g x) 122 | 123 | -- | Build a list of trees from an unfolding function and a seed value. 124 | unfoldForest :: forall a b. (b -> a) -> (b -> Lazy.List b) -> b -> Lazy.List (Tree a) 125 | unfoldForest f g = 126 | map (unfoldTree f g) <<< g 127 | 128 | -- | Apply an additional unfolding function to an existing tree. 129 | -- | 130 | -- | The root outcome remains intact, only the shrinks are affected, this 131 | -- | applies recursively, so shrinks can only ever be added using this 132 | -- | function. 133 | -- | 134 | -- | If you want to replace the shrinks altogether, try: 135 | -- | 136 | -- | > unfoldTree f (outcome oldTree) 137 | -- | 138 | expandTree :: forall a. (a -> Lazy.List a) -> Tree a -> Tree a 139 | expandTree f (Node x xs) = 140 | -- 141 | -- Ideally we could put the 'unfoldForest' nodes before the 'fmap expandTree' 142 | -- nodes, so that we're culling from the top down and we would be able to 143 | -- terminate our search faster, but this prevents minimal shrinking. 144 | -- 145 | -- We'd need some kind of tree transpose to do this properly. 146 | -- 147 | Node x (map (expandTree f) xs <> unfoldForest identity f x) 148 | 149 | -- | Recursively discard any shrinks whose outcome does not pass the predicate. 150 | -- | /Note that the root outcome can never be discarded./ 151 | filterTree :: forall a. (a -> Boolean) -> Tree a -> Tree a 152 | filterTree f (Node x xs) = 153 | Node x (filterForest f xs) 154 | 155 | -- | Recursively discard any trees whose outcome does not pass the predicate. 156 | filterForest :: forall a. (a -> Boolean) -> Lazy.List (Tree a) -> Lazy.List (Tree a) 157 | filterForest f = 158 | map (filterTree f) <<< Lazy.filter (f <<< outcome) 159 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | [![Latest Release](http://img.shields.io/bower/v/purescript-jack.svg)](https://github.com/jacobstanley/purescript-jack/releases) 2 | [![Build Status](https://travis-ci.org/jacobstanley/purescript-jack.svg?branch=master)](https://travis-ci.org/jacobstanley/purescript-jack) 3 | 7 | 8 | # purescript-jack 9 | 10 | ``` 11 | Jack's love of dice has brought him here, where he has taken on the form 12 | of a PureScript library, in order to help you gamble with your propositions. 13 | ``` 14 | 15 | ![](img/dice.jpg) 16 | 17 | Jack is a testing library in the spirit of Hughes & Classen's 18 | [QuickCheck](https://web.archive.org/web/20160319204559/http://www.cs.tufts.edu/~nr/cs257/archive/john-hughes/quick.pdf). 19 | 20 | What makes it different is that instead of generating a random value and 21 | using a shrinking function after the fact, we generate the random value 22 | and all the possible shrinks in a rose tree, all at once. 23 | 24 | ## Why Jack? 25 | 26 | Generating the shrinks when you generate your initial value has many 27 | advantages. 28 | 29 | It is easy to maintain the invariants of a generator for example. With 30 | QuickCheck style shrinking if you do `chooseInt 100 200` and then try to 31 | shrink it, it will happily shrink to `0`. 32 | 33 | QuickCheck shrinking functions are also invariant, as the `a` appears on 34 | both sides of the arrow in the shrink function `a -> List a`. 35 | 36 | So if you imagine the following scenario: 37 | 38 | ```purescript 39 | newtype Foo = Foo String 40 | 41 | shrinkString :: String -> List String 42 | shrinkString = ... 43 | ``` 44 | 45 | `shrinkString` cannot be lifted to work over `Foo` without having 46 | a mapping in both directions. This breaks the beautiful applicative 47 | syntax that generators can be constructed with. Jack doesn't have this 48 | problem, a `Gen String` can be turned in to a `Gen Foo` using only 49 | `map`, but with the benefit that your `Foo` will be shrunk for free. 50 | 51 | ## Getting Started 52 | 53 | The easiest way to get started with Jack is to install it as a dev dependency: 54 | 55 | ``` 56 | $ bower install --save-dev purescript-jack 57 | ``` 58 | 59 | Then create a `test/Main.purs` as shown below: 60 | 61 | ```purescript 62 | module Test.Main ( 63 | main 64 | ) where 65 | 66 | import Effect (Effect) 67 | 68 | import Jack.Runner (jackMain) 69 | 70 | import Prelude 71 | 72 | main :: Effect Unit 73 | main = 74 | jackMain [ 75 | -- List all the modules which contain property tests here, for this 76 | -- example we have just one module: Test.DiceGames 77 | "Test.DiceGames" 78 | ] 79 | ``` 80 | 81 | Jack has a test runner, invoked via `jackMain`, which scans the given 82 | modules for properties. Any exported function of type `Property` with 83 | the prefix `prop_` will be found and exercised. 84 | 85 | Lets take a look at `test/DiceGames.purs` for a contrived example: 86 | 87 | ```purescript 88 | module Test.DiceGames where 89 | 90 | import Data.Array as Array 91 | import Data.Foldable (elem) 92 | import Data.Maybe (Maybe(..)) 93 | import Data.String.CodeUnits (toCharArray) 94 | 95 | import Jack (Property, Gen, property, forAll, boundedInt) 96 | 97 | import Prelude 98 | 99 | genEven :: Gen Int 100 | genEven = 101 | map (\x -> (x / 2) * 2) boundedInt 102 | 103 | genEvenString :: Gen String 104 | genEvenString = 105 | map show genEven 106 | 107 | evens :: Array Char 108 | evens = 109 | toCharArray "02468" 110 | 111 | prop_even_strings_end_with_evens :: Property 112 | prop_even_strings_end_with_evens = 113 | forAll genEvenString \str -> 114 | case Array.last $ toCharArray str of 115 | Nothing -> 116 | property false -- numbers should always have at least one digit 117 | Just x -> 118 | property $ elem x evens 119 | ``` 120 | 121 | Here we're verifying that even numbers always end with an even digit. We 122 | do this by generating random even numbers as strings and checking that 123 | the last character is what we expect. 124 | 125 | If we run this example using `pulp test` we get the following output: 126 | 127 | ``` 128 | $ pulp test 129 | * Building project in /home/jack/example 130 | * Build successful. 131 | * Running tests... 132 | === prop_even_strings_end_with_evens from Test.DiceGames === 133 | +++ OK, passed 100 tests. 134 | 135 | * Tests OK. 136 | ``` 137 | 138 | Let's sabotage the test so that we're generating odd numbers instead of 139 | evens: 140 | 141 | ```purescript 142 | genEven :: Gen Int 143 | genEven = 144 | map (\x -> (x / 2) * 2 + 1) boundedInt -- note the + 1 145 | ``` 146 | 147 | And run our example again with `pulp test`: 148 | 149 | ``` 150 | $ pulp test 151 | * Building project in /home/jack/example 152 | * Build successful. 153 | === prop_even_strings_end_with_evens from Test.Foo === 154 | *** Failed! Falsifiable (after 1 test and 1 shrink): 155 | "1" 156 | 157 | * ERROR: Subcommand terminated with exit code 1 158 | ``` 159 | 160 | You can see we get a failure, and after shrinking we're presented with 161 | the minimal possible counterexample, `"1"`. 162 | 163 | Note that we didn't have to do any extra work to get shrinking of our 164 | even or odd numbers. Even shrinking a string which must be a constrained 165 | number happens automatically. With traditional QuickCheck shrinking we 166 | would have had to parse the string, shrink the number, check that's it's 167 | still even (or odd), and then convert it back to a string again. 168 | 169 | ## Limitations 170 | 171 | Many of the features you'd expect from a QuickCheck library are still 172 | missing, but we'll get there eventually: 173 | 174 | - Monadic / effectful tests 175 | - Generating functions 176 | - Model testing 177 | 178 | Jack doesn't have an `Arbitrary` type class, by design. `Arbitrary` 179 | instances often end up being orphans and I consider this problematic, 180 | especially in PureScript. The main purpose of the `Arbitrary` class as 181 | I see it is to link the generator with a shrink function, this isn't 182 | required with Jack so `Arbitrary` has been eliminated. 183 | 184 | This library is still very new, and I wouldn't be surprised if some of 185 | the combinators are still a bit buggy. Jack relies heavily on laziness 186 | and it wasn't something that I had to worry about when I wrote it for 187 | Haskell, so I'm fixing stack overflows and out of memory errors as they 188 | appear. 189 | 190 | ## Developing 191 | 192 | Ensure PureScript is installed and available on your path. [Getting 193 | started instructions](http://www.purescript.org/learn/getting-started/) 194 | are available on the PureScript site. 195 | 196 | Then run `bower` to install the PureScript packages: 197 | 198 | bower install 199 | 200 | Finally, run `pulp` to build `purescript-jack`: 201 | 202 | pulp build 203 | pulp test 204 | -------------------------------------------------------------------------------- /src/Jack/Property.purs: -------------------------------------------------------------------------------- 1 | module Jack.Property ( 2 | Result(..) 3 | , renderResult 4 | 5 | , Property 6 | , mkProperty 7 | , unProperty 8 | , property 9 | 10 | , check 11 | , check' 12 | , forAll 13 | , forAllRender 14 | , counterexample 15 | , assertEq 16 | , assertNotEq 17 | , (===) 18 | , (=/=) 19 | 20 | , sampleTree 21 | , printSample 22 | , printSampleTree 23 | ) where 24 | 25 | import Control.Monad.Rec.Class (Step(..), tailRec) 26 | 27 | import Data.Foldable (for_, foldMap, intercalate) 28 | import Data.List (List(..)) 29 | import Data.List as List 30 | import Data.List.Lazy as Lazy 31 | import Data.Maybe (Maybe(..)) 32 | import Data.Maybe.First (First(..)) 33 | import Data.Newtype (unwrap) 34 | import Data.Traversable (traverse_) 35 | import Data.Tuple (Tuple(..)) 36 | 37 | import Effect (Effect) 38 | import Effect.Console (log) 39 | 40 | import Jack.Gen (Gen(..), runGen) 41 | import Jack.Random (Size, runRandom, replicateRecM) 42 | import Jack.Seed (randomSeed, splitSeed) 43 | import Jack.Tree (Tree(..), outcome, shrinks) 44 | 45 | import Prelude 46 | 47 | 48 | data Result = 49 | Success 50 | | Failure (List String) 51 | 52 | instance showResult :: Show Result where 53 | show xx = 54 | case xx of 55 | Success -> 56 | "Success" 57 | Failure xs -> 58 | "(Failure " <> show xs <> ")" 59 | 60 | renderResult :: Result -> String 61 | renderResult xx = 62 | case xx of 63 | Success -> 64 | "Success" 65 | Failure xs -> 66 | intercalate "\n" xs 67 | 68 | mapFailure :: (List String -> List String) -> Result -> Result 69 | mapFailure f xx = 70 | case xx of 71 | Success -> 72 | Success 73 | Failure xs -> 74 | Failure $ f xs 75 | 76 | newtype Property = 77 | Property { "Property :: Gen Result" :: Gen Result } 78 | 79 | mkProperty :: Gen Result -> Property 80 | mkProperty gen = 81 | Property { "Property :: Gen Result": gen } 82 | 83 | unProperty :: Property -> Gen Result 84 | unProperty (Property x) = 85 | x."Property :: Gen Result" 86 | 87 | mapGen :: (Gen Result -> Gen Result) -> Property -> Property 88 | mapGen f = 89 | mkProperty <<< f <<< unProperty 90 | 91 | property :: Boolean -> Property 92 | property b = 93 | if b then 94 | mkProperty $ pure Success 95 | else 96 | mkProperty <<< pure $ Failure List.Nil 97 | 98 | counterexample :: String -> Property -> Property 99 | counterexample msg = 100 | mapGen <<< map <<< mapFailure $ Cons msg 101 | 102 | forAll :: forall a. Show a => Gen a -> (a -> Property) -> Property 103 | forAll = 104 | forAllRender show 105 | 106 | forAllRender :: forall a. (a -> String) -> Gen a -> (a -> Property) -> Property 107 | forAllRender render gen f = 108 | let 109 | prepend x = 110 | unProperty $ counterexample (render x) (f x) 111 | in 112 | mkProperty $ bind gen prepend 113 | 114 | check :: Property -> Effect Boolean 115 | check = 116 | check' 100 117 | 118 | check' :: Int -> Property -> Effect Boolean 119 | check' n p = do 120 | let 121 | random = 122 | runGen $ unProperty p 123 | 124 | nextSize size = 125 | if size >= 100 then 126 | 1 127 | else 128 | size + 1 129 | 130 | loop { seed, size, tests } = 131 | if tests == n then 132 | Done { 133 | tests 134 | , result: pure Success 135 | } 136 | else 137 | case splitSeed seed of 138 | Tuple seed1 seed2 -> 139 | let 140 | result = 141 | runRandom seed1 size random 142 | in 143 | case outcome result of 144 | Failure _ -> 145 | Done { 146 | tests: tests + 1 147 | , result 148 | } 149 | 150 | Success -> 151 | Loop { 152 | seed: seed2 153 | , size: nextSize size 154 | , tests: tests + 1 155 | } 156 | 157 | seed <- randomSeed 158 | 159 | let 160 | x = 161 | tailRec loop { seed, size: 1, tests: 0 } 162 | 163 | case takeSmallest x.result 0 of 164 | Nothing -> do 165 | log $ "+++ OK, passed " <> renderTests x.tests <> "." 166 | pure true 167 | Just { nshrinks, msgs } -> do 168 | log $ "*** Failed! Falsifiable (after " <> 169 | renderTests x.tests <> renderShrinks nshrinks <> "):" 170 | log $ renderResult $ Failure msgs 171 | pure false 172 | 173 | renderTests :: Int -> String 174 | renderTests n = 175 | case n of 176 | 1 -> 177 | "1 test" 178 | _ -> 179 | show n <> " tests" 180 | 181 | renderShrinks :: Int -> String 182 | renderShrinks n = 183 | case n of 184 | 0 -> 185 | "" 186 | 1 -> 187 | " and 1 shrink" 188 | _ -> 189 | " and " <> show n <> " shrinks" 190 | 191 | takeSmallest :: Tree Result -> Int -> Maybe { nshrinks :: Int, msgs :: List String } 192 | takeSmallest (Node x xs) nshrinks = 193 | case x of 194 | Success -> 195 | Nothing 196 | Failure msgs -> 197 | case firstFailure xs of 198 | Nothing -> 199 | Just { nshrinks, msgs } 200 | Just tree -> 201 | takeSmallest tree (nshrinks + 1) 202 | 203 | takeFailure :: Tree Result -> Maybe (Tree Result) 204 | takeFailure t@(Node x _) = 205 | case x of 206 | Success -> 207 | Nothing 208 | Failure _ -> 209 | Just t 210 | 211 | firstFailure :: Lazy.List (Tree Result) -> Maybe (Tree Result) 212 | firstFailure = 213 | unwrap <<< foldMap (First <<< takeFailure) 214 | 215 | -- | Generate some example trees. 216 | sampleTree :: forall a. Size -> Int -> Gen a -> Effect (List (Tree a)) 217 | sampleTree size count (Gen r) = do 218 | seed <- randomSeed 219 | pure <<< runRandom seed size $ 220 | replicateRecM count r 221 | 222 | -- | Generate some example outcomes (and shrinks) and prints them to 'stdout'. 223 | printSample :: forall a. Show a => Gen a -> Effect Unit 224 | printSample gen = do 225 | forest <- map (List.take 5) $ sampleTree 10 5 gen 226 | for_ forest $ \tree -> do 227 | log "=== Outcome ===" 228 | log <<< show $ outcome tree 229 | log "=== Shrinks ===" 230 | traverse_ (log <<< show <<< outcome) $ shrinks tree 231 | log "" 232 | 233 | printSampleTree :: forall a. Show a => Gen a -> Effect Unit 234 | printSampleTree gen = do 235 | forest <- map (List.take 1) $ sampleTree 10 1 gen 236 | for_ forest $ \tree -> do 237 | log $ show tree 238 | 239 | assertEq :: forall a. Eq a => Show a => a -> a -> Property 240 | assertEq x y = 241 | let 242 | render a b = show a <> " /= " <> show b 243 | in 244 | counterexample "=== Not equal ===" $ 245 | counterexample (render x y) (property (x == y)) 246 | 247 | assertNotEq :: forall a. Eq a => Show a => a -> a -> Property 248 | assertNotEq x y = 249 | let 250 | render a b = show a <> " == " <> show b 251 | in 252 | counterexample "=== Equal ===" $ 253 | counterexample (render x y) (property (x /= y)) 254 | 255 | infix 4 assertEq as === 256 | 257 | infix 4 assertNotEq as =/= 258 | -------------------------------------------------------------------------------- /src/Jack/Combinators.purs: -------------------------------------------------------------------------------- 1 | module Jack.Combinators ( 2 | noShrink 3 | , sized 4 | , resize 5 | , scale 6 | , chooseChar 7 | , chooseInt 8 | , boundedChar 9 | , boundedInt 10 | , frequency 11 | , elements 12 | , oneOf 13 | , oneOfRec 14 | , listOf 15 | , listOf1 16 | , listOfN 17 | , listOfN' 18 | , arrayOf 19 | , arrayOf1 20 | , arrayOfN 21 | , arrayOfN' 22 | , maybeOf 23 | , justOf 24 | , suchThat 25 | , suchThatMaybe 26 | ) where 27 | 28 | import Control.Monad.Rec.Class (Step(..), tailRecM2) 29 | 30 | import Data.Array as Array 31 | import Data.Char (toCharCode, fromCharCode) 32 | import Data.Foldable (sum) 33 | import Data.List (List(..)) 34 | import Data.List as List 35 | import Data.List.Lazy as Lazy 36 | import Data.Maybe (Maybe(..), isJust) 37 | import Data.NonEmpty (NonEmpty(..)) 38 | import Data.Tuple (Tuple(..), fst) 39 | 40 | import Jack.Gen (Gen(..), runGen, mkGen, mapTree, mapRandom) 41 | import Jack.Random (Random, replicateRecM) 42 | import Jack.Random as Random 43 | import Jack.Shrink (shrinkTowards, sequenceShrinkList, sequenceShrinkOne) 44 | import Jack.Tree (Tree(..), outcome, filterTree) 45 | 46 | import Partial.Unsafe as Savage 47 | 48 | import Prelude 49 | 50 | 51 | -- | Prevent a 'Gen' from shrinking. 52 | noShrink :: forall a. Gen a -> Gen a 53 | noShrink = 54 | mapTree $ \(Node x _) -> 55 | Node x Lazy.nil 56 | 57 | -- | Construct a 'Gen' that depends on the size parameter. 58 | sized :: forall a. (Int -> Gen a) -> Gen a 59 | sized f = 60 | Gen $ Random.sized (runGen <<< f) 61 | 62 | -- | Overrides the size parameter. Returns a 'Gen' which uses the given size 63 | -- instead of the runtime-size parameter. 64 | resize :: forall a. Int -> Gen a -> Gen a 65 | resize n = 66 | -- TODO throw when size is negative? 67 | mapRandom $ Random.resize n 68 | 69 | -- | Update the current size by mapping a function over it. 70 | scale :: forall a. (Int -> Int) -> Gen a -> Gen a 71 | scale f j = 72 | sized $ \n -> 73 | resize (f n) j 74 | 75 | -- | Generates a 'Char' in the given range. 76 | chooseChar :: Char -> Char -> Gen Char 77 | chooseChar x0 x1 = 78 | let 79 | fromInt x = 80 | case fromCharCode x of 81 | Nothing -> 82 | x0 83 | Just x2 -> 84 | x2 85 | in 86 | map fromInt $ 87 | chooseInt (toCharCode x0) (toCharCode x1) 88 | 89 | -- | Generates an integral number. 90 | chooseInt :: Int -> Int -> Gen Int 91 | chooseInt x0 x1 = 92 | let 93 | x_min = 94 | min x0 x1 95 | 96 | x_max = 97 | max x0 x1 98 | in 99 | mkGen (shrinkTowards x0) $ 100 | Random.chooseInt x_min x_max 101 | 102 | -- | Generates a 'Char'. The character is chosen from the entire range of valid 103 | -- | 'Char' values, this is [0, 65535]. 104 | boundedChar :: Gen Char 105 | boundedChar = 106 | chooseChar bottom top 107 | 108 | -- | Generates an 'Int'. The number is chosen from the entire range of valid 109 | -- | 'Int' values, this is [-2^31, 2^31). 110 | boundedInt :: Gen Int 111 | boundedInt = 112 | mkGen (shrinkTowards 0) $ 113 | Random.chooseInt bottom top 114 | 115 | -- | Uses a weighted distribution to randomly select one of the jacks in the array. 116 | -- /The input array must be non-empty./ 117 | frequency :: forall a. Array (Tuple Int (Gen a)) -> Gen a 118 | frequency xs = 119 | if Array.null xs then 120 | crashEmptyArray "frequency" 121 | else do 122 | let 123 | total = 124 | sum (map fst xs) 125 | 126 | pick n ys0 = 127 | case ys0 of 128 | Nil -> 129 | crashEmptyArray "frequency/pick" 130 | Cons (Tuple k y) ys -> 131 | if n <= k then 132 | y 133 | else 134 | pick (n - k) ys 135 | 136 | n <- chooseInt 1 total 137 | pick n $ List.fromFoldable xs 138 | 139 | -- | Randomly selects one of the values in the array. 140 | -- | /The input array must be non-empty./ 141 | elements :: forall a. Array a -> Gen a 142 | elements xs = 143 | let 144 | fromIx :: Int -> a 145 | fromIx ix = 146 | case Array.index xs ix of 147 | Nothing -> 148 | crashEmptyArray "elements" 149 | Just x -> 150 | x 151 | in 152 | if Array.null xs then 153 | crashEmptyArray "elements" 154 | else do 155 | fromIx <$> chooseInt 0 (Array.length xs - 1) 156 | 157 | -- | Randomly selects one of the jacks in the array. 158 | -- | /The input array must be non-empty./ 159 | oneOf :: forall a. Array (Gen a) -> Gen a 160 | oneOf xs = 161 | let 162 | fromIx :: Int -> Gen a 163 | fromIx ix = 164 | case Array.index xs ix of 165 | Nothing -> 166 | crashEmptyArray "oneOf" 167 | Just x -> 168 | x 169 | in 170 | if Array.null xs then 171 | crashEmptyArray "oneOf" 172 | else do 173 | fromIx =<< chooseInt 0 (Array.length xs - 1) 174 | 175 | -- | Randomly selects from one of the jacks in either the non-recursive or the 176 | -- | recursive array. When a selection is made from the recursive array, the size 177 | -- | is halved. When the size gets to one or less, selections are no longer made 178 | -- | from the recursive array. 179 | -- | /The first argument (i.e. the non-recursive input array) must be non-empty./ 180 | oneOfRec :: forall a. Array (Gen a) -> Array (Gen a) -> Gen a 181 | oneOfRec nonrec rec = 182 | sized $ \n -> 183 | if n <= 1 then 184 | oneOf nonrec 185 | else 186 | oneOf $ nonrec <> map (scale (_ `div` 2)) rec 187 | 188 | -- | Generates a list of random length. The maximum length depends on the size 189 | -- | parameter. 190 | listOf :: forall a. Gen a -> Gen (List a) 191 | listOf (Gen g) = 192 | sized $ \n -> 193 | Gen $ do 194 | k <- Random.chooseInt 0 n 195 | xs <- replicateRecM k g 196 | pure $ sequenceShrinkList xs 197 | 198 | -- | Generates a non-empty list of random length. The maximum length depends on 199 | -- | the size parameter. 200 | listOf1 :: forall a. Gen a -> Gen (NonEmpty List a) 201 | listOf1 jack = 202 | sized $ \n -> do 203 | Gen $ do 204 | k <- Random.chooseInt 1 (max n 1) 205 | 206 | let 207 | unpack ys0 = 208 | case ys0 of 209 | Nil -> 210 | Savage.unsafeCrashWith $ 211 | "Jack.Combinators.listOf1: " <> 212 | "internal error, generated empty list" 213 | Cons y ys -> 214 | NonEmpty y ys 215 | 216 | go = 217 | map unpack <<< 218 | filterTree (not <<< List.null) <<< 219 | sequenceShrinkList 220 | 221 | map go <<< Random.replicateRecM k $ runGen jack 222 | 223 | -- | Generates a list of the given length. 224 | listOfN :: forall a. Int -> Gen a -> Gen (List a) 225 | listOfN n = 226 | mapRandom (map sequenceShrinkOne <<< Random.replicateRecM n) 227 | 228 | -- | Generates a list between 'n' and 'm' in length. 229 | listOfN' :: forall a. Int -> Int -> Gen a -> Gen (List a) 230 | listOfN' n m (Gen r) = 231 | Gen $ do 232 | k <- Random.chooseInt n m 233 | 234 | let 235 | k_min = 236 | min n m 237 | 238 | check xs = 239 | List.length xs >= k_min 240 | 241 | map (filterTree check <<< sequenceShrinkList) $ 242 | Random.replicateRecM k r 243 | 244 | -- | Generates an array of random length. The maximum length depends on the 245 | -- | size parameter. 246 | arrayOf :: forall a. Gen a -> Gen (Array a) 247 | arrayOf = 248 | map Array.fromFoldable <<< listOf 249 | 250 | -- | Generates a non-empty array of random length. The maximum length depends 251 | -- | on the size parameter. 252 | arrayOf1 :: forall a. Gen a -> Gen (NonEmpty Array a) 253 | arrayOf1 = 254 | map (transNonEmpty Array.fromFoldable) <<< listOf1 255 | 256 | -- | Generates an array of the given length. 257 | arrayOfN :: forall a. Int -> Gen a -> Gen (Array a) 258 | arrayOfN n = 259 | map Array.fromFoldable <<< listOfN n 260 | 261 | -- | Generates an array between 'n' and 'm' in length. 262 | arrayOfN' :: forall a. Int -> Int -> Gen a -> Gen (Array a) 263 | arrayOfN' n m = 264 | map Array.fromFoldable <<< listOfN' n m 265 | 266 | -- | Generates a 'Nothing' some of the time. 267 | maybeOf :: forall a. Gen a -> Gen (Maybe a) 268 | maybeOf jack = 269 | sized $ \n -> 270 | frequency [ 271 | Tuple 2 $ 272 | pure Nothing 273 | , Tuple (1 + n) $ 274 | Just <$> jack 275 | ] 276 | 277 | -- | Runs a generator that produces 'Maybe a' until it produces a 'Just'. 278 | justOf :: forall a. Gen (Maybe a) -> Gen a 279 | justOf g = do 280 | mx <- suchThat g isJust 281 | case mx of 282 | Just x -> 283 | pure x 284 | Nothing -> 285 | Savage.unsafeCrashWith $ 286 | "Jack.Combinators.justOf: " <> 287 | "internal error, unexpected Nothing" 288 | 289 | -- | Generates a value that satisfies a predicate. 290 | suchThat :: forall a. Gen a -> (a -> Boolean) -> Gen a 291 | suchThat (Gen r) p = 292 | Gen $ 293 | let 294 | -- TODO this might blow the stack 295 | loop = do 296 | mx <- tryRandom r p 297 | case mx of 298 | Just x -> 299 | pure x 300 | Nothing -> 301 | Random.sized $ \n -> 302 | Random.resize (n + 1) loop 303 | in 304 | loop 305 | 306 | -- | Tries to generate a value that satisfies a predicate. 307 | suchThatMaybe :: forall a. Gen a -> (a -> Boolean) -> Gen (Maybe a) 308 | suchThatMaybe (Gen r) p = 309 | Gen $ do 310 | mx <- tryRandom r p 311 | case mx of 312 | Nothing -> 313 | pure $ pure Nothing 314 | Just x -> 315 | pure $ map Just x 316 | 317 | -- | More or less the same logic as suchThatMaybe from QuickCheck, except 318 | -- | modified to ensure that the shrinks also obey the predicate. 319 | tryRandom :: forall a. Random (Tree a) -> (a -> Boolean) -> Random (Maybe (Tree a)) 320 | tryRandom r p = 321 | let 322 | try k n = 323 | case n of 324 | 0 -> 325 | pure $ Done Nothing 326 | _ -> 327 | Random.resize (2 * k + n) r >>= \x -> 328 | if p (outcome x) then 329 | pure <<< Done <<< Just $ filterTree p x 330 | else 331 | pure $ Loop { a: k + 1, b: n - 1 } 332 | in 333 | Random.sized $ tailRecM2 try 0 <<< max 1 334 | 335 | transNonEmpty :: forall f g a. (f a -> g a) -> NonEmpty f a -> NonEmpty g a 336 | transNonEmpty f (NonEmpty x xs) = 337 | NonEmpty x $ f xs 338 | 339 | crashEmptyArray :: forall a. String -> a 340 | crashEmptyArray fn = 341 | Savage.unsafeCrashWith $ 342 | "Jack.Combinators." <> fn <> ": used with empty array" 343 | --------------------------------------------------------------------------------