├── .gitignore ├── .gitmodules ├── LICENSE.md ├── Makefile ├── README.md ├── Setup.hs ├── TODO.md ├── examples └── RedBlackTrees │ ├── README │ ├── RedBlackSet.hs │ ├── RedBlackSetTest.hs │ ├── RedBlackTrees.cabal │ └── Setup.hs ├── paper ├── .gitignore ├── Figs │ ├── cex-gen.png │ └── cex-gen.svg ├── Makefile ├── Paper.hs ├── paper.bib ├── paper.pdf ├── paper.tex ├── sigplanconf.cls └── talk │ ├── smartcheck-pike.key │ ├── Data │ │ ├── 110809_FamilyChineseOahu_EN_00317_2040x1360-small-12.jpg │ │ ├── 110809_FamilyChineseOahu_EN_02016_981x654-small-14.jpg │ │ ├── 110809_FamilyChineseOahu_EN_02390_2880x1921-small-10.jpg │ │ ├── mt10@2x-87.jpg │ │ ├── mt1@2x-78.jpg │ │ ├── mt2@2x-79.jpg │ │ ├── mt3@2x-80.jpg │ │ ├── mt4@2x-81.jpg │ │ ├── mt5@2x-82.jpg │ │ ├── mt6@2x-83.jpg │ │ ├── mt7@2x-84.jpg │ │ ├── mt8@2x-85.jpg │ │ ├── mt9@2x-86.jpg │ │ ├── pasted-image-332.pdf │ │ ├── pasted-image-94.tif │ │ ├── pasted-image-small-333.png │ │ ├── pasted-image-small-95.png │ │ ├── st0-97.jpg │ │ ├── st1-3216.jpg │ │ ├── st10-1331.jpg │ │ ├── st12-2968.jpg │ │ ├── st13-3147.jpg │ │ ├── st14-2470.jpg │ │ ├── st15-1913.jpg │ │ ├── st15-3261.jpg │ │ ├── st16-3275.jpg │ │ ├── st18-3015.jpg │ │ ├── st2-2935.jpg │ │ ├── st3-2530.jpg │ │ ├── st4-3192.jpg │ │ ├── st5-3201.jpg │ │ └── st7-2553.jpg │ ├── Index.zip │ ├── Metadata │ │ ├── BuildVersionHistory.plist │ │ ├── DocumentIdentifier │ │ └── Properties.plist │ ├── preview-micro.jpg │ ├── preview-web.jpg │ └── preview.jpg │ └── smartcheck.png ├── qc-tests └── Tests.hs ├── refs ├── README.txt ├── quickcheck-notes.md └── reddit-comments.png ├── regression ├── .gitignore ├── Config.mk ├── Degenerate │ ├── Degenerate.hs │ └── Makefile ├── Div0 │ ├── Div0.hs │ └── Makefile ├── Heap │ ├── Heap_Program.hs │ └── Makefile ├── LICENSE ├── List │ ├── List.hs │ └── Makefile ├── Makefile ├── PaperExample1 │ ├── Makefile │ ├── PaperExample1.hs │ └── script.gnp ├── Parser │ ├── Makefile │ └── Parser.hs ├── README.md ├── Test.hs └── gnuplot-notes.txt ├── smartcheck.cabal └── src └── Test ├── SmartCheck.hs └── SmartCheck ├── Args.hs ├── ConstructorGen.hs ├── DataToTree.hs ├── Extrapolate.hs ├── LICENSE ├── Matches.hs ├── Reduce.hs ├── Render.hs ├── SmartGen.hs ├── Test.hs └── Types.hs /.gitignore: -------------------------------------------------------------------------------- 1 | .svn 2 | cabal-dev 3 | dist 4 | cabal.config 5 | packages* 6 | .cabal-sandbox 7 | *.dyn_* 8 | -------------------------------------------------------------------------------- /.gitmodules: -------------------------------------------------------------------------------- 1 | [submodule "quickcheck"] 2 | path = quickcheck 3 | url = https://github.com/leepike/quickcheck.git 4 | -------------------------------------------------------------------------------- /LICENSE.md: -------------------------------------------------------------------------------- 1 | Copyright (c)2012, Lee Pike 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Lee Pike nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | # -*- Mode: makefile-gmake; indent-tabs-mode: t; tab-width: 2 -*- 2 | # please use tabs (8 width) 3 | 4 | ################################################################################ 5 | # Building 6 | 7 | CABAL_INSTALL = cabal install 8 | 9 | .PHONY: all 10 | all: cabal-build 11 | 12 | # Regular (default) build 13 | cabal-build: .cabal-sandbox 14 | $(CABAL_INSTALL) 15 | 16 | # Regression build, requires more packages in the sandbox 17 | regression-build: .cabal-sandbox 18 | $(CABAL_INSTALL) -fregression-flag 19 | 20 | .cabal-sandbox: $(MAKEFILE_LIST) 21 | cabal sandbox init 22 | 23 | sandbox-clean: 24 | rm -rf cabal.sandbox.config .cabal-sandbox 25 | find . -name "dist" | xargs rm -rf 26 | 27 | clean: 28 | @echo "Clean in the top level does not remove your cabal sandbox." 29 | @echo "If you want to remove your cabal sandbox, use the 'sandbox-clean' target" 30 | 31 | ################################################################################ 32 | # Testing/comparing SmartCheck to other test frameworks 33 | 34 | .PHONY: regression 35 | regression: regression-build 36 | $(MAKE) all -C regression 37 | 38 | .PHONY: regression-clean 39 | regression-clean: 40 | $(MAKE) clean -C regression 41 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Build Instructions 2 | 3 | Requirements (others may work, but they are untested): 4 | 5 | - GHC version >= 7.6.2 6 | - cabal-install version >= 1.18.0.2 7 | - Cabal library version >= 1.18.1.2 8 | 9 | The build system assumes a cabal-sandbox build. 10 | 11 | > make configure 12 | > make all 13 | 14 | # Synopsis 15 | 16 | SmartCheck is a smarter [QuickCheck](http://hackage.haskell.org/package/QuickCheck), a powerful testing library for Haskell. The purpose of SmartCheck is to help you more quickly get to the heart of a bug and to quickly discover _each_ possible way that a property may fail. 17 | 18 | SmartCheck is useful for debugging programs operating on algebraic datatypes. When a property is true, SmartCheck is just like QuickCheck (SmartCheck uses QuickCheck as a backend). When a property fails, SmartCheck kicks into gear. First, it attempts to find a _minimal_ counterexample to the property in a robust, systematic way. (You do not need to define any custom shrink instances, like with QuickCheck, but if you do, those are used. SmartCheck usually can do much better than even custom shrink instances.) Second, once a minimal counterexample is found, SmartCheck then attempts to generalize the failed value `d` by replacing `d`'s substructures with new values to make `d'`, and QuickChecking each new `d'`. If for each new `d'` generated, the property also fails, we claim the property fails for any substructure replaced here (of course, this is true modulo the coverage of the tests). 19 | 20 | SmartCheck executes in a read-eval-print loop. In each iteration, all values that have the "same shape" as the generalized value are removed from possible created tests. The loop can be iterated until a fixed-point is reached, and SmartCheck is not able to create any new values that fail the property. 21 | 22 | # A typical example 23 | 24 | In the package there is an examples directory containing a number of examples. Let's look at the simplest, [Div0.hs](https://github.com/leepike/SmartCheck/blob/master/examples/Div0.hs). 25 | 26 | > cd SmartCheck/examples 27 | > ghci -Wall Div0.hs 28 | 29 | Div0 defines a toy language containing constants (C), addition (A), and division (D): 30 | 31 | data M = C Int 32 | | A M M 33 | | D M M 34 | deriving (Show, Typeable, Generic) 35 | 36 | Because SmartCheck performs data-generic operations using GHC.Generics we have to derive Typeable and Generic. To use GHC.Generics, you also need the following pragmas: and the single automatically-derived instance: 37 | 38 | {-# LANGUAGE DeriveDataTypeable #-} 39 | {-# LANGUAGE DeriveGeneric #-} 40 | 41 | instance SubTypes M 42 | 43 | Let's say we have a little interpreter for the language that takes care to return `Nothing` if there is a division by 0: 44 | 45 | eval :: M -> Maybe Int 46 | eval (C i) = Just i 47 | eval (A a b) = do 48 | i <- eval a 49 | j <- eval b 50 | return $ i + j 51 | eval (D a b) = 52 | if eval b == Just 0 then Nothing 53 | else do i <- eval a 54 | j <- eval b 55 | return $ i `div` j 56 | 57 | Now suppose we define a set of values of M such that they won't result in division by 0. We might try the following: 58 | 59 | divSubTerms :: M -> Bool 60 | divSubTerms (C _) = True 61 | divSubTerms (D _ (C 0)) = False 62 | divSubTerms (A m0 m1) = divSubTerms m0 && divSubTerms m1 63 | divSubTerms (D m0 m1) = divSubTerms m0 && divSubTerms m1 64 | 65 | So our property (tries) to state that so long as a value satisfies divSubTerms, then we won't have division by 0 (can you spot the problem in `divSubTerms`?): 66 | 67 | div_prop :: M -> Property 68 | div_prop m = divSubTerms m ==> eval m /= Nothing 69 | 70 | Assuming we've defined an Arbitrary instance for M (just like in 71 | QuickCheck---however, we just have to implement the arbitrary method; the shrink 72 | method is superfluous), we are ready to run SmartCheck. The property you want 73 | to check must be an instance of the type 74 | 75 | prop :: Testable a => a -> b 76 | 77 | where `Testable` is defined by QuickCheck, and `a` is the datatype you want to 78 | reduce (I've left off some class constraints for `a` taken care of above). So 79 | while we can test properties with an arbitrary number of arguments, the *first* 80 | argument is the one we assume you want to reduce (remember your friend, `flip`!). 81 | 82 | In this example, we won't redefine any of QuickCheck's standard arguments, but it's certainly possible. the treeShow field tells SmartCheck whether you want generalized counterexamples shown in a tree format or printed as a long string (the default is the tree format). 83 | 84 | divTest :: IO () 85 | divTest = smartCheck args div_prop 86 | where 87 | args = scStdArgs { qcArgs = stdArgs 88 | , treeShow = PrintString } 89 | 90 | Ok, let's try it. First, SmartCheck just runs QuickCheck: 91 | 92 | *Div0> divTest 93 | *** Failed! Falsifiable (after 7 tests): 94 | D (D (D (A (C (-20)) (D (D (C 2) (C (-19))) (C (-8)))) (D (D (C (-23)) (C 32)) (C (-7)))) (A (A (C 2) (C 10)) (A (C (-2)) (C 13)))) (D (A (C 12) (C (-7))) (D (A (C (-29)) (C 19)) (C 30))) 95 | 96 | Oh, that's confusing, and for such a simple property and small datatype! SmartCheck takes the output from QuickCheck and tries systematic shrinking for the one failed test-case, kind of like [SmallCheck](http://www.cs.york.ac.uk/fp/smallcheck/) might. We get the following reduced counterexample: 97 | 98 | *** Smart Shrinking ... 99 | *** Smart-shrunk value: 100 | D (C 0) (D (C 0) (C (-1))) 101 | 102 | Ok, that's some progress! Now SmartCheck attempts to generalize this (local) minimal counterexample. SmartCheck has two generalization steps that we'll explain separately although SmartCheck combines their results in practice (you can turn off each kind of generalization in the flags). First, SmartCheck tries to generalize *values* in the shrunk counterexample. SmartCheck returns 103 | 104 | *** Extrapolating values ... 105 | *** Extrapolated value: 106 | forall x0: 107 | 108 | D x0 (D (C 0) (C (-1))) 109 | 110 | Ahah! We see that for any possible subvalues x0, the above value fails. Our precondition divSubTerms did not account for the possibility of a non-terminal divisor evaluating to 0; we only pattern-matched on constants. 111 | 112 | In addition, SmartCheck tries to do something I call *constructor generalization*. For a datatype with a finite number of constructors, the idea is to see if for each subvalue in the counterexample, there are subvalues that also fail the property using every possible constructor in the datatype. So for example, for our counterexample above 113 | 114 | *** Extrapolating constructors ... 115 | *** Extrapolated value: 116 | forall C0: 117 | there exist arguments s.t. 118 | 119 | D (C 0) (D C0 (C (-1))) 120 | 121 | So in the hole `C0`, SmartCheck was able to build a value using each of the constructors `C`, `A`, and `D` (well, it already knew there was a value using `C`---`C 0`). 122 | 123 | SmartCheck asks us if we want to continue: 124 | 125 | Attempt to find a new counterexample? ('Enter' to continue; any character 126 | then 'Enter' to quit.) 127 | 128 | SmartCheck will omit any term that has the "same shape" as `D (C 0) (D (C 0) (C (-1)))` and try to find a new counterexample. 129 | 130 | *** Failed! Falsifiable (after 9 tests): 131 | A (A (D (C (-20)) (A (C (-5)) (C (-32)))) (D (A (C 6) (C 19)) (A (C (-3)) (A (C (-16)) (C (-13)))))) (D (C 29) (D (C (-11)) (D (C 11) (C 23)))) 132 | 133 | *** Smart Shrinking ... 134 | *** Smart-shrunk value: 135 | A (C (-1)) (D (A (C 1) (C 1)) (D (C 1) (C 2))) 136 | 137 | *** Extrapolating values ... 138 | 139 | *** Extrapolating Constructors ... 140 | 141 | *** Extrapolated value: 142 | forall values x0 x1: 143 | 144 | A x1 (D x0 (D (C 1) (C 2))) 145 | 146 | We find another counterexample; this time, the main constructor is addition. 147 | 148 | We might ask SmartCheck to find another counterexample: 149 | 150 | ... 151 | 152 | *** Extrapolating ... 153 | *** Could not extrapolate a new value; done. 154 | 155 | At this point, SmartCheck can't find a newly-shaped counterexample. (This doesn't mean there aren't more---you can try to increase the standard arguments to QuickCheck to allow more failed test before giving up (maxDiscard) or increasing the size of tests (maxSize). Or you could simply just keep running the real-eval-print loop.) 156 | 157 | # Other notes 158 | 159 | - More details can be found in the [technical paper](paper/paper.pdf). 160 | 161 | - We use 162 | [GHC Generics](http://www.haskell.org/ghc/docs/7.4.1/html/libraries/ghc-prim-0.2.0.0/GHC-Generics.html). 163 | You may have to define new instances in [src/Test/SmartCheck/Types.hs](src/Test/SmartCheck/Types.hs) . Email (leepike at Gmail) 164 | (or submit patches) if you need instances for other types. 165 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /TODO.md: -------------------------------------------------------------------------------- 1 | # TODO 2 | 3 | * Die on exceptions from QuickCheck. 4 | 5 | * Testing with arguments to value constructors omitted in the SubTypes 6 | instances. 7 | 8 | * Web view for large data (like Yav's thing for type nats)? 9 | 10 | * I would (maybe?) benefit from using a zipper for traversal. 11 | 12 | * Refactor so we only getAtIdx (which is expensive!) once per pass. 13 | 14 | * Pass around stdGen so that the code is more pure. 15 | 16 | Won't Do / Can't Do 17 | ----------------------------------------------- 18 | * Use shrink instances as default for base types. 19 | 20 | * It's not clear there's a benefit to this. What's difficult is not 21 | understanding some base-type failure but the structure of large data. This 22 | seems like wasted time. In any event, there's commented out code in 23 | smartShrink (in Reduce) that will do this. 24 | 25 | * I don't think I can make a generic instance for the arbitrary method. This is 26 | because I don't take a value and apply a function to it. Rather, I want to 27 | generate a new value. But Generics expects to have some sort of 28 | representation of the data you're manipulating. 29 | 30 | * QuickCheck uses a clever trick with typeclasses that allows them to generate 31 | and test functions in the [Property 32 | module](http://hackage.haskell.org/packages/archive/QuickCheck/2.5/doc/html/src/Test-QuickCheck-Property.html#exhaustive). 33 | I was thinking it might be nice to follow their approach with SmartCheck, but 34 | there are a few problems/lack of motivation: 35 | 36 | * SmartCheck addresses the problem of getting complex counterexamples. 37 | Usually, we imagine there's one complex datatype, and maybe some Ints, 38 | Chars, etc. that we also want to randomly generate and test. In this case, 39 | it makes sense to focus on the one. 40 | 41 | * With QuickCheck, there are essentially two passes: (1) make some arbitrary 42 | values and test them, and (2) shrink the values. 43 | -------------------------------------------------------------------------------- /examples/RedBlackTrees/README: -------------------------------------------------------------------------------- 1 | Code slightly modified from Matt Might's Blog: http://matt.might.net/articles/quick-quickcheck/ 2 | -------------------------------------------------------------------------------- /examples/RedBlackTrees/RedBlackSet.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable #-} 2 | {-# LANGUAGE DeriveGeneric #-} 3 | 4 | module RedBlackSet where 5 | 6 | import Test.SmartCheck(SubTypes) 7 | import GHC.Generics 8 | import Data.Typeable 9 | 10 | import Prelude hiding (max) 11 | 12 | data Color = 13 | R -- red 14 | | B -- black 15 | | BB -- double black 16 | | NB -- negative black 17 | deriving (Show, Read, Typeable, Generic) 18 | 19 | data RBSet a = 20 | E -- black leaf 21 | | EE -- double black leaf 22 | | T Color (RBSet a) a (RBSet a) 23 | deriving (Show, Read, Typeable, Generic) 24 | 25 | -- Private auxiliary functions -- 26 | 27 | redden :: RBSet a -> RBSet a 28 | redden E = error "cannot redden empty tree" 29 | redden EE = error "cannot redden empty tree" 30 | redden (T _ a x b) = T R a x b 31 | 32 | blacken :: RBSet a -> RBSet a 33 | blacken E = E 34 | blacken EE = E 35 | blacken (T _ a x b) = T B a x b 36 | 37 | isBB :: RBSet a -> Bool 38 | isBB EE = True 39 | isBB (T BB _ _ _) = True 40 | isBB _ = False 41 | 42 | blacker :: Color -> Color 43 | blacker NB = R 44 | blacker R = B 45 | blacker B = BB 46 | blacker BB = error "too black" 47 | 48 | redder :: Color -> Color 49 | redder NB = error "not black enough" 50 | redder R = NB 51 | redder B = R 52 | redder BB = B 53 | 54 | blacker' :: RBSet a -> RBSet a 55 | blacker' E = EE 56 | blacker' (T c l x r) = T (blacker c) l x r 57 | 58 | redder' :: RBSet a -> RBSet a 59 | redder' EE = E 60 | redder' (T c l x r) = T (redder c) l x r 61 | 62 | -- `balance` rotates away coloring conflicts: 63 | balance :: Color -> RBSet a -> a -> RBSet a -> RBSet a 64 | 65 | -- Okasaki's original cases: 66 | balance B (T R (T R a x b) y c) z d = T R (T B a x b) y (T B c z d) 67 | balance B (T R a x (T R b y c)) z d = T R (T B a x b) y (T B c z d) 68 | balance B a x (T R (T R b y c) z d) = T R (T B a x b) y (T B c z d) 69 | balance B a x (T R b y (T R c z d)) = T R (T B a x b) y (T B c z d) 70 | 71 | -- Six cases for deletion: 72 | balance BB (T R (T R a x b) y c) z d = T B (T B a x b) y (T B c z d) 73 | balance BB (T R a x (T R b y c)) z d = T B (T B a x b) y (T B c z d) 74 | balance BB a x (T R (T R b y c) z d) = T B (T B a x b) y (T B c z d) 75 | balance BB a x (T R b y (T R c z d)) = T B (T B a x b) y (T B c z d) 76 | 77 | balance BB a x (T NB (T B b y c) z d@(T B _ _ _)) 78 | = T B (T B a x b) y (balance B c z (redden d)) 79 | balance BB (T NB a@(T B _ _ _) x (T B b y c)) z d 80 | = T B (balance B (redden a) x b) y (T B c z d) 81 | 82 | balance color a x b = T color a x b 83 | 84 | -- `bubble` "bubbles" double-blackness upward: 85 | bubble :: Color -> RBSet a -> a -> RBSet a -> RBSet a 86 | bubble color l x r 87 | | isBB(l) || isBB(r) = balance (blacker color) (redder' l) x (redder' r) 88 | | otherwise = balance color l x r 89 | 90 | 91 | 92 | 93 | -- Public operations -- 94 | 95 | empty :: RBSet a 96 | empty = E 97 | 98 | 99 | member :: (Ord a) => a -> RBSet a -> Bool 100 | member x E = False 101 | member x (T _ l y r) | x < y = member x l 102 | | x > y = member x r 103 | | otherwise = True 104 | 105 | max :: RBSet a -> a 106 | max E = error "no largest element" 107 | max (T _ _ x E) = x 108 | max (T _ _ x r) = max r 109 | 110 | 111 | -- Insertion: 112 | 113 | insert :: (Ord a) => a -> RBSet a -> RBSet a 114 | insert x s = blacken (ins s) 115 | where ins E = T R E x E 116 | ins s@(T color a y b) | x < y = balance color (ins a) y b 117 | | x > y = balance color a y (ins b) 118 | | otherwise = s 119 | 120 | 121 | -- Deletion: 122 | 123 | delete :: (Ord a,Show a) => a -> RBSet a -> RBSet a 124 | delete x s = blacken(del s) 125 | where del E = E 126 | del s@(T color a y b) | x < y = bubble color (del a) y b 127 | | x > y = bubble color a y (del b) 128 | | otherwise = remove s 129 | 130 | remove :: RBSet a -> RBSet a 131 | remove E = E 132 | remove (T R E _ E) = E 133 | remove (T B E _ E) = EE 134 | remove (T B E _ (T R a x b)) = T B a x b 135 | remove (T B (T R a x b) _ E) = T B a x b 136 | remove (T color l y r) = bubble color l' mx r 137 | where mx = max l 138 | l' = removeMax l 139 | 140 | removeMax :: RBSet a -> RBSet a 141 | removeMax E = error "no maximum to remove" 142 | removeMax s@(T _ _ _ E) = remove s 143 | removeMax s@(T color l x r) = bubble color l x (removeMax r) 144 | 145 | -- Conversion: 146 | 147 | toAscList :: RBSet a -> [a] 148 | toAscList E = [] 149 | toAscList (T _ l x r) = (toAscList l) ++ [x] ++ (toAscList r) 150 | 151 | -- Equality 152 | 153 | instance Eq a => Eq (RBSet a) where 154 | rb == rb' = (toAscList rb) == (toAscList rb') 155 | -------------------------------------------------------------------------------- /examples/RedBlackTrees/RedBlackSetTest.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable #-} 2 | {-# LANGUAGE DeriveGeneric #-} 3 | 4 | -- Note: Benjamin Pierce's lecture notes are where I learned to 5 | -- generate properly ordered binary search trees: 6 | 7 | -- http://www.seas.upenn.edu/~cis552/12fa/lectures/stub/BST.html 8 | 9 | module RedBlackSetTest where 10 | 11 | import RedBlackSet 12 | import Test.QuickCheck 13 | import System.Random (Random) 14 | import Control.Monad 15 | import Data.List (foldr) 16 | 17 | import Test.SmartCheck 18 | import Test.SmartCheck.Types 19 | import GHC.Generics 20 | import Data.Typeable 21 | 22 | 23 | -- Base-2 logarithm: 24 | lg :: Int -> Int 25 | lg n = round(logBase (fromIntegral(2)) (fromIntegral(n))) 26 | 27 | 28 | -- Generate unbounded trees: 29 | unboundedTree :: Arbitrary a => Gen (RBSet a) 30 | unboundedTree = 31 | oneof [return E, 32 | liftM4 T (oneof [return R,return B]) 33 | unboundedTree arbitrary unboundedTree] 34 | 35 | 36 | -- Generate arbitrary trees: 37 | boundedTree :: Arbitrary a => Gen (RBSet a) 38 | boundedTree = sized tree where 39 | 40 | tree :: Arbitrary a => Int -> Gen (RBSet a) 41 | tree 0 = return E 42 | tree n | n>0 = 43 | oneof [return E, 44 | liftM4 T color subtree arbitrary subtree] 45 | where subtree = tree (n `div` 2) 46 | color = oneof [return R, return B] 47 | 48 | 49 | -- Generate trees with no red-red violations: 50 | nrrTree :: Arbitrary a => Gen (RBSet a) 51 | nrrTree = sized (tree R) where 52 | 53 | tree :: Arbitrary a => Color -> Int -> Gen (RBSet a) 54 | 55 | -- Assuming black parent: 56 | tree B 0 = return E 57 | tree B n | n>0 = 58 | oneof [return E, 59 | liftM4 T (return B) subtree arbitrary subtree, 60 | liftM4 T (return R) subtree' arbitrary subtree'] 61 | where subtree = tree B (n `div` 2) 62 | subtree' = tree R (n `div` 2) 63 | 64 | -- Assuming red parent: 65 | tree R 0 = return E 66 | tree R n | n>0 = 67 | oneof [return E, 68 | liftM4 T (return B) subtree arbitrary subtree] 69 | where subtree = tree B (n `div` 2) 70 | 71 | 72 | -- Generate black-balanced trees with no red-red violations: 73 | balnrrTree :: Arbitrary a => Gen (RBSet a) 74 | balnrrTree = sized (\n -> tree B (lg(n))) where 75 | 76 | tree :: Arbitrary a => Color -> Int -> Gen (RBSet a) 77 | 78 | tree B 0 = return E 79 | tree B 1 = 80 | oneof [return E, 81 | liftM4 T (return R) (return E) arbitrary (return E)] 82 | 83 | tree B n | n>0 = 84 | oneof [liftM4 T (return B) subtree arbitrary subtree, 85 | liftM4 T (return R) subtree' arbitrary subtree'] 86 | where subtree = tree B (n-1) 87 | subtree' = tree R n 88 | 89 | tree R 0 = return E 90 | tree R 1 = return E 91 | tree R n | n>0 = 92 | oneof [liftM4 T (return B) subtree arbitrary subtree] 93 | where subtree = tree B (n-1) 94 | 95 | 96 | -- Generate ordered, black-balanced trees with no red-red violations: 97 | ordbalnrrTree :: (Arbitrary a, Random a, 98 | Bounded a, Ord a, Num a) => Gen (RBSet a) 99 | ordbalnrrTree = 100 | -- sized (\n -> tree 0 100000000000000 B (lg n)) where 101 | sized (\n -> tree 0 2 B (lg n)) where 102 | 103 | tree min max _ _ | max < min = error $ "cannot generate" 104 | tree min max B 0 = return E 105 | tree min max B 1 = 106 | oneof [return E, 107 | liftM4 T (return R) (return E) (choose(min+1,max-1)) (return E)] 108 | tree min max B n | n>0 = 109 | do key <- choose (min+1,max-1) 110 | let subtree1 = tree min (key-1) B (n-1) 111 | let subtree2 = tree (key+1) max B (n-1) 112 | let subtree1' = tree min (key-1) R n 113 | let subtree2' = tree (key+1) max R n 114 | oneof [liftM4 T (return B) subtree1 (return key) subtree2, 115 | liftM4 T (return R) subtree1' (return key) subtree2'] 116 | 117 | tree min max R 0 = return E 118 | tree min max R 1 = return E 119 | tree min max R n | n>0 = 120 | do key <- choose (min+1, max-1) 121 | let subtree1 = tree min (key-1) B (n-1) 122 | let subtree2 = tree (key+1) max B (n-1) 123 | oneof [liftM4 T (return B) subtree1 (return key) subtree2] 124 | 125 | -- Generate trees from insertions: 126 | insertedTree :: (Arbitrary a, Ord a) => Gen (RBSet a) 127 | insertedTree = liftM (Data.List.foldr insert empty) arbitrary 128 | 129 | -- Redefine arbitrary since we don't have forall in SmartCheck. 130 | instance (Arbitrary a, Random a, 131 | Bounded a, Ord a, Num a) => Arbitrary (RBSet a) where 132 | arbitrary = nrrTree 133 | -- arbitrary = oneof[ordbalnrrTree, 134 | -- liftM (Data.List.foldr insert empty) arbitrary] 135 | 136 | -- Count the black depth of a red-black tree: 137 | blackDepth :: RBSet a -> Maybe Int 138 | blackDepth (E) = Just(1) 139 | blackDepth (T R l _ r) = case (blackDepth(l),blackDepth(r)) of 140 | (Just(n),Just(m)) -> if n == m then Just(n) else Nothing 141 | (_,_) -> Nothing 142 | blackDepth (T B l _ r) = case (blackDepth(l),blackDepth(r)) of 143 | (Just(n),Just(m)) -> if n == m then Just(1+n) else Nothing 144 | (_,_) -> Nothing 145 | 146 | -- Check for red-red violations: 147 | prop_NoRedRed :: RBSet Int -> Bool 148 | prop_NoRedRed E = True 149 | prop_NoRedRed (T R (T R _ _ _) _ _) = False 150 | prop_NoRedRed (T R _ _ (T R _ _ _)) = False 151 | prop_NoRedRed (T _ l x r) = (prop_NoRedRed l) && (prop_NoRedRed r) 152 | 153 | 154 | -- Check for black-balanced violations: 155 | prop_BlackBalanced :: RBSet Int -> Bool 156 | prop_BlackBalanced t = 157 | case blackDepth(t) of 158 | Just _ -> True 159 | Nothing -> False 160 | 161 | 162 | -- Check for ordering violations: 163 | prop_OrderedList :: Ord a => [a] -> Bool 164 | prop_OrderedList [] = True 165 | prop_OrderedList [x] = True 166 | prop_OrderedList (x:y:tl) = (x < y) && (prop_OrderedList(y:tl)) 167 | 168 | prop_Ordered :: RBSet Int -> Bool 169 | prop_Ordered t = prop_OrderedList (toAscList t) 170 | 171 | -- Check for the validity of a red-black tree: 172 | prop_RBValid :: RBSet Int -> Bool 173 | prop_RBValid t = prop_NoRedRed t && prop_BlackBalanced t && prop_Ordered t 174 | 175 | 176 | -- Insertion properties: 177 | prop_Create5 :: Int -> Int -> Int -> Int -> Int -> Bool 178 | prop_Create5 a b c d e = 179 | ((foldr insert empty) [a,b,c,d,e]) == 180 | ((foldr insert empty) [b,c,d,e,a]) 181 | 182 | prop_InsertValid :: RBSet Int -> Int -> Bool 183 | prop_InsertValid t x = prop_RBValid(insert x t) 184 | 185 | prop_InsertMember :: RBSet Int -> Int -> Bool 186 | prop_InsertMember t x = member x (insert x t) 187 | 188 | prop_InsertSafe :: RBSet Int -> Int -> Int -> Property 189 | prop_InsertSafe t x y = member x t ==> (member x (insert y t)) 190 | 191 | prop_NoInsertPhantom :: RBSet Int -> Int -> Int -> Property 192 | prop_NoInsertPhantom t x y = 193 | not (member x t) && x /= y ==> not (member x (insert y t)) 194 | 195 | -- Deletion properties: 196 | prop_InsertDeleteValid :: RBSet Int -> Int -> Bool 197 | prop_InsertDeleteValid t x = prop_RBValid(delete x (insert x t)) 198 | 199 | prop_DeleteValid :: RBSet Int -> Int -> Bool 200 | prop_DeleteValid t x = prop_RBValid(delete x t) 201 | 202 | prop_MemberDelete :: RBSet Int -> Int -> Property 203 | prop_MemberDelete t x = member x t ==> not (member x (delete x t)) 204 | 205 | prop_DeletePreserve :: RBSet Int -> Int -> Int -> Property 206 | prop_DeletePreserve t x y = x /= y ==> (member y t) == (member y (delete x t)) 207 | 208 | test :: IO () 209 | test = 210 | do quickCheck(prop_RBValid) 211 | 212 | -- Insertion tests: 213 | quickCheck(prop_Create5) 214 | quickCheck(prop_InsertValid) 215 | quickCheck(prop_InsertSafe) 216 | quickCheck(prop_NoInsertPhantom) 217 | quickCheck(prop_InsertMember) 218 | 219 | -- Deletion tests: 220 | quickCheck(prop_InsertDeleteValid) 221 | quickCheck(prop_DeleteValid) 222 | quickCheck(prop_MemberDelete) 223 | quickCheck(prop_DeletePreserve) 224 | 225 | main :: IO () 226 | main = test 227 | 228 | ------------------------------------------------------------ 229 | -- SmartCheck 230 | 231 | instance Arbitrary Color where 232 | arbitrary = elements [R, B, BB, NB] 233 | 234 | instance SubTypes Color where 235 | baseType _ = True 236 | 237 | instance ( Arbitrary a, Random a 238 | , Bounded a, Ord a, Num a 239 | , SubTypes a 240 | ) => SubTypes (RBSet a) 241 | 242 | testSC :: IO () 243 | testSC = sc prop_BlackBalanced 244 | where 245 | sc = smartCheck scStdArgs {format = PrintString } 246 | 247 | -------------------------------------------------------------------------------- /examples/RedBlackTrees/RedBlackTrees.cabal: -------------------------------------------------------------------------------- 1 | -- Initial RedBlackTrees.cabal generated by cabal init. For further 2 | -- documentation, see http://haskell.org/cabal/users-guide/ 3 | 4 | name: RedBlackTrees 5 | version: 0.1.0.0 6 | synopsis: SmartCheck for Matt Might's Red-Black Trees example. 7 | -- description: 8 | license: BSD3 9 | license-file: LICENSE 10 | author: leepike 11 | maintainer: leepike@gmail.com 12 | -- copyright: 13 | category: Testing 14 | build-type: Simple 15 | -- extra-source-files: 16 | cabal-version: >=1.10 17 | 18 | library 19 | exposed-modules: RedBlackSet, RedBlackSetTest 20 | -- other-modules: 21 | other-extensions: DeriveDataTypeable, DeriveGeneric 22 | build-depends: base, 23 | QuickCheck, 24 | random, 25 | smartcheck 26 | -- hs-source-dirs: 27 | default-language: Haskell2010 28 | -------------------------------------------------------------------------------- /examples/RedBlackTrees/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /paper/.gitignore: -------------------------------------------------------------------------------- 1 | pdflatex 2 | -------------------------------------------------------------------------------- /paper/Figs/cex-gen.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/leepike/SmartCheck/86bfe4a3f61bfd74fa79e1afb9b5a77d4ad58efb/paper/Figs/cex-gen.png -------------------------------------------------------------------------------- /paper/Figs/cex-gen.svg: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 22 | 24 | 27 | 31 | 32 | 35 | 39 | 40 | 47 | 52 | 53 | 60 | 65 | 66 | 73 | 78 | 79 | 80 | 99 | 102 | 103 | 105 | 106 | 108 | image/svg+xml 109 | 111 | 112 | 113 | 114 | 115 | 119 | 128 | Possible values 139 | 149 | Counterexample 160 | 173 | 174 | 179 | 184 | 185 | 189 | 199 | 202 | 212 | 221 | 231 | 241 | 251 | 261 | 271 | 276 | 277 | Generalizationformula 292 | pre 303 | post 314 | Satisfies 326 | Satisfies 337 | 338 | 339 | -------------------------------------------------------------------------------- /paper/Makefile: -------------------------------------------------------------------------------- 1 | DIR=pdflatex 2 | DOC=paper 3 | BIB=$(DOC).bib 4 | LATEX=pdflatex 5 | 6 | FIGS=./Figs 7 | 8 | all: $(DIR) $(DOC).tex $(BIB) 9 | $(LATEX) -output-directory $(DIR) $(DOC) 10 | bibtex $(DIR)/$(DOC).aux 11 | $(LATEX) -output-directory $(DIR) $(DOC) 12 | $(LATEX) -output-directory $(DIR) $(DOC) 13 | cp $(DIR)/$(DOC).pdf . 14 | 15 | # twopi -Tps $(FIGS)/architecture_sensors.dot > $(FIGS)/architecture_sensors.ps 16 | # ps2epsi $(FIGS)/architecture_sensors.ps $(FIGS)/architecture_sensors.epsi 17 | # epstopdf $(FIGS)/architecture_sensors.epsi 18 | 19 | $(DIR): 20 | mkdir -p $(DIR) 21 | 22 | .PHONY: clean 23 | clean: 24 | rm -rf $(DIR) 25 | -------------------------------------------------------------------------------- /paper/Paper.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ExistentialQuantification, ScopedTypeVariables #-} 2 | 3 | -- | Model of the SmartCheck algorithms explained in the paper. We leave a 4 | -- number of functions undefined here. 5 | 6 | -- Limit: col 50 7 | 8 | module Paper where 9 | 10 | import Prelude hiding (fail) 11 | import Data.Maybe (mapMaybe) 12 | import Data.Tree 13 | import Control.Monad (liftM, replicateM) 14 | import Test.QuickCheck 15 | 16 | -------------------------------------------------------------------------------- 17 | 18 | -- Arguments 19 | 20 | data Format = PrintTree | PrintString 21 | deriving (Eq, Read, Show) 22 | 23 | -- SmartCheck arguments 24 | data ScArgs = ScArgs { 25 | format :: Format -- ^ How to show extrapolated formula 26 | , qcArgs :: Args -- ^ QuickCheck arguments 27 | , qc :: Bool -- ^ Should we run QuickCheck? (If not, you are 28 | -- expected to pass in data to analyze.) 29 | , scMaxSize :: Int -- ^ Maximum size of data to generate, in terms of 30 | -- the size parameter of QuickCheck's Arbitrary 31 | -- instance for your data. 32 | , scMaxDepth :: Maybe Int -- ^ How many levels into the structure of the 33 | -- failed value should we descend when reducing or 34 | -- generalizing? Nothing means we go down to base 35 | -- types. 36 | , scMaxReduce :: Int -- ^ How hard (number of rounds) to look for 37 | -- failure in the reduction stage. 38 | , runForall :: Bool -- ^ Should we extrapolate? 39 | , scMaxForall :: Int -- ^ How hard (number of rounds) to look for 40 | -- failures during the extrapolation stage. 41 | , scMinForall :: Int -- ^ Minimum number of times a property's 42 | -- precondition must be passed to generalize it. 43 | , runExists :: Bool -- ^ Should we try to generalize constructors? 44 | , scMaxExists :: Int -- ^ How hard (number of rounds) to look for 45 | -- failing values with each constructor. For 46 | -- "wide" sum types, this value should be 47 | -- increased. 48 | } 49 | -------------------------------------------------------------------------------- 50 | 51 | -- Types 52 | data SubVal = forall a. SubTypes a => SubVal a 53 | 54 | type Size = Int 55 | type Idx = Int 56 | 57 | class Arbitrary a => SubTypes a where 58 | size :: a -> Size 59 | index :: a -> Idx -> Maybe SubVal 60 | replace :: a -> Idx -> SubVal -> a 61 | subVals :: a -> Tree SubVal 62 | constr :: a -> String 63 | constrs :: a -> [String] 64 | opaque :: a -> Bool 65 | 66 | -------------------------------------------------------------------------------- 67 | 68 | -- Undefined 69 | 70 | pass :: (a -> Property) -> a -> Bool 71 | pass _ _ = True 72 | 73 | -- Failed (Just False), passed (Just True), or failed precondition (Nothing). 74 | fail :: (a -> Property) -> a -> Maybe Bool 75 | fail _ _ = Just True 76 | 77 | cast :: SubTypes a => a -> Maybe b 78 | cast _ = undefined 79 | 80 | sizedArbitrary :: 81 | forall a . SubTypes a => Size -> a -> IO a 82 | sizedArbitrary sz _ = return (undefined sz :: a) 83 | 84 | subTree :: SubTypes a => a -> Idx -> Idx -> Bool 85 | subTree _ _ _ = undefined 86 | 87 | -------------------------------------------------------------------------------- 88 | 89 | getSize :: SubVal -> Size 90 | getSize (SubVal a) = size a 91 | 92 | newVals :: Size -> Int -> SubVal -> IO [SubVal] 93 | newVals sz tries (SubVal a) = 94 | replicateM tries s where 95 | s = liftM SubVal (sizedArbitrary sz a) 96 | 97 | reduce :: SubTypes a 98 | => ScArgs -> (a -> Property) -> a -> IO a 99 | reduce args prop cex = reduce' 1 100 | where 101 | reduce' idx 102 | | Just v <- index cex idx 103 | = do vs <- newVals (getSize v) 104 | (scMaxReduce args) v 105 | case test cex idx vs prop of 106 | Nothing -> reduce' (idx+1) 107 | Just a -> reduce args prop a 108 | | otherwise = return cex 109 | 110 | test :: SubTypes a => a -> Idx -> [SubVal] 111 | -> (a -> Property) -> Maybe a 112 | test cex idx vs prop = go vs 113 | where 114 | go [] = Nothing 115 | go (v:vs') = 116 | let cex' = replace cex idx v in 117 | if pass prop cex' then go vs' 118 | else Just cex' 119 | 120 | -------------------------------------------------------------------------------- 121 | 122 | reduceOpt :: forall a . SubTypes a 123 | => ScArgs -> (a -> Property) -> a -> IO a 124 | reduceOpt args prop cex = reduce' 1 125 | where 126 | reduce' idx 127 | | Just v <- index cex idx 128 | = case testHole v of 129 | Nothing -> test' v idx 130 | Just a -> reduceOpt args prop a 131 | | otherwise = return cex 132 | 133 | test' v idx = do 134 | vs <- newVals (getSize v) (scMaxReduce args) v 135 | case test cex idx vs prop of 136 | Nothing -> reduce' (idx+1) 137 | Just a -> reduceOpt args prop a 138 | 139 | testHole (SubVal a) = do 140 | a' <- cast a :: Maybe a 141 | if pass prop a' then Nothing else Just a' 142 | 143 | -------------------------------------------------------------------------------- 144 | 145 | subTrees :: SubTypes a => a -> Idx -> [Idx] -> Bool 146 | subTrees cex idx = any (subTree cex idx) 147 | 148 | extrapolate :: SubTypes a 149 | => ScArgs -> a -> (a -> Property) -> IO [Idx] 150 | extrapolate args cex prop = extrapolate' 1 [] 151 | where 152 | extrapolate' idx idxs 153 | | subTrees cex idx idxs 154 | = extrapolate' (idx+1) idxs 155 | | Just v <- index cex idx = mkNewVals v 156 | | otherwise = return idxs 157 | where 158 | mkNewVals v = do 159 | vs <- newVals (scMaxSize args) 160 | (scMaxForall args) v 161 | extrapolate' (idx+1) 162 | (if allFail args cex idx vs prop 163 | then idx:idxs else idxs) 164 | 165 | allFail :: SubTypes a => ScArgs -> a -> Idx 166 | -> [SubVal] -> (a -> Property) -> Bool 167 | allFail args cex idx vs prop = 168 | length res >= scMinForall args && and res 169 | where 170 | res = mapMaybe go vs 171 | go = fail prop . replace cex idx 172 | 173 | -------------------------------------------------------------------------------- 174 | 175 | subConstr :: SubVal -> String 176 | subConstr (SubVal a) = constr a 177 | 178 | subConstrs :: SubVal -> [String] 179 | subConstrs (SubVal a) = constrs a 180 | 181 | sumTest :: SubTypes a => ScArgs -> a 182 | -> (a -> Property) -> [Idx] -> IO [Idx] 183 | sumTest args cex prop exIdxs = sumTest' 1 [] 184 | where 185 | sumTest' idx idxs 186 | | subTrees cex idx (exIdxs ++ idxs) 187 | = sumTest' (idx+1) idxs 188 | | Just v <- index cex idx = fromSumTest v 189 | | otherwise = return idxs 190 | where 191 | fromSumTest v = do 192 | vs <- newVals (scMaxSize args) 193 | (scMaxExists args) v 194 | sumTest' (idx+1) 195 | (if constrFail cex idx vs prop 196 | (subConstr v) (subConstrs v) 197 | then idx:idxs else idxs) 198 | 199 | constrFail :: SubTypes a => a -> Idx -> [SubVal] 200 | -> (a -> Property) -> String -> [String] -> Bool 201 | constrFail cex idx vs prop con allCons = 202 | constrFail' [con] vs 203 | where 204 | constrFail' cons vs' 205 | | length cons == length allCons = True 206 | | null vs' = False 207 | | go v == Just True 208 | = constrFail' (c:cons) (tail vs') 209 | | otherwise 210 | = constrFail' cons (tail vs') 211 | where 212 | v = head vs' 213 | c = subConstr v 214 | go = fail prop' . replace cex idx 215 | prop' a = c `notElem` cons ==> prop a 216 | 217 | -------------------------------------------------------------------------------- 218 | 219 | matchesShapes :: SubTypes a 220 | => a -> [(a,[Idx])] -> Bool 221 | matchesShapes d = any (matchesShape d) 222 | 223 | -- | At each index that we generalize (either value generalization or 224 | -- constructor generalization), we replace that value from b into a. At this 225 | -- point, we check for constructor equality between the two values, decending 226 | -- their structures. 227 | matchesShape :: SubTypes a 228 | => a -> (a, [Idx]) -> Bool 229 | matchesShape a (b, idxs) 230 | | constr a /= constr b = False 231 | | Just a' <- aRepl 232 | = let x = subForest (subVals a') in 233 | let y = subForest (subVals b) in 234 | all foldEqConstrs (zip x y) 235 | | otherwise = False 236 | where 237 | updateA idx d = 238 | fmap (replace d idx) (index b idx) 239 | aRepl = foldl go (Just a) idxs where 240 | go ma idx | Just x <- ma = updateA idx x 241 | | otherwise = Nothing 242 | foldEqConstrs ( Node (SubVal l0) sts0 243 | , Node (SubVal l1) sts1 ) 244 | -- Don't need a opaque test, since they don't ever appear in subTypes. 245 | | constr l0 == constr l1 = 246 | all foldEqConstrs (zip sts0 sts1) 247 | | otherwise = False 248 | -------------------------------------------------------------------------------- /paper/paper.bib: -------------------------------------------------------------------------------- 1 | @inproceedings{qc, 2 | author = {Claessen, Koen and Hughes, John}, 3 | title = {{QuickCheck}: a lightweight tool for random testing of {H}askell programs}, 4 | booktitle = {ACM SIGPLAN International Conference on Functional Programming (ICFP)}, 5 | journal = {SIGPLAN Notices}, 6 | OPTvolume = {35}, 7 | OPTnumber = {9}, 8 | year = {2000}, 9 | pages = {268--279}, 10 | publisher = {ACM} 11 | } 12 | 13 | @article{daikon, 14 | author = {Ernst, Michael D. and Perkins, Jeff H. and Guo, Philip J. and McCamant, Stephen and Pacheco, Carlos and Tschantz, Matthew S. and Xiao, Chen}, 15 | title = {The {D}aikon system for dynamic detection of likely invariants}, 16 | journal = {Science of Computer Programing}, 17 | volume = {69}, 18 | number = {1-3}, 19 | month = dec, 20 | year = {2007}, 21 | pages = {35--45} 22 | } 23 | 24 | @article{regehr, 25 | author = {Regehr, John and Chen, Yang and Cuoq, Pascal and Eide, Eric and Ellison, Chucky and Yang, Xuejun}, 26 | title = {Test-case Reduction for {C} Compiler Bugs}, 27 | journal = {SIGPLAN Notices}, 28 | issue_date = {June 2012}, 29 | volume = {47}, 30 | number = {6}, 31 | month = jun, 32 | year = {2012}, 33 | publisher = {ACM} 34 | } 35 | 36 | @inproceedings{claessen, 37 | author = {Claessen, Koen}, 38 | title = {Shrinking and showing functions: (functional pearl)}, 39 | booktitle = {Proceedings of the Haskell symposium}, 40 | year = {2012}, 41 | pages = {73--80}, 42 | publisher = {ACM} 43 | } 44 | 45 | @inproceedings{kow, 46 | author = {Kow, Eric}, 47 | title = {{GenI}: natural language generation in {H}askell}, 48 | booktitle = {Proceedings of the 2006 ACM SIGPLAN workshop on Haskell}, 49 | year = {2006}, 50 | pages = {110--119}, 51 | publisher = {ACM} 52 | } 53 | 54 | @inproceedings{feat, 55 | author = {Dureg{\aa}rd, Jonas and Jansson, Patrik and Wang, Meng}, 56 | booktitle = {Proceedings of the 5th ACM SIGPLAN Symposium on Haskell}, 57 | pages = {61-72}, 58 | publisher = {ACM}, 59 | title = {{F}eat: functional enumeration of algebraic types}, 60 | year = 2012 61 | } 62 | 63 | @inproceedings{telecom, 64 | author = {Thomas Arts and 65 | John Hughes and 66 | Joakim Johansson and 67 | Ulf T. Wiger}, 68 | title = {Testing telecoms software with {Quviq QuickCheck}}, 69 | booktitle = {ACM SIGPLAN Workshop on Erlang Erlang Workshop}, 70 | year = {2006}, 71 | publisher = {ACM}, 72 | pages = {2-10} 73 | } 74 | 75 | @inproceedings{qcjh, 76 | author = {John Hughes}, 77 | title = {Software Testing with {QuickCheck}}, 78 | booktitle = {Central European Functional Programming School (CEFP)}, 79 | year = {2010}, 80 | publisher = {Springer}, 81 | volume = {6299}, 82 | series = {LNCS}, 83 | pages = {183-223} 84 | } 85 | 86 | 87 | 88 | @techreport{haskell2010, 89 | author = {Simon {Marlow (editor)}}, 90 | title = {{H}askell 2010 Language Report}, 91 | howpublished = {Available at \url{http://www.haskell.org/definition/haskell2010.pdf}}, 92 | month = {July}, 93 | year = {2010} 94 | } 95 | 96 | 97 | 98 | @Misc{ghc, 99 | key = {GHC}, 100 | author = {{GHC Team}}, 101 | title = {The Glorious {G}lasgow {H}askell Compilation System User's Guide, Version 7.4.1}, 102 | OPThowpublished = {}, 103 | month = {March}, 104 | year = {2012}, 105 | note = {Available at \url{http://www.haskell.org/ghc/docs/latest/html/users_guide/}}, 106 | OPTannote = {} 107 | } 108 | 109 | @inproceedings{qs, 110 | author = {Koen Claessen and 111 | Nicholas Smallbone and 112 | John Hughes}, 113 | title = {{QuickSpec}: Guessing Formal Specifications Using Testing}, 114 | booktitle = {Tests and Proofs Intl. Conference (TAP)}, 115 | year = {2010}, 116 | series = {LNCS}, 117 | pages = {6-21} 118 | } 119 | 120 | 121 | @inproceedings{gadts, 122 | author = {Johann, Patricia and Ghani, Neil}, 123 | title = {Foundations for structured programming with {GADT}s}, 124 | booktitle = {Symposium on Principles of programming Languages (POPL)}, 125 | year = {2008}, 126 | pages = {297--308}, 127 | numpages = {12}, 128 | publisher = {ACM} 129 | } 130 | 131 | @article{zipper, 132 | author = {G{\'e}rard P. Huet}, 133 | title = {The Zipper}, 134 | journal = {Journal of Functional Programming}, 135 | volume = {7}, 136 | number = {5}, 137 | year = {1997}, 138 | pages = {549-554} 139 | } 140 | 141 | @inproceedings{xmonad, 142 | author = {Don Stewart and 143 | Spencer Sjanssen}, 144 | title = {{XMonad}}, 145 | booktitle = {ACM SIGPLAN Workshop on Haskell}, 146 | year = {2007}, 147 | pages = {119}, 148 | publisher = {ACM} 149 | } 150 | 151 | @inproceedings{generics, 152 | author = {Magalh\~aes, Jos\'e Pedro and Dijkstra, Atze and Jeuring, Johan and L\"{o}h, Andres}, 153 | title = {A generic deriving mechanism for {Haskell}}, 154 | booktitle = {Proceedings of the 3rd ACM Haskell Symposium on Haskell}, 155 | year = {2010}, 156 | pages = {37--48}, 157 | publisher = {ACM} 158 | } 159 | 160 | @inproceedings{syb, 161 | author = {Ralf L{\"a}mmel and 162 | Simon L. Peyton-Jones}, 163 | title = {Scrap your boilerplate with class: extensible generic functions}, 164 | booktitle = {ACM SIGPLAN International Conference on Functional Programming 165 | (ICFP)}, 166 | year = {2005}, 167 | publisher = {ACM}, 168 | pages = {204-215} 169 | } 170 | 171 | @Book{jackson, 172 | author = {Daniel Jackson}, 173 | ALTeditor = {}, 174 | title = {Software abstractions: logic, language and analysis}, 175 | publisher = {{MIT} Press}, 176 | year = {2006}, 177 | OPTannote = {} 178 | } 179 | 180 | @article{haskell98, 181 | author = {Simon Peyton-Jones and others}, 182 | title = {The {Haskell} 98 Language and Libraries: The Revised Report}, 183 | journal = {Journal of Functional Programming}, 184 | volume = 13, 185 | number = 1, 186 | pages = {0--255}, 187 | month = {Jan}, 188 | year = 2003, 189 | note = {Available at \url{http://www.haskell.org/definition/}}, 190 | } 191 | 192 | @article{dd, 193 | author = {Zeller, Andreas and Hildebrandt, Ralf}, 194 | title = {Simplifying and Isolating Failure-Inducing Input}, 195 | journal = {IEEE Transactions on Software Engineering}, 196 | volume = {28}, 197 | number = {2}, 198 | month = feb, 199 | year = {2002}, 200 | pages = {183--200}, 201 | } 202 | 203 | @inproceedings{hdd, 204 | author = {Misherghi, Ghassan and Su, Zhendong}, 205 | title = {{HDD}: hierarchical delta debugging}, 206 | booktitle = {Proceedings of the 28th international conference on Software engineering}, 207 | year = {2006}, 208 | pages = {142--151}, 209 | publisher = {ACM}, 210 | } 211 | 212 | 213 | @inproceedings{sc, 214 | author = {Colin Runciman and 215 | Matthew Naylor and 216 | Fredrik Lindblad}, 217 | title = {{SmallCheck} and lazy {s}mallcheck: automatic exhaustive testing 218 | for small values}, 219 | booktitle = {Proceedings of the ACM Haskell Symposium}, 220 | publisher = {ACM}, 221 | year = {2008}, 222 | pages = {37-48} 223 | } 224 | 225 | @INPROCEEDINGS{monadic, 226 | author = {Koen Claessen and John Hughes}, 227 | title = {Testing Monadic Code with {QuickCheck}}, 228 | booktitle = {ACM SIGPLAN workshop on Haskell}, 229 | year = {2002}, 230 | pages = {65--77} 231 | } 232 | -------------------------------------------------------------------------------- /paper/paper.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/leepike/SmartCheck/86bfe4a3f61bfd74fa79e1afb9b5a77d4ad58efb/paper/paper.pdf -------------------------------------------------------------------------------- /paper/talk/smartcheck-pike.key/Data/110809_FamilyChineseOahu_EN_00317_2040x1360-small-12.jpg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/leepike/SmartCheck/86bfe4a3f61bfd74fa79e1afb9b5a77d4ad58efb/paper/talk/smartcheck-pike.key/Data/110809_FamilyChineseOahu_EN_00317_2040x1360-small-12.jpg -------------------------------------------------------------------------------- /paper/talk/smartcheck-pike.key/Data/110809_FamilyChineseOahu_EN_02016_981x654-small-14.jpg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/leepike/SmartCheck/86bfe4a3f61bfd74fa79e1afb9b5a77d4ad58efb/paper/talk/smartcheck-pike.key/Data/110809_FamilyChineseOahu_EN_02016_981x654-small-14.jpg -------------------------------------------------------------------------------- /paper/talk/smartcheck-pike.key/Data/110809_FamilyChineseOahu_EN_02390_2880x1921-small-10.jpg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/leepike/SmartCheck/86bfe4a3f61bfd74fa79e1afb9b5a77d4ad58efb/paper/talk/smartcheck-pike.key/Data/110809_FamilyChineseOahu_EN_02390_2880x1921-small-10.jpg -------------------------------------------------------------------------------- /paper/talk/smartcheck-pike.key/Data/mt10@2x-87.jpg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/leepike/SmartCheck/86bfe4a3f61bfd74fa79e1afb9b5a77d4ad58efb/paper/talk/smartcheck-pike.key/Data/mt10@2x-87.jpg -------------------------------------------------------------------------------- /paper/talk/smartcheck-pike.key/Data/mt1@2x-78.jpg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/leepike/SmartCheck/86bfe4a3f61bfd74fa79e1afb9b5a77d4ad58efb/paper/talk/smartcheck-pike.key/Data/mt1@2x-78.jpg -------------------------------------------------------------------------------- /paper/talk/smartcheck-pike.key/Data/mt2@2x-79.jpg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/leepike/SmartCheck/86bfe4a3f61bfd74fa79e1afb9b5a77d4ad58efb/paper/talk/smartcheck-pike.key/Data/mt2@2x-79.jpg -------------------------------------------------------------------------------- /paper/talk/smartcheck-pike.key/Data/mt3@2x-80.jpg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/leepike/SmartCheck/86bfe4a3f61bfd74fa79e1afb9b5a77d4ad58efb/paper/talk/smartcheck-pike.key/Data/mt3@2x-80.jpg -------------------------------------------------------------------------------- /paper/talk/smartcheck-pike.key/Data/mt4@2x-81.jpg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/leepike/SmartCheck/86bfe4a3f61bfd74fa79e1afb9b5a77d4ad58efb/paper/talk/smartcheck-pike.key/Data/mt4@2x-81.jpg -------------------------------------------------------------------------------- /paper/talk/smartcheck-pike.key/Data/mt5@2x-82.jpg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/leepike/SmartCheck/86bfe4a3f61bfd74fa79e1afb9b5a77d4ad58efb/paper/talk/smartcheck-pike.key/Data/mt5@2x-82.jpg -------------------------------------------------------------------------------- /paper/talk/smartcheck-pike.key/Data/mt6@2x-83.jpg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/leepike/SmartCheck/86bfe4a3f61bfd74fa79e1afb9b5a77d4ad58efb/paper/talk/smartcheck-pike.key/Data/mt6@2x-83.jpg -------------------------------------------------------------------------------- /paper/talk/smartcheck-pike.key/Data/mt7@2x-84.jpg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/leepike/SmartCheck/86bfe4a3f61bfd74fa79e1afb9b5a77d4ad58efb/paper/talk/smartcheck-pike.key/Data/mt7@2x-84.jpg -------------------------------------------------------------------------------- /paper/talk/smartcheck-pike.key/Data/mt8@2x-85.jpg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/leepike/SmartCheck/86bfe4a3f61bfd74fa79e1afb9b5a77d4ad58efb/paper/talk/smartcheck-pike.key/Data/mt8@2x-85.jpg -------------------------------------------------------------------------------- /paper/talk/smartcheck-pike.key/Data/mt9@2x-86.jpg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/leepike/SmartCheck/86bfe4a3f61bfd74fa79e1afb9b5a77d4ad58efb/paper/talk/smartcheck-pike.key/Data/mt9@2x-86.jpg -------------------------------------------------------------------------------- /paper/talk/smartcheck-pike.key/Data/pasted-image-332.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/leepike/SmartCheck/86bfe4a3f61bfd74fa79e1afb9b5a77d4ad58efb/paper/talk/smartcheck-pike.key/Data/pasted-image-332.pdf -------------------------------------------------------------------------------- /paper/talk/smartcheck-pike.key/Data/pasted-image-94.tif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/leepike/SmartCheck/86bfe4a3f61bfd74fa79e1afb9b5a77d4ad58efb/paper/talk/smartcheck-pike.key/Data/pasted-image-94.tif -------------------------------------------------------------------------------- /paper/talk/smartcheck-pike.key/Data/pasted-image-small-333.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/leepike/SmartCheck/86bfe4a3f61bfd74fa79e1afb9b5a77d4ad58efb/paper/talk/smartcheck-pike.key/Data/pasted-image-small-333.png -------------------------------------------------------------------------------- /paper/talk/smartcheck-pike.key/Data/pasted-image-small-95.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/leepike/SmartCheck/86bfe4a3f61bfd74fa79e1afb9b5a77d4ad58efb/paper/talk/smartcheck-pike.key/Data/pasted-image-small-95.png -------------------------------------------------------------------------------- /paper/talk/smartcheck-pike.key/Data/st0-97.jpg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/leepike/SmartCheck/86bfe4a3f61bfd74fa79e1afb9b5a77d4ad58efb/paper/talk/smartcheck-pike.key/Data/st0-97.jpg -------------------------------------------------------------------------------- /paper/talk/smartcheck-pike.key/Data/st1-3216.jpg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/leepike/SmartCheck/86bfe4a3f61bfd74fa79e1afb9b5a77d4ad58efb/paper/talk/smartcheck-pike.key/Data/st1-3216.jpg -------------------------------------------------------------------------------- /paper/talk/smartcheck-pike.key/Data/st10-1331.jpg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/leepike/SmartCheck/86bfe4a3f61bfd74fa79e1afb9b5a77d4ad58efb/paper/talk/smartcheck-pike.key/Data/st10-1331.jpg -------------------------------------------------------------------------------- /paper/talk/smartcheck-pike.key/Data/st12-2968.jpg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/leepike/SmartCheck/86bfe4a3f61bfd74fa79e1afb9b5a77d4ad58efb/paper/talk/smartcheck-pike.key/Data/st12-2968.jpg -------------------------------------------------------------------------------- /paper/talk/smartcheck-pike.key/Data/st13-3147.jpg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/leepike/SmartCheck/86bfe4a3f61bfd74fa79e1afb9b5a77d4ad58efb/paper/talk/smartcheck-pike.key/Data/st13-3147.jpg -------------------------------------------------------------------------------- /paper/talk/smartcheck-pike.key/Data/st14-2470.jpg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/leepike/SmartCheck/86bfe4a3f61bfd74fa79e1afb9b5a77d4ad58efb/paper/talk/smartcheck-pike.key/Data/st14-2470.jpg -------------------------------------------------------------------------------- /paper/talk/smartcheck-pike.key/Data/st15-1913.jpg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/leepike/SmartCheck/86bfe4a3f61bfd74fa79e1afb9b5a77d4ad58efb/paper/talk/smartcheck-pike.key/Data/st15-1913.jpg -------------------------------------------------------------------------------- /paper/talk/smartcheck-pike.key/Data/st15-3261.jpg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/leepike/SmartCheck/86bfe4a3f61bfd74fa79e1afb9b5a77d4ad58efb/paper/talk/smartcheck-pike.key/Data/st15-3261.jpg -------------------------------------------------------------------------------- /paper/talk/smartcheck-pike.key/Data/st16-3275.jpg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/leepike/SmartCheck/86bfe4a3f61bfd74fa79e1afb9b5a77d4ad58efb/paper/talk/smartcheck-pike.key/Data/st16-3275.jpg -------------------------------------------------------------------------------- /paper/talk/smartcheck-pike.key/Data/st18-3015.jpg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/leepike/SmartCheck/86bfe4a3f61bfd74fa79e1afb9b5a77d4ad58efb/paper/talk/smartcheck-pike.key/Data/st18-3015.jpg -------------------------------------------------------------------------------- /paper/talk/smartcheck-pike.key/Data/st2-2935.jpg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/leepike/SmartCheck/86bfe4a3f61bfd74fa79e1afb9b5a77d4ad58efb/paper/talk/smartcheck-pike.key/Data/st2-2935.jpg -------------------------------------------------------------------------------- /paper/talk/smartcheck-pike.key/Data/st3-2530.jpg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/leepike/SmartCheck/86bfe4a3f61bfd74fa79e1afb9b5a77d4ad58efb/paper/talk/smartcheck-pike.key/Data/st3-2530.jpg -------------------------------------------------------------------------------- /paper/talk/smartcheck-pike.key/Data/st4-3192.jpg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/leepike/SmartCheck/86bfe4a3f61bfd74fa79e1afb9b5a77d4ad58efb/paper/talk/smartcheck-pike.key/Data/st4-3192.jpg -------------------------------------------------------------------------------- /paper/talk/smartcheck-pike.key/Data/st5-3201.jpg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/leepike/SmartCheck/86bfe4a3f61bfd74fa79e1afb9b5a77d4ad58efb/paper/talk/smartcheck-pike.key/Data/st5-3201.jpg -------------------------------------------------------------------------------- /paper/talk/smartcheck-pike.key/Data/st7-2553.jpg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/leepike/SmartCheck/86bfe4a3f61bfd74fa79e1afb9b5a77d4ad58efb/paper/talk/smartcheck-pike.key/Data/st7-2553.jpg -------------------------------------------------------------------------------- /paper/talk/smartcheck-pike.key/Index.zip: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/leepike/SmartCheck/86bfe4a3f61bfd74fa79e1afb9b5a77d4ad58efb/paper/talk/smartcheck-pike.key/Index.zip -------------------------------------------------------------------------------- /paper/talk/smartcheck-pike.key/Metadata/BuildVersionHistory.plist: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | Template: White (2014-02-28 09:41) 6 | M6.2-1861-1 7 | 8 | 9 | -------------------------------------------------------------------------------- /paper/talk/smartcheck-pike.key/Metadata/DocumentIdentifier: -------------------------------------------------------------------------------- 1 | 44CD53D3-2A5C-4DB2-9A3B-55CCA8948600 -------------------------------------------------------------------------------- /paper/talk/smartcheck-pike.key/Metadata/Properties.plist: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/leepike/SmartCheck/86bfe4a3f61bfd74fa79e1afb9b5a77d4ad58efb/paper/talk/smartcheck-pike.key/Metadata/Properties.plist -------------------------------------------------------------------------------- /paper/talk/smartcheck-pike.key/preview-micro.jpg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/leepike/SmartCheck/86bfe4a3f61bfd74fa79e1afb9b5a77d4ad58efb/paper/talk/smartcheck-pike.key/preview-micro.jpg -------------------------------------------------------------------------------- /paper/talk/smartcheck-pike.key/preview-web.jpg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/leepike/SmartCheck/86bfe4a3f61bfd74fa79e1afb9b5a77d4ad58efb/paper/talk/smartcheck-pike.key/preview-web.jpg -------------------------------------------------------------------------------- /paper/talk/smartcheck-pike.key/preview.jpg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/leepike/SmartCheck/86bfe4a3f61bfd74fa79e1afb9b5a77d4ad58efb/paper/talk/smartcheck-pike.key/preview.jpg -------------------------------------------------------------------------------- /paper/talk/smartcheck.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/leepike/SmartCheck/86bfe4a3f61bfd74fa79e1afb9b5a77d4ad58efb/paper/talk/smartcheck.png -------------------------------------------------------------------------------- /qc-tests/Tests.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable #-} 2 | {-# LANGUAGE DeriveGeneric #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | {-# LANGUAGE StandaloneDeriving #-} 5 | {-# LANGUAGE CPP #-} 6 | 7 | {-# OPTIONS_GHC -fno-warn-orphans #-} 8 | 9 | -- QuickCheck tests for the implementation of SmartCheck. 10 | 11 | module Main where 12 | 13 | import qualified Test.QuickCheck as Q 14 | 15 | import Data.Maybe 16 | import Data.Tree 17 | import Control.Monad 18 | import GHC.Generics 19 | import Test.SmartCheck.DataToTree 20 | import Test.SmartCheck.Types 21 | 22 | -------------------------------------------------------------------------------- 23 | 24 | #if MIN_VERSION_containers(0,5,10) 25 | #else 26 | deriving instance Generic (Tree a) 27 | #endif 28 | 29 | instance (SubTypes a) => SubTypes (Tree a) 30 | 31 | instance Q.Arbitrary a => Q.Arbitrary (Tree a) where 32 | arbitrary = Q.sized mkT 33 | where 34 | mkT 0 = Q.arbitrary >>= \a -> return (Node a []) 35 | mkT n = do len <- Q.choose (0, 4) 36 | a <- Q.arbitrary 37 | ls <- replicateM len mkT' 38 | return $ Node a ls 39 | where mkT' = mkT =<< Q.choose (0, n-1) 40 | 41 | instance Q.Arbitrary Idx where 42 | arbitrary = liftM2 Idx Q.arbitrary Q.arbitrary 43 | 44 | -------------------------------------------------------------------------------- 45 | 46 | -- Just to prevent us from getting too many Nothings from indexing too deeply. 47 | dep :: Maybe Int 48 | dep = Just 5 49 | 50 | -------------------------------------------------------------------------------- 51 | 52 | -- If you take from v a sub-value v' at index i, then replace v' at index i, you 53 | -- get v back. 54 | prop_getReplaceIdem :: 55 | Tree Int -> Q.NonNegative Int -> Q.NonNegative Int -> Bool 56 | prop_getReplaceIdem v (Q.NonNegative i) (Q.NonNegative j) = 57 | let x = getAtIdx v idx dep in 58 | case x of 59 | Nothing -> True 60 | Just st -> rep st 61 | where 62 | idx = Idx i j 63 | rep (SubT v') = replaceAtIdx v idx v' == Just v 64 | 65 | -------------------------------------------------------------------------------- 66 | 67 | -- Morally, getAtIdx v idx Nothing == rootLabel $ getIdxForest (subTypes v) idx 68 | -- 69 | -- That is, they return the same value, except getIdxForest returns the whole 70 | -- tree. 71 | prop_forestTreeEq :: Tree Int -> Q.Positive Int -> Q.NonNegative Int -> Bool 72 | prop_forestTreeEq v (Q.Positive i) (Q.NonNegative j) = 73 | let mx = getAtIdx v idx Nothing :: Maybe SubT in 74 | let my = getIdxForest (subTypes v) idx :: Maybe (Tree SubT) in 75 | (isNothing mx && isNothing my) || go mx my == Just True 76 | where 77 | -- XXX Hack! Since SubTypes doesn't derive Eq. 78 | exEq (SubT x) (SubT y) = show x == show y 79 | idx = Idx i j 80 | go a b = do 81 | x <- a 82 | y <- b 83 | return $ exEq x (rootLabel y) 84 | 85 | -------------------------------------------------------------------------------- 86 | -- Prop: 87 | -- null (subTypes v) iff null (showForest v) 88 | -------------------------------------------------------------------------------- 89 | 90 | 91 | -- Some random values. 92 | vals :: IO () 93 | vals = Q.sample (Q.resize 5 Q.arbitrary :: Q.Gen (Tree Int)) 94 | 95 | main :: IO () 96 | main = do 97 | Q.quickCheck prop_getReplaceIdem 98 | Q.quickCheck prop_forestTreeEq 99 | 100 | -------------------------------------------------------------------------------- 101 | -------------------------------------------------------------------------------- /refs/README.txt: -------------------------------------------------------------------------------- 1 | -- xmonad ---------------------------------------------------------------------- 2 | 3 | * internals overview: 4 | http://xmonad.org/xmonad-docs/xmonad-contrib/XMonad-Doc-Developing.html 5 | 6 | * hackage: http://hackage.haskell.org/package/xmonad 7 | 8 | * properties are inside 0.10/xmonad-0.10/tests/ 9 | 10 | INSTRUCTIONS 11 | 12 | * Blow away your cabal-dev directories to do a fresh install. 13 | 14 | Make latest smartcheck: from SmartCheck: 15 | > cabal-dev install 16 | 17 | Make smartcheck available: from xmonad-0.10/ 18 | > cabal-dev add-source ../../../../ 19 | 20 | Turn on testing: 21 | > cabal-dev install -ftesting 22 | 23 | From xmonad-0.10/ 24 | > cabal-dev ghci -Wall 25 | 26 | > Properties.main 27 | 28 | or to test individual props: 29 | 30 | > :m + Test.QuickCheck.Test 31 | 32 | > quickCheckWithResult stdArgs Properties.prop_shift_reversible 33 | 34 | or 35 | 36 | > :m + Test.SmartCheck 37 | > smartCheck scStdArgs prop_shift_reversible 38 | 39 | (This is a good candidate for shrinking...) 40 | 41 | * Mark changed properties or functions in StackSet.hs with -- BAD 42 | * Changes for SmartCheck marked with -- SC 43 | 44 | -- TODOs ----------------------------------------------------------------------- 45 | 46 | * Find disjunctive invariants---actually, just add as new preconditions to 47 | tests. 48 | 49 | * Run smartcheck and quickcheck in parallel. Maybe? 50 | 51 | * Run as many tests in parallel as possible. Maybe? 52 | 53 | * Explore the idea of data coverage: 54 | 55 | * E.g., trivial "false" property to see if your program exercises all 56 | constructors. 57 | 58 | * Kinds of type coverage: exists some contructor to fail... 59 | -------------------------------------------------------------------------------- /refs/quickcheck-notes.md: -------------------------------------------------------------------------------- 1 | # QuickCheck implementation notes for my own use. (The design is rather clever. :) I *think* this is how things work...) 2 | 3 | --------------------------------------- 4 | 5 | The main entry point is `quickCheckWithResult`. There, a property (something that 6 | belongs to the `Testable` class) is turned into a `Property`: 7 | 8 | type Property = Gen Prop 9 | newtype Prop = MkProp{ unProp :: Rose Result } 10 | data Rose a = MkRose a [Rose a] | IORose (IO (Rose a)) 11 | 12 | (more on that in a bit) by using `Testable`'s `property` method. At 13 | this point, it's important to know that we have everything we need to test some 14 | function: we've generated random values for the function's inputs, and we have a 15 | tree of results based on shrinking the values in the Rose tree. So none of the 16 | data structures (e.g., Result) need to be paramaterized by the function argument 17 | types. 18 | 19 | So `quickCheckWithResult` calls `test`, which calls `runATest`. There, we loop 20 | (by calling `continue`, locally defined in `runATest`) if we don't get a 21 | failure. If we do get a failure, we start shrinking in the call 22 | 23 | foundFailure st res ts 24 | 25 | `foundFailure` starts a loop of looking through the Rose Tree to find smaller 26 | failing values (`localMin'` calls `foundFailure` to complete the loop). 27 | 28 | The real magic is in the `Testable` class in the Rose data structure, both 29 | defined in the `Property` module. Starting with `Testable`: basically, you're 30 | going to have some function `f :: X -> Y -> ... -> Bool` that you want to test. 31 | QuickCheck knows how to make arbitrary values for `X`, `Y`, etc. So the first 32 | instance you'll probably encounter is 33 | 34 | instance (Arbitrary a, Show a, Testable prop) => Testable (a -> prop) where 35 | property f = forAllShrink arbitrary shrink f 36 | 37 | `forallShrink` calls `shrinking`, which actually makes the `Property`. 38 | 39 | shrinking :: Testable prop => 40 | (a -> [a]) -- ^ 'shrink'-like function. 41 | -> a -- ^ The original argument 42 | -> (a -> prop) -> Property 43 | shrinking shrinker x0 pf = fmap (MkProp . joinRose . fmap unProp) (promote (props x0)) 44 | where props x = MkRose (property (pf x)) [ props x' | x' <- shrinker x ] 45 | 46 | We "tie the knot" by calling `property (pf x)` here, where as you'll recall, is 47 | the method of the `Testable` class. So if you have more arguments to the 48 | function, they'll get consumed. Recall for each argument for the function, 49 | we'll call `forAllShrink arbitrary shrink f` again... So here, 50 | 51 | Note that the new random value is produced in 'forAllShrink', where there is an 52 | 53 | x <- gen 54 | 55 | As for some types, 56 | 57 | props :: a -> Rose Property 58 | ===> alpha-renames to 59 | props :: a -> Rose (Gen Prop) 60 | 61 | which is a little confusing. This is a rose tree of Rose `Result`s: each 62 | element is a rose tree! But `joinRose` combines the "inner" Rose tree with the 63 | outer one, so we're left with a sane rose tree. 64 | 65 | I guess the way to think about the type `Rose Result` is that for a value 66 | 67 | MkRose v ls 68 | 69 | `v` is the result of evaluating the function, and `ls` holds all possible 70 | shrinks for `v`. If `v` fails, we want to traverse down `ls`, finding the best 71 | shrinking. The nondeterminism held by the Rose tree is to keep us from favoring 72 | one argument's shrink over another. That is, for 73 | 74 | foo :: Int -> Int -> Bool 75 | foo x y = ... 76 | 77 | we don't want to favor the shrinking results of `x` over `y`. The Rose tree 78 | gives us a list of shrinks with `x`, and from these, a list of shrinks with `y`. 79 | So if the first shrink of `x` doesn't work, we'll ignore all `y`s there. 80 | 81 | You can see this in the definition of `noShrinking`: 82 | 83 | noShrinking :: Testable prop => prop -> Property 84 | noShrinking = mapRoseResult (onRose (\res _ -> MkRose res [])) 85 | 86 | It throws away the shrinking values. 87 | 88 | When testing a function like 89 | 90 | prop :: Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Bool 91 | prop a b c d e f g h i j = average [a, b, c, d, e, f, g, h, i, j] < 1000 92 | where 93 | average [] = 0 94 | average ls = fromIntegral (sum ls) / fromIntegral (length ls) 95 | 96 | QuickCheck doesn't seem to favor (overly) early arguments over late ones. Of 97 | course, you're always just finding a local minimum... I don't think there's 98 | backtracking. 99 | 100 | Where did the argument types go in all of this? The `Result` (or `State`) data 101 | structures don't carry any information about the argument types. This all goes 102 | away in `forAllShrink` (and `shrinking`), after which we have a `Property` data 103 | structure. Note, for example, in the call to `counterexample` in `forAllShrink` 104 | there is an explicit use of `show`. 105 | 106 | New tests, and their potential shrinks, in the Rose Tree are generated in 107 | `runATest`: 108 | 109 | unProp (f rnd1 size) 110 | 111 | Note: 112 | 113 | foobar :: Int -> Int 114 | foobar i = unGen inGen (mkQCGen i) 10 115 | where 116 | inGen :: Gen Int 117 | inGen = do 118 | let f :: Int -> Int 119 | f x = x + 10 120 | x <- arbitrary 121 | return (f x) 122 | 123 | Will return new values for new inputs. 124 | -------------------------------------------------------------------------------- /refs/reddit-comments.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/leepike/SmartCheck/86bfe4a3f61bfd74fa79e1afb9b5a77d4ad58efb/refs/reddit-comments.png -------------------------------------------------------------------------------- /regression/.gitignore: -------------------------------------------------------------------------------- 1 | *.out 2 | *.csv 3 | *.log 4 | *.hi 5 | *.o 6 | -------------------------------------------------------------------------------- /regression/Config.mk: -------------------------------------------------------------------------------- 1 | RNDS = 100 2 | LOG = regression.log 3 | DB = ../../.cabal-sandbox/*-packages.conf.d 4 | 5 | %.out : $(SRC).hs 6 | mkdir -p out 7 | ghc --make -Wall -package-db $(DB) -O2 -D$* -o out/$@ $< ../Test.hs 8 | date >> $(LOG) 9 | echo "*******************" >> $(LOG) 10 | echo $@ >> $(LOG) 11 | ./out/$@ \"out/$*\" $(RNDS) 12 | 13 | .PHONY : clean 14 | clean : 15 | -rm -r out 16 | -rm $(SRC).o $(SRC).hi 17 | 18 | .PHONY : veryclean 19 | veryclean : clean 20 | -rm $(LOG) 21 | -------------------------------------------------------------------------------- /regression/Degenerate/Degenerate.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE TemplateHaskell #-} 3 | {-# LANGUAGE DeriveDataTypeable #-} 4 | {-# LANGUAGE DeriveGeneric #-} 5 | 6 | -- | Degenerate test case. In which QuickCheck will fail to find a minimal 7 | -- counterexample, but SmartCheck finds one. The reason is that when (generic) 8 | -- shrinking, QuickCheck only uses constructors found in the original 9 | -- counterexample. 10 | 11 | module Main where 12 | 13 | import Prelude hiding (showList, mod) 14 | 15 | #if defined(qcGen) || defined(smart) 16 | -- import Test 17 | import System.Environment 18 | #endif 19 | 20 | import Test.QuickCheck 21 | import Test.SmartCheck 22 | 23 | import GHC.Generics hiding (S) 24 | import Data.Typeable 25 | import Control.Applicative 26 | 27 | ----------------------------------------------------------------- 28 | 29 | data E = A E | B E | C E | N deriving (Show, Read, Eq, Typeable, Generic) 30 | 31 | instance SubTypes E 32 | 33 | -- | Generates sequences of 2-100 constructors, wtih a high probability that 34 | -- they're the same. 35 | instance Arbitrary E where 36 | arbitrary = go 37 | where go = go' =<< choose (10::Int, 100) 38 | go' i = do go'' i =<< choose (0::Int, 2) 39 | 40 | go'' 0 _ = return N 41 | go'' i c = let g = go'' (i-1) in 42 | case c of 43 | 0 -> frequency [ (90, A <$> g 0) 44 | , ( 5, B <$> g 1) 45 | , ( 5, C <$> g 2) 46 | ] 47 | 1 -> frequency [ (90, B <$> g 1) 48 | , ( 5, A <$> g 0) 49 | , ( 5, C <$> g 2) 50 | ] 51 | 2 -> frequency [ (90, C <$> g 2) 52 | , ( 5, A <$> g 0) 53 | , ( 5, B <$> g 1) 54 | ] 55 | 56 | #ifdef qcGen 57 | shrink = genericShrink 58 | #endif 59 | 60 | -- | The length of the sequence if all constructors are the same, Nothing otherwise. 61 | degenLen :: E -> Maybe Int 62 | degenLen N = Nothing 63 | degenLen e' = case e' of 64 | A e -> degenA e 65 | B e -> degenB e 66 | C e -> degenC e 67 | N -> Nothing 68 | where 69 | degenA N = Just 1 70 | degenA (A e) = fmap (+1) (degenA e) 71 | degenA _ = Nothing 72 | 73 | degenB N = Just 1 74 | degenB (B e) = fmap (+1) (degenB e) 75 | degenB _ = Nothing 76 | 77 | degenC N = Just 1 78 | degenC (C e) = fmap (+1) (degenC e) 79 | degenC _ = Nothing 80 | 81 | -- | Fails if there are more than 4 constructors that are the same. 82 | prop_degen :: E -> Bool 83 | prop_degen e0 84 | | Just i <- degenLen e0 85 | , i > 4 86 | = False 87 | | otherwise 88 | = True 89 | 90 | -- | Fails if all constructors in a sequence differ and has a size of at least 91 | -- 1. 92 | diff :: E -> Bool 93 | diff N = True 94 | diff (A (B (C N))) = False 95 | diff (A (C (B N))) = False 96 | diff (B (A (C N))) = False 97 | diff (B (C (A N))) = False 98 | diff (C (A (B N))) = False 99 | diff (C (B (A N))) = False 100 | diff e = size e >= 3 101 | 102 | -- Fails if either all values differ or we have a long string of the same 103 | -- constructor. 104 | prop :: E -> Bool 105 | prop e = prop_degen e && diff e 106 | 107 | size :: E -> Int 108 | size = sizeE 109 | 110 | sizeE :: E -> Int 111 | sizeE e' = case e' of 112 | A e -> 1 + sizeE e 113 | B e -> 1 + sizeE e 114 | C e -> 1 + sizeE e 115 | N -> 0 116 | 117 | qArgs :: Args 118 | qArgs = stdArgs { maxSuccess = 10000 } 119 | 120 | scargs :: ScArgs 121 | scargs = scStdArgs { qcArgs = qArgs 122 | , format = PrintString 123 | , runForall = False 124 | , runExists = False 125 | } 126 | 127 | qcTest :: IO () 128 | qcTest = quickCheckWith stdArgs { maxSuccess = 10000 } prop 129 | 130 | scTest :: IO () 131 | scTest = smartCheck scargs prop 132 | 133 | -- #if defined(qcGen) || defined(smart) 134 | -- main :: IO () 135 | -- main = do 136 | -- [file', rnds'] <- getArgs 137 | -- let rnds = read rnds' :: Int 138 | -- let file = read file' :: String 139 | -- #if defined(qcGen) 140 | -- test file rnds $ runQC' proxy qArgs prop size 141 | -- #endif 142 | -- #ifdef smart 143 | -- test file rnds $ runSC scargs prop size 144 | -- #endif 145 | -- #endif 146 | -------------------------------------------------------------------------------- /regression/Degenerate/Makefile: -------------------------------------------------------------------------------- 1 | SRC = Degenerate 2 | 3 | # We never run small.out since it's not feasible. 4 | TARGETS = qcGen.out smart.out 5 | 6 | all : $(TARGETS) 7 | 8 | include ../Config.mk 9 | -------------------------------------------------------------------------------- /regression/Div0/Div0.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE DeriveDataTypeable #-} 3 | {-# LANGUAGE DeriveGeneric #-} 4 | 5 | -- | Divide by 0 example in a simple arithmetic language. 6 | 7 | module Main where 8 | 9 | #if defined(qc) || defined(qcGen) || defined(smart) 10 | import Test 11 | import System.Environment 12 | #endif 13 | import Test.QuickCheck 14 | import Test.SmartCheck 15 | import Control.Monad 16 | 17 | import GHC.Generics 18 | import Data.Typeable 19 | 20 | ----------------------------------------------------------------- 21 | 22 | data Exp = C Int 23 | | Add Exp Exp 24 | | Div Exp Exp 25 | deriving (Show, Read, Typeable, Generic) 26 | 27 | instance SubTypes Exp 28 | 29 | eval :: Exp -> Maybe Int 30 | eval (C i) = Just i 31 | eval (Add e0 e1) = 32 | liftM2 (+) (eval e0) (eval e1) 33 | eval (Div e0 e1) = 34 | let e = eval e1 in 35 | if e == Just 0 then Nothing 36 | else liftM2 div (eval e0) e 37 | 38 | instance Arbitrary Exp where 39 | arbitrary = sized mkM 40 | where 41 | mkM 0 = liftM C arbitrary 42 | mkM n = oneof [ liftM2 Add mkM' mkM' 43 | , liftM2 Div mkM' mkM' ] 44 | where mkM' = mkM =<< choose (0,n-1) 45 | #ifdef qc 46 | shrink (C i) = map C (shrink i) 47 | shrink (Add e0 e1) = [e0, e1] 48 | shrink (Div e0 e1) = [e0, e1] 49 | #endif 50 | #ifdef qcGen 51 | shrink = genericShrink 52 | #endif 53 | 54 | -- property: so long as 0 isn't in the divisor, we won't try to divide by 0. 55 | -- It's false: something might evaluate to 0 still. 56 | prop_div :: Exp -> Property 57 | prop_div e = divSubTerms e ==> eval e /= Nothing 58 | 59 | -- precondition: no dividand in a subterm can be 0. 60 | divSubTerms :: Exp -> Bool 61 | divSubTerms (C _) = True 62 | divSubTerms (Div _ (C 0)) = False 63 | divSubTerms (Add e0 e1) = divSubTerms e0 && divSubTerms e1 64 | divSubTerms (Div e0 e1) = divSubTerms e0 && divSubTerms e1 65 | 66 | -- Get the minimal offending sub-value. 67 | findVal :: Exp -> (Exp,Exp) 68 | findVal (Div e0 e1) 69 | | eval e1 == Just 0 = (e0,e1) 70 | | eval e1 == Nothing = findVal e1 71 | | otherwise = findVal e0 72 | findVal a@(Add e0 e1) 73 | | eval e0 == Nothing = findVal e0 74 | | eval e1 == Nothing = findVal e1 75 | | eval a == Just 0 = (a,a) 76 | findVal _ = error "not possible" 77 | 78 | size :: Exp -> Int 79 | size e = case e of 80 | C _ -> 1 81 | Add e0 e1 -> 1 + size e0 + size e1 82 | Div e0 e1 -> 1 + size e0 + size e1 83 | 84 | divTest :: IO () 85 | divTest = smartCheck args prop_div 86 | where 87 | args = scStdArgs { qcArgs = stdArgs 88 | -- { maxSuccess = 1000 89 | -- , maxSize = 20 } 90 | , format = PrintString 91 | , runForall = True 92 | } 93 | 94 | #if defined(qc) || defined(qcGen) || defined(smart) 95 | main :: IO () 96 | main = do 97 | [file', rnds'] <- getArgs 98 | let rnds = read rnds' :: Int 99 | let file = read file' :: String 100 | #if defined(qc) || defined(qcGen) 101 | test file rnds $ runQC' proxy stdArgs prop_div size 102 | #else 103 | test file rnds $ runSC scStdArgs prop_div size 104 | #endif 105 | #endif 106 | 107 | -------------------------------------------------------------------------------- 108 | -------------------------------------------------------------------------------- /regression/Div0/Makefile: -------------------------------------------------------------------------------- 1 | SRC = Div0 2 | 3 | # We never run small.out since it's not feasible. 4 | TARGETS = qc.out qcGen.out smart.out 5 | 6 | all : $(TARGETS) 7 | 8 | include ../Config.mk 9 | -------------------------------------------------------------------------------- /regression/Heap/Heap_Program.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | 3 | {-# LANGUAGE ScopedTypeVariables, TemplateHaskell, DeriveDataTypeable, StandaloneDeriving #-} 4 | {-# LANGUAGE DeriveGeneric #-} 5 | {-# LANGUAGE DeriveDataTypeable #-} 6 | 7 | {-# OPTIONS_GHC -fno-warn-missing-signatures #-} 8 | {-# OPTIONS_GHC -fno-warn-orphans #-} 9 | 10 | -- Copied from QuickCheck2's examples. 11 | 12 | module Main where 13 | 14 | -------------------------------------------------------------------------- 15 | -- imports 16 | 17 | #if defined(qc) || defined(qcGen) || defined(smart) 18 | import Test 19 | import System.Environment 20 | #endif 21 | import Test.SmartCheck 22 | 23 | import Test.QuickCheck 24 | import Test.QuickCheck.Poly 25 | 26 | import Data.List 27 | ( sort 28 | ) 29 | import Data.Typeable 30 | 31 | import GHC.Generics 32 | 33 | import qualified Test.SmartCheck as SC 34 | 35 | -------------------------------------------------------------------------- 36 | -- SmartCheck Testing. Comment out shrink instance if you want to be more 37 | -- impressed. :) 38 | -------------------------------------------------------------------------- 39 | 40 | deriving instance Typeable OrdA 41 | deriving instance Generic OrdA 42 | 43 | instance Read OrdA where 44 | readsPrec i = \s -> 45 | let rd = readsPrec i s :: [(Integer,String)] in 46 | let go (i',s') = (OrdA i', s') in 47 | map go rd 48 | 49 | heapProgramTest :: IO () 50 | heapProgramTest = SC.smartCheck SC.scStdArgs prop_ToSortedList 51 | 52 | instance SC.SubTypes OrdA 53 | instance (SC.SubTypes a, Ord a, Arbitrary a, Generic a) 54 | => SC.SubTypes (Heap a) 55 | instance (SC.SubTypes a, Arbitrary a, Generic a) 56 | => SC.SubTypes (HeapP a) 57 | instance (SC.SubTypes a, Ord a, Arbitrary a, Generic a) 58 | => SC.SubTypes (HeapPP a) 59 | 60 | instance (Ord a, Arbitrary a, Typeable a) => Arbitrary (Heap a) where 61 | arbitrary = do p <- arbitrary :: Gen (HeapP a) 62 | return $ heap p 63 | 64 | -------------------------------------------------------------------------- 65 | -- skew heaps 66 | -- Smallest values on top. 67 | 68 | data Heap a 69 | = Node a (Heap a) (Heap a) 70 | | Nil 71 | deriving ( Eq, Ord, Show, Read, Typeable, Generic ) 72 | 73 | empty :: Heap a 74 | empty = Nil 75 | 76 | isEmpty :: Heap a -> Bool 77 | isEmpty Nil = True 78 | isEmpty _ = False 79 | 80 | unit :: a -> Heap a 81 | unit x = Node x empty empty 82 | 83 | size :: Heap a -> Int 84 | size Nil = 0 85 | size (Node _ h1 h2) = 1 + size h1 + size h2 86 | 87 | insert :: Ord a => a -> Heap a -> Heap a 88 | insert x h = unit x `merge` h 89 | 90 | removeMin :: Ord a => Heap a -> Maybe (a, Heap a) 91 | removeMin Nil = Nothing 92 | removeMin (Node x h1 h2) = Just (x, h1 `merge` h2) 93 | 94 | merge :: Ord a => Heap a -> Heap a -> Heap a 95 | h1 `merge` Nil = h1 96 | Nil `merge` h2 = h2 97 | h1@(Node x h11 h12) `merge` h2@(Node y h21 h22) 98 | | x <= y = Node x (h12 `merge` h2) h11 99 | | otherwise = Node y (h22 `merge` h1) h21 100 | 101 | fromList :: Ord a => [a] -> Heap a 102 | fromList xs = merging [ unit x | x <- xs ] 103 | where 104 | merging [] = empty 105 | merging [h] = h 106 | merging hs = merging (sweep hs) 107 | 108 | sweep [] = [] 109 | sweep [h] = [h] 110 | sweep (h1:h2:hs) = (h1 `merge` h2) : sweep hs 111 | 112 | toList :: Heap a -> [a] 113 | toList h = toList' [h] 114 | where 115 | toList' [] = [] 116 | toList' (Nil : hs) = toList' hs 117 | toList' (Node x h1 h2 : hs) = x : toList' (h1:h2:hs) 118 | 119 | toSortedList :: Ord a => Heap a -> [a] 120 | toSortedList Nil = [] 121 | toSortedList (Node x h1 h2) = x : toList (h1 `merge` h2) 122 | 123 | -------------------------------------------------------------------------- 124 | -- heap programs 125 | 126 | data HeapP a 127 | = Empty 128 | | Unit a 129 | | Insert a (HeapP a) 130 | | SafeRemoveMin (HeapP a) 131 | | Merge (HeapP a) (HeapP a) 132 | | FromList [a] 133 | deriving ( Show, Read, Typeable, Generic ) 134 | 135 | heap :: Ord a => HeapP a -> Heap a 136 | heap Empty = empty 137 | heap (Unit x) = unit x 138 | heap (Insert x p) = insert x (heap p) 139 | heap (SafeRemoveMin p) = case removeMin (heap p) of 140 | Nothing -> empty -- arbitrary choice 141 | Just (_,h) -> h 142 | heap (Merge p q) = heap p `merge` heap q 143 | heap (FromList xs) = fromList xs 144 | 145 | instance (Typeable a, Arbitrary a) => Arbitrary (HeapP a) where 146 | arbitrary = sized arbHeapP 147 | where 148 | arbHeapP s = 149 | frequency 150 | [ (1, do return Empty) 151 | , (1, do x <- arbitrary 152 | return (Unit x)) 153 | , (s, do x <- arbitrary 154 | p <- arbHeapP s1 155 | return (Insert x p)) 156 | , (s, do p <- arbHeapP s1 157 | return (SafeRemoveMin p)) 158 | , (s, do p <- arbHeapP s2 159 | q <- arbHeapP s2 160 | return (Merge p q)) 161 | , (1, do xs <- arbitrary 162 | return (FromList xs)) 163 | ] 164 | where 165 | s1 = s-1 166 | s2 = s`div`2 167 | 168 | #ifdef qc 169 | shrink (Unit x) = [ Unit x' | x' <- shrink x ] 170 | shrink (FromList xs) = [ Unit x | x <- xs ] 171 | ++ [ FromList xs' | xs' <- shrink xs ] 172 | shrink (Insert x p) = [ p ] 173 | ++ [ Insert x p' | p' <- shrink p ] 174 | ++ [ Insert x' p | x' <- shrink x ] 175 | shrink (SafeRemoveMin p) = [ p ] 176 | ++ [ SafeRemoveMin p' | p' <- shrink p ] 177 | shrink (Merge p q) = [ p, q ] 178 | ++ [ Merge p' q | p' <- shrink p ] 179 | ++ [ Merge p q' | q' <- shrink q ] 180 | shrink _ = [] 181 | #endif 182 | #ifdef qcGen 183 | shrink = genericShrink 184 | #endif 185 | 186 | data HeapPP a = HeapPP (HeapP a) (Heap a) 187 | deriving ( Show, Read, Typeable, Generic ) 188 | 189 | instance (Ord a, Arbitrary a, Typeable a) => Arbitrary (HeapPP a) where 190 | arbitrary = 191 | do p <- arbitrary 192 | return (HeapPP p (heap p)) 193 | #ifdef qc 194 | shrink (HeapPP p _) = 195 | [ HeapPP p' (heap p') | p' <- shrink p ] 196 | #endif 197 | #ifdef qcGen 198 | shrink = genericShrink 199 | #endif 200 | -------------------------------------------------------------------------- 201 | -- properties 202 | 203 | (==?) :: Heap OrdA -> [OrdA] -> Bool 204 | h ==? xs = sort (toList h) == sort xs 205 | 206 | prop_ToSortedList :: HeapPP OrdA -> Bool 207 | prop_ToSortedList (HeapPP _ h) = 208 | h ==? xs && xs == sort xs 209 | where 210 | xs = toSortedList h 211 | 212 | sizePP :: HeapPP a -> Int 213 | sizePP (HeapPP h0 h1) = sizeP h0 + sizeH h1 214 | 215 | sizeP :: HeapP a -> Int 216 | sizeP hp = case hp of 217 | Empty -> 1 218 | Unit _ -> 1 219 | Insert _ h -> 1 + sizeP h 220 | SafeRemoveMin h -> 1 + sizeP h 221 | Merge h0 h1 -> 1 + sizeP h0 + sizeP h1 222 | FromList ls -> 1 + length ls 223 | 224 | sizeH :: Heap a -> Int 225 | sizeH hp = case hp of 226 | Node a h0 h1 -> 1 + sizeH h0 + sizeH h1 227 | Nil -> 1 228 | 229 | l :: HeapP OrdA 230 | l = FromList [OrdA 2, OrdA 1] 231 | 232 | #if defined(qc) || defined(qcGen) || defined(smart) 233 | main :: IO () 234 | main = do 235 | [file', rnds'] <- getArgs 236 | let rnds = read rnds' :: Int 237 | let file = read file' :: String 238 | #if defined(qc) || defined(qcGen) 239 | test file rnds $ runQC' proxy stdArgs prop_ToSortedList (sizePP :: HeapPP OrdA -> Int) 240 | #else 241 | test file rnds $ runSC scStdArgs prop_ToSortedList sizePP 242 | #endif 243 | #endif 244 | 245 | -------------------------------------------------------------------------------- /regression/Heap/Makefile: -------------------------------------------------------------------------------- 1 | SRC = Heap_Program 2 | 3 | # We never run small.out since it's not feasible. 4 | TARGETS = qc.out qcGen.out smart.out 5 | 6 | all : $(TARGETS) 7 | 8 | # Must come after all target. 9 | include ../Config.mk 10 | 11 | 12 | # %.pdf : $(TARGETS) 13 | # gnuplot script.gnp 14 | 15 | -------------------------------------------------------------------------------- /regression/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2014, Lee Pike 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Lee Pike nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /regression/List/List.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE DeriveDataTypeable #-} 3 | {-# LANGUAGE DeriveGeneric #-} 4 | 5 | -- | List properties 6 | 7 | module Main where 8 | 9 | 10 | #if defined(qc) || defined(qcGen) || defined(smart) 11 | import Test 12 | import System.Environment 13 | #endif 14 | 15 | import Test.QuickCheck 16 | import Test.SmartCheck 17 | 18 | ----------------------------------------------------------------- 19 | 20 | prop_rev :: [Int] -> Bool 21 | prop_rev ls = reverse ls == ls 22 | 23 | revTest :: IO () 24 | revTest = smartCheck args prop_rev 25 | where 26 | args = scStdArgs { qcArgs = stdArgs 27 | -- { maxSuccess = 1000 28 | -- , maxSize = 20 } 29 | , format = PrintString 30 | , runForall = True 31 | } 32 | 33 | #if defined(qc) || defined(qcGen) || defined(smart) 34 | main :: IO () 35 | main = do 36 | [file', rnds'] <- getArgs 37 | let rnds = read rnds' :: Int 38 | let file = read file' :: String 39 | #if defined(qc) || defined(qcGen) 40 | test file rnds $ runQC' (proxy :: Proxy [Int]) stdArgs prop_rev length 41 | #else 42 | test file rnds $ runSC scStdArgs prop_rev length 43 | #endif 44 | #endif 45 | 46 | -------------------------------------------------------------------------------- 47 | -------------------------------------------------------------------------------- /regression/List/Makefile: -------------------------------------------------------------------------------- 1 | SRC = List 2 | 3 | # We never run small.out since it's not feasible. 4 | TARGETS = qc.out qcGen.out smart.out 5 | 6 | all : $(TARGETS) 7 | 8 | include ../Config.mk 9 | 10 | # %.pdf : $(TARGETS) 11 | # gnuplot script.gnp 12 | 13 | -------------------------------------------------------------------------------- /regression/Makefile: -------------------------------------------------------------------------------- 1 | DIRS = List Div0 Heap PaperExample1 Parser 2 | # DIRS = Degenerate 3 | BENCHMARKS = $(foreach dir, $(DIRS), $(dir).reg) 4 | CLEANS = $(foreach dir, $(DIRS), $(dir).clean) 5 | VERYCLEANS = $(foreach dir, $(DIRS), $(dir).veryclean) 6 | 7 | .PHONY: all clean veryclean 8 | 9 | all: $(BENCHMARKS) 10 | 11 | %.reg: 12 | $(MAKE) all -C $* 13 | 14 | clean: $(CLEANS) 15 | 16 | %.clean: 17 | $(MAKE) clean -C $* 18 | 19 | veryclean: $(VERYCLEANS) 20 | 21 | %.veryclean: 22 | $(MAKE) veryclean -C $* 23 | -------------------------------------------------------------------------------- /regression/PaperExample1/Makefile: -------------------------------------------------------------------------------- 1 | SRC = PaperExample1 2 | FRMT = jpeg 3 | 4 | # We never run small.out since it's not feasible. 5 | TARGETS = qcNone.out \ 6 | qcGen.out \ 7 | qcjh.out \ 8 | smart.out \ 9 | qc10.out 10 | 11 | # feat.out \ 12 | 13 | GRAPHS = data.$(FRMT) time-big.$(FRMT) time-small.$(FRMT) 14 | 15 | all : $(TARGETS) 16 | gnuplot script.gnp 17 | 18 | include ../Config.mk 19 | -------------------------------------------------------------------------------- /regression/PaperExample1/PaperExample1.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE TemplateHaskell #-} 3 | {-# LANGUAGE DeriveDataTypeable #-} 4 | {-# LANGUAGE FlexibleInstances #-} 5 | {-# LANGUAGE DeriveGeneric #-} 6 | 7 | -- | Try to generate a very large counterexample. 8 | 9 | module Main where 10 | 11 | #if defined(qcjh) || defined(qcNone) || defined(qc10) || defined(qc20) || defined(feat) || defined(qcGen) || defined(smart) || defined(small) 12 | import Test 13 | import System.Environment 14 | #endif 15 | 16 | import Test.SmartCheck 17 | import Test.QuickCheck 18 | #ifdef small 19 | import Test.LazySmallCheck hiding (Property, test, (==>)) 20 | import qualified Test.LazySmallCheck as S 21 | #endif 22 | 23 | import GHC.Generics hiding (P, C) 24 | import Data.Typeable 25 | 26 | import Data.Int 27 | import Control.Monad 28 | 29 | #ifdef feat 30 | import Test.Feat 31 | #endif 32 | 33 | ----------------------------------------------------------------- 34 | 35 | #if defined(qcjh) || defined(qcNone) || defined(qc10) || defined(qc20) 36 | -- So that Int16s aren't shrunk by default arbitrary instances. 37 | newtype J = J { getInt :: Int16 } deriving (Show, Read) 38 | type I = [J] 39 | instance Arbitrary J where 40 | arbitrary = fmap J arbitrary 41 | #else 42 | type I = [Int16] 43 | #endif 44 | 45 | data T = T I I I I I 46 | deriving (Read, Show, Typeable, Generic) 47 | 48 | -- SmallCheck -------------------------- 49 | #ifdef small 50 | enum :: (Enum b, Integral a, Num b) => a -> [b] 51 | enum d = [(-d')..d'] 52 | where d' = fromIntegral d 53 | 54 | instance Serial Int16 where 55 | series = drawnFrom . enum 56 | 57 | instance Serial Word8 where 58 | series = drawnFrom . enum 59 | 60 | instance Serial T where 61 | series = cons5 T 62 | #endif 63 | -- SmallCheck -------------------------- 64 | 65 | -- SmartCheck -------------------------- 66 | #ifdef smart 67 | instance SubTypes I 68 | instance SubTypes T 69 | #endif 70 | -- SmartCheck -------------------------- 71 | 72 | -- qc/shrink takes over 1m seconds 73 | instance Arbitrary T where 74 | #ifdef feat 75 | arbitrary = sized uniform 76 | #else 77 | arbitrary = liftM5 T arbitrary arbitrary 78 | arbitrary arbitrary arbitrary 79 | #endif 80 | 81 | #if defined(qcNone) || defined(feat) 82 | shrink _ = [] 83 | #endif 84 | #if defined(qcjh) 85 | shrink (T i0 i1 i2 i3 i4) = map go xs 86 | where xs = shrink (i0, i1, i2, i3, i4) 87 | go (i0', i1', i2', i3', i4') = T i0' i1' i2' i3' i4' 88 | #endif 89 | #if defined(qc10) || defined(qc20) 90 | shrink (T i0 i1 i2 i3 i4) = 91 | [ T a b c d e | a <- tk i0 92 | , b <- tk i1, c <- tk i2 93 | , d <- tk i3, e <- tk i4 ] 94 | where 95 | #ifdef qc10 96 | sz = 10 97 | #endif 98 | #ifdef qc20 99 | sz = 20 100 | #endif 101 | tk x = take sz (shrink x) 102 | #endif 103 | #if defined(qcNaive) 104 | shrink (T i0 i1 i2 i3 i4) = 105 | [ T a b c d e | a <- shrink i0 106 | , b <- shrink i1, c <- shrink i2 107 | , d <- shrink i3, e <- shrink i4 ] 108 | #endif 109 | #if defined(qcGen) 110 | shrink = genericShrink 111 | #endif 112 | 113 | -- Feat -------------------------------- 114 | #ifdef feat 115 | deriveEnumerable ''T 116 | #endif 117 | -- Feat -------------------------------- 118 | 119 | toList :: T -> [[Int16]] 120 | toList (T i0 i1 i2 i3 i4) = 121 | #if defined(qcjh) || defined(qcNone) || defined(qc10) || defined(qc20) 122 | (map . map) (fromIntegral . getInt) [i0, i1, i2, i3, i4] 123 | #else 124 | [i0, i1, i2, i3, i4] 125 | #endif 126 | 127 | 128 | pre :: T -> Bool 129 | pre t = all ((< 256) . sum) (toList t) 130 | 131 | post :: T -> Bool 132 | post t = (sum . concat) (toList t) < 5 * 256 133 | 134 | prop :: T -> Property 135 | prop t = pre t ==> post t 136 | 137 | -- Smallcheck -------------------------- 138 | #ifdef small 139 | prop_small :: T -> Bool 140 | prop_small t = pre t S.==> post t 141 | #endif 142 | -- Smallcheck -------------------------- 143 | 144 | -------------------------------------------------------------------------------- 145 | -- Testing 146 | -------------------------------------------------------------------------------- 147 | 148 | size :: T -> Int 149 | size t = sum $ map length (toList t) 150 | 151 | #if defined(qcjh) || defined(qcNone) || defined(qc10) || defined(qc20) || defined(feat) || defined(qcGen) || defined(smart) || defined(small) 152 | main :: IO () 153 | main = do 154 | [file', rnds'] <- getArgs 155 | let rnds = read rnds' :: Int 156 | let file = read file' :: String 157 | #ifdef feat 158 | test file rnds $ runQC' proxy stdArgs {maxSuccess = 10000} prop size 159 | #endif 160 | #ifdef smart 161 | test file rnds $ runSC scStdArgs prop size 162 | #endif 163 | #if defined(qcNone) || defined(qc10) || defined(qc20) || defined(qcjh) || defined(qcNaive) || defined(qcGen) 164 | test file rnds $ runQC' proxy stdArgs prop size 165 | #endif 166 | #endif 167 | 168 | #ifdef smart 169 | -- Tester (not part of the benchmark). 170 | smtChk :: IO () 171 | smtChk = smartCheck scStdArgs { scMaxForall = 20 172 | , runForall = True 173 | , scMinForall = 25 174 | , format = PrintString 175 | } prop 176 | #endif 177 | 178 | -------------------------------------------------------------------------------- /regression/PaperExample1/script.gnp: -------------------------------------------------------------------------------- 1 | set title "" 2 | # black and white output 3 | set term pdfcairo mono dashed linewidth 4 4 | # set term wxt 5 | set autoscale 6 | set xlabel "Final value size" 7 | set ylabel "Runs with resulting size" 8 | # set xrange [0:100] 9 | # set yrange [0:500] 10 | 11 | set nologscale y 12 | 13 | ###### Data 14 | 15 | set output "out/data.pdf" 16 | plot \ 17 | 'out/smart_vals.csv' using 1:2:(1.0) smooth bezier title 'SmartCheck', \ 18 | 'out/qcNone_vals.csv' using 1:2:(1.0) smooth bezier title 'none', \ 19 | 'out/qcGen_vals.csv' using 1:2:(1.0) smooth bezier title 'QC generic', \ 20 | 'out/qc10_vals.csv' using 1:2:(1.0) smooth bezier title 'QC trunc', \ 21 | 'out/qcjh_vals.csv' using 1:2:(1.0) smooth bezier title 'QC tuple' 22 | 23 | # 'feat_vals.csv' using 1:2:(1.0) smooth bezier title 'Feat', \ 24 | 25 | ###### Time 26 | set xlabel "Execution time (seconds)" 27 | # set logscale x 28 | # set yrange [1:500] 29 | # set xrange [0:35] 30 | 31 | set output "out/time-big.pdf" 32 | # big! 33 | plot \ 34 | 'out/qc10_time.csv' using 1:2:(1.0) smooth bezier title 'QC trunc', \ 35 | 'out/qcjh_time.csv' using 1:2:(1.0) smooth bezier title 'QC tuple' 36 | 37 | # 'feat_time.csv' using 1:2:(1.0) smooth bezier title 'Feat', \ 38 | 39 | # set nologscale x 40 | 41 | # set yrange [0:60] 42 | set output "out/time-small.pdf" 43 | # very small 44 | plot \ 45 | 'out/smart_time.csv' using 1:2:(1.0) smooth bezier title 'SmartCheck', \ 46 | 'out/qcNone_time.csv' using 1:2:(1.0) smooth bezier title 'QC none' 47 | 48 | -------------------------------------------------------------------------------- /regression/Parser/Makefile: -------------------------------------------------------------------------------- 1 | SRC = Parser 2 | 3 | # We never run small.out since it's not feasible. 4 | TARGETS = qcGen.out smart.out 5 | 6 | all : $(TARGETS) 7 | 8 | include ../Config.mk 9 | -------------------------------------------------------------------------------- /regression/Parser/Parser.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE TemplateHaskell #-} 3 | {-# LANGUAGE DeriveDataTypeable #-} 4 | {-# LANGUAGE DeriveGeneric #-} 5 | 6 | -- | Toy "parser"/"serializer" (with a bug) in And parsing. 7 | 8 | module Main where 9 | 10 | import Prelude hiding (showList, mod) 11 | 12 | #if defined(qc) || defined(qcGen) || defined(smart) 13 | import Test 14 | import System.Environment 15 | #endif 16 | 17 | import Test.QuickCheck 18 | import Test.SmartCheck 19 | import Data.List 20 | 21 | import GHC.Generics 22 | import Data.Typeable 23 | import Control.Applicative 24 | 25 | import Control.Monad.State 26 | import Data.Char 27 | 28 | #ifdef feat 29 | import Test.Feat 30 | #endif 31 | 32 | ----------------------------------------------------------------- 33 | 34 | -- Let's make up a toy language. 35 | 36 | data Lang = Lang 37 | { modules :: [Mod] 38 | , funcs :: [Func] 39 | } deriving (Show, Read, Typeable, Generic, Eq) 40 | 41 | instance SubTypes Lang 42 | 43 | newtype Var = Var String 44 | deriving (Show, Read, Typeable, Generic, Eq) 45 | 46 | instance SubTypes Var 47 | where baseType _ = True 48 | 49 | data Mod = Mod 50 | { imports :: [Var] 51 | , exports :: [Var] 52 | } deriving (Show, Read, Typeable, Generic, Eq) 53 | 54 | instance SubTypes Mod 55 | 56 | data Func = Func 57 | { fnName :: Var 58 | , args :: [Exp] 59 | , stmts :: [Stmt] 60 | } deriving (Show, Read, Typeable, Generic, Eq) 61 | 62 | instance SubTypes Func 63 | 64 | data Stmt = Assign Var Exp 65 | | Alloc Var Exp 66 | | Return Exp 67 | -- | Ref Exp 68 | -- | Deref Exp 69 | -- | Assert Exp 70 | -- | Loop Exp [Stmt] 71 | -- | IfTE Exp [Stmt] [Stmt] 72 | deriving (Show, Read, Typeable, Generic, Eq) 73 | 74 | instance SubTypes Stmt 75 | 76 | data Exp = Int Int 77 | | Bool Bool 78 | | Add Exp Exp 79 | | Sub Exp Exp 80 | | Mul Exp Exp 81 | | Div Exp Exp 82 | | Not Exp 83 | | And Exp Exp 84 | | Or Exp Exp 85 | deriving (Show, Read, Typeable, Generic, Eq) 86 | 87 | instance SubTypes Exp 88 | 89 | -- Feat -------------------------------- 90 | #ifdef feat 91 | deriveEnumerable ''Lang 92 | deriveEnumerable ''Var 93 | deriveEnumerable ''Mod 94 | deriveEnumerable ''Func 95 | deriveEnumerable ''Stmt 96 | deriveEnumerable ''Exp 97 | #endif 98 | -- Feat -------------------------------- 99 | 100 | -------------------------------------------------------------------------------- 101 | 102 | nonEmpty :: Gen [a] -> Gen [a] 103 | nonEmpty a = suchThat a (not . null) 104 | 105 | instance Arbitrary Var where 106 | arbitrary = Var <$> suchThat arbitrary 107 | (\s -> all isAlphaNum s && not (null s)) 108 | 109 | instance Arbitrary Lang where 110 | arbitrary = Lang <$> nonEmpty arbitrary <*> nonEmpty arbitrary 111 | #ifdef qc 112 | shrink (Lang m f) = map go (shrink (m, f)) 113 | where go (a,b) = Lang a b 114 | #endif 115 | #ifdef qcGen 116 | shrink = genericShrink 117 | #endif 118 | 119 | instance Arbitrary Mod where 120 | arbitrary = Mod <$> nonEmpty arbitrary <*> nonEmpty arbitrary 121 | #ifdef qc 122 | shrink (Mod a b) = map go (shrink (a, b)) 123 | where go (x,y) = Mod x y 124 | #endif 125 | #ifdef qcGen 126 | shrink = genericShrink 127 | #endif 128 | 129 | instance Arbitrary Func where 130 | arbitrary = Func <$> arbitrary <*> nonEmpty arbitrary <*> nonEmpty arbitrary 131 | #ifdef qc 132 | shrink (Func f a st) = map go (shrink (a, st)) 133 | where go (x, s) = Func f x s 134 | #endif 135 | #ifdef qcGen 136 | shrink = genericShrink 137 | #endif 138 | 139 | instance Arbitrary Stmt where 140 | arbitrary = do 141 | v <- arbitrary 142 | e <- arbitrary 143 | let a0 = Assign v e 144 | let a1 = Alloc v e 145 | let a2 = Return e 146 | elements [a0, a1, a2] 147 | #ifdef qc 148 | shrink stmt = case stmt of 149 | Assign v e -> map (Assign v) (shrink e) 150 | Alloc v e -> map (Alloc v) (shrink e) 151 | Return e -> map Return (shrink e) 152 | #endif 153 | #ifdef qcGen 154 | shrink = genericShrink 155 | #endif 156 | 157 | instance Arbitrary Exp where 158 | arbitrary = go 159 | where 160 | go = go' =<< choose (0::Int, 100) 161 | go' 0 = oneof [Bool <$> arbitrary, Int <$> arbitrary] 162 | go' i = let g = go' =<< choose (0::Int, i-1) in 163 | frequency [ (10, Not <$> g) 164 | , (100, And <$> g <*> g) 165 | , (100, Or <$> g <*> g) 166 | , (100, Add <$> g <*> g) 167 | , (100, Sub <$> g <*> g) 168 | , (100, Mul <$> g <*> g) 169 | , (100, Div <$> g <*> g) 170 | ] 171 | 172 | #ifdef qc 173 | shrink e = case e of 174 | Int i -> map Int (shrink i) 175 | Bool b -> map Bool (shrink b) 176 | Add e0 e1 -> map (uncurry Add) (zip (shrink e0) (shrink e1)) 177 | Sub e0 e1 -> map (uncurry Sub) (zip (shrink e0) (shrink e1)) 178 | Mul e0 e1 -> map (uncurry Mul) (zip (shrink e0) (shrink e1)) 179 | Div e0 e1 -> map (uncurry Div) (zip (shrink e0) (shrink e1)) 180 | Not e0 -> map Not (shrink e0) 181 | And e0 e1 -> map (uncurry And) (zip (shrink e0) (shrink e1)) 182 | Or e0 e1 -> map (uncurry Or) (zip (shrink e0) (shrink e1)) 183 | #endif 184 | #ifdef qcGen 185 | shrink = genericShrink 186 | #endif 187 | 188 | -------------------------------------------------------------------------------- 189 | -- "serializer" 190 | 191 | parens :: String -> String 192 | parens a = '(' : a ++ ")" 193 | 194 | showList :: Show' a => Char -> [a] -> String 195 | showList sep ls = parens $ concat $ intersperse [sep] $ map show' ls 196 | 197 | class Show a => Show' a where 198 | show' :: a -> String 199 | show' = show 200 | 201 | instance Show' Char 202 | instance Show' Int 203 | instance Show' Bool 204 | 205 | instance Show' Lang where 206 | show' (Lang m f) = unwords 207 | [ "Lang" 208 | , showList ';' m 209 | , showList ';' f 210 | ] 211 | 212 | instance Show' Mod where 213 | show' (Mod i e) = unwords 214 | [ "Mod" 215 | , showList ':' i 216 | , showList ':' e 217 | ] 218 | 219 | instance Show' Func where 220 | show' (Func f a s) = unwords 221 | [ "Func" 222 | , show' f 223 | , showList ',' a 224 | , showList ',' s 225 | ] 226 | 227 | instance Show' Var where 228 | show' (Var v) = v 229 | 230 | instance Show' Stmt where 231 | show' stmt = unwords $ case stmt of 232 | Assign v e -> ["Assign", show' v, parens $ show' e] 233 | Alloc v e -> ["Alloc" , show' v, parens $ show' e] 234 | Return e -> ["Return", parens $ show' e] 235 | 236 | instance Show' Exp where 237 | show' e = unwords $ case e of 238 | Int i -> ["Int" , show' i] 239 | Bool b -> ["Bool", show' b] 240 | Add e0 e1 -> ["Add" , parens $ show' e0, parens $ show' e1] 241 | Sub e0 e1 -> ["Sub" , parens $ show' e0, parens $ show' e1] 242 | Mul e0 e1 -> ["Mul" , parens $ show' e0, parens $ show' e1] 243 | Div e0 e1 -> ["Div" , parens $ show' e0, parens $ show' e1] 244 | Not e0 -> ["Not" , parens $ show' e0] 245 | And e0 e1 -> ["And" , parens $ show' e0, parens $ show' e1] 246 | Or e0 e1 -> ["Or" , parens $ show' e0, parens $ show' e1] 247 | 248 | -------------------------------------------------------------------------------- 249 | -- "parser" 250 | 251 | class Read a => Read' a where 252 | read' :: String -> a 253 | read' = read 254 | 255 | instance Read' Lang where 256 | read' str = run str $ do 257 | modify (strip "Lang") 258 | m <- state unparens 259 | let ms = map read' (fromSeps ';' m) 260 | f <- state unparens 261 | let fs = map read' (fromSeps ';' f) 262 | return (Lang ms fs) 263 | 264 | instance Read' Mod where 265 | read' mod = run mod $ do 266 | modify (strip "Mod") 267 | m <- state unparens 268 | let i = fromSeps ':' m 269 | es <- state unparens 270 | let e = fromSeps ':' es 271 | return (Mod (map Var i) (map Var e)) 272 | 273 | instance Read' Func where 274 | read' f = run f $ do 275 | modify (strip "Func") 276 | n <- state (procWord id) 277 | as <- state unparens 278 | let ars = map read' (fromSeps ',' as) 279 | ss <- state unparens 280 | let sts = map read' (fromSeps ',' ss) 281 | return (Func (Var n) ars sts) 282 | 283 | instance Read' Stmt where 284 | read' stmt | isPrefixOf "Assign" stmt = run stmt $ do 285 | modify (strip "Assign") 286 | v <- state (procWord id) 287 | e <- state (procParens read') 288 | return (Assign (Var v) e) 289 | | isPrefixOf "Alloc" stmt = run stmt $ do 290 | modify (strip "Alloc") 291 | v <- state (procWord id) 292 | e <- state (procParens read') 293 | return (Alloc (Var v) e) 294 | | isPrefixOf "Return" stmt = run stmt $ do 295 | modify (strip "Return") 296 | e <- state (procParens read') 297 | return (Return e) 298 | | otherwise = error $ "Couldn't match stmt " ++ stmt 299 | 300 | instance Read' Exp where 301 | read' e | isPrefixOf "Int" e = Int (read $ strip "Int" e) 302 | | isPrefixOf "Bool" e = Bool (read $ strip "Bool" e) 303 | | isPrefixOf "Add" e = run e $ do 304 | modify (strip "Add") 305 | e0 <- state (procParens read') 306 | e1 <- state (procParens read') 307 | return (Add e0 e1) 308 | 309 | | isPrefixOf "Sub" e = run e $ do 310 | modify (strip "Sub") 311 | e0 <- state (procParens read') 312 | e1 <- state (procParens read') 313 | return (Sub e0 e1) 314 | 315 | | isPrefixOf "Mul" e = run e $ do 316 | modify (strip "Mul") 317 | e0 <- state (procParens read') 318 | e1 <- state (procParens read') 319 | return (Mul e0 e1) 320 | 321 | | isPrefixOf "Div" e = run e $ do 322 | modify (strip "Div") 323 | e0 <- state (procParens read') 324 | e1 <- state (procParens read') 325 | return (Div e0 e1) 326 | 327 | | isPrefixOf "Not" e = run e $ do 328 | modify (strip "Not") 329 | e0 <- state (procParens read') 330 | return (Not e0) 331 | 332 | | isPrefixOf "And" e = run e $ do 333 | modify (strip "And") 334 | e0 <- state (procParens read') 335 | e1 <- state (procParens read') 336 | -- XXX Bug! 337 | return (And e1 e0) 338 | | isPrefixOf "Or" e = run e $ do 339 | modify (strip "Or") 340 | e0 <- state (procParens read') 341 | e1 <- state (procParens read') 342 | -- XXX Bug! 343 | return (And e1 e0) 344 | | otherwise = error $ "Couldn't match exp " ++ e 345 | 346 | -------------------------------------------------------------------------------- 347 | 348 | run :: s -> State s a -> a 349 | run e m = (flip evalState) e m 350 | 351 | -- strip a prefix and a space from a string. Return the remainder of the 352 | -- string. 353 | strip :: String -> String -> String 354 | strip pre str = case stripPrefix pre str of 355 | Nothing -> error $ "Couldn't strip " ++ pre ++ " from " ++ str 356 | Just rst -> if null rst then rst else tail rst 357 | 358 | -- Strip the next word. 359 | stripWord :: String -> (String, String) 360 | stripWord str = let strs = words str in 361 | (head strs, unwords (tail strs)) 362 | 363 | 364 | procWord :: (String -> a) -> String -> (a, String) 365 | procWord = runProc stripWord 366 | 367 | -- Return a prefix inside parens and the remainder of a string. 368 | unparens :: String -> (String, String) 369 | unparens ('(':str) = unparens' (1::Integer) [] str 370 | where 371 | unparens' n s ('(':r) = unparens' (n+1) ('(':s) r 372 | unparens' n s (')':r) | n == 1 = (reverse s, strip "" r) 373 | | otherwise = unparens' (n-1) (')':s) r 374 | unparens' _ _ [] = error $ "End of string reached in unparens" 375 | unparens' n s (c:r) = unparens' n (c:s) r 376 | unparens str = error $ "Unparsens couldn't parse " ++ str 377 | 378 | procParens :: (String -> a) -> String -> (a, String) 379 | procParens = runProc unparens 380 | 381 | -- Parse up to a sep 382 | fromSep :: Char -> String -> (String, String) 383 | fromSep sep str = let pre = takeWhile (/= sep) str in 384 | let post = drop (length pre + 1) str in 385 | (pre, post) 386 | 387 | fromSeps :: Char -> String -> [String] 388 | fromSeps _ [] = [] 389 | fromSeps sep str = let (a, b) = fromSep sep str in 390 | let as = fromSeps sep b in 391 | a:as 392 | 393 | runProc :: (String -> (String, String)) 394 | -> (String -> a) 395 | -> String 396 | -> (a, String) 397 | runProc t f s = let (a, b) = t s in (f a, b) 398 | 399 | -------------------------------------------------------------------------------- 400 | 401 | size :: Lang -> Int 402 | size (Lang m f) = sumit sizem m + sumit sizef f 403 | where 404 | sizem (Mod is es) = length is + length es 405 | sizef (Func _ as sts) = sumit sizee as + sumit sizes sts 406 | sizes stmt = case stmt of 407 | Assign _ e -> 1 + sizee e 408 | Alloc _ e -> 1 + sizee e 409 | Return e -> 1 + sizee e 410 | sizee e = case e of 411 | Int _ -> 1 412 | Bool _ -> 1 413 | Add e0 e1 -> 1 + sizee e0 + sizee e1 414 | Sub e0 e1 -> 1 + sizee e0 + sizee e1 415 | Mul e0 e1 -> 1 + sizee e0 + sizee e1 416 | Div e0 e1 -> 1 + sizee e0 + sizee e1 417 | Not e0 -> 1 + sizee e0 418 | And e0 e1 -> 1 + sizee e0 + sizee e1 419 | Or e0 e1 -> 1 + sizee e0 + sizee e1 420 | sumit sz ls = sum (map sz ls) 421 | 422 | -------------------------------------------------------------------------------- 423 | 424 | prop_parse :: Lang -> Bool 425 | prop_parse e = read' (show' e) == e 426 | 427 | scargs :: ScArgs 428 | scargs = scStdArgs { qcArgs = stdArgs 429 | -- { maxSuccess = 1000 430 | -- , maxSize = 20 } 431 | , format = PrintString 432 | , runForall = False 433 | , runExists = False 434 | -- , scMaxDepth = Just 4 435 | , scMaxSize = 5 436 | , scMaxReduce = 10 437 | } 438 | 439 | #if defined(qc) || defined(qcGen) || defined(smart) 440 | main :: IO () 441 | main = do 442 | [file', rnds'] <- getArgs 443 | let rnds = read rnds' :: Int 444 | let file = read file' :: String 445 | #ifdef feat 446 | test file rnds $ runQC' proxy stdArgs {maxSuccess = 1000} prop_parse size 447 | #endif 448 | #if defined(qc) || defined(qcGen) 449 | test file rnds $ runQC' proxy stdArgs prop_parse size 450 | #endif 451 | #ifdef smart 452 | test file rnds $ runSC scargs prop_parse size 453 | #endif 454 | #endif 455 | -------------------------------------------------------------------------------- 456 | 457 | {- 458 | testqc :: IO () 459 | testqc = quickCheckWith theArgs prop_parse 460 | 461 | parseTest :: IO () 462 | parseTest = smartCheck scargs prop_parse 463 | 464 | a0 = Func (Var "foo") [Int 3, Bool True] [Assign (Var "v") (Int 4), Return (Int 5)] 465 | a1 = Assign (Var "a") (Int 0) 466 | a2 = Alloc (Var "a") (Int 0) 467 | 468 | runit x = read' $ show' x 469 | -} 470 | -------------------------------------------------------------------------------- /regression/README.md: -------------------------------------------------------------------------------- 1 | This directory contains regression tests for SmartCheck vs. QuickCheck, Feat, 2 | etc. 3 | 4 | Each benchmark is in it's own directory. The Makefile builds the binaries and 5 | runs them, using submake. Sometimes, we make GNUPlot plots. 6 | 7 | Test.hs is a top-level driver for doing I/O for benchmarks. 8 | 9 | You can also load these files in GHCI (or cabal repl, launched from the 10 | top-level directory). 11 | -------------------------------------------------------------------------------- /regression/Test.hs: -------------------------------------------------------------------------------- 1 | -- I/O for regression testing. 2 | 3 | module Test where 4 | 5 | import Control.Monad 6 | import Data.Maybe 7 | import Data.Time 8 | import Data.List 9 | 10 | import Test.QuickCheck 11 | import Test.SmartCheck 12 | import Test.SmartCheck.Reduce 13 | 14 | -------------------------------------------------------------------------------- 15 | 16 | test :: FilePath -> Int -> IO Res -> IO () 17 | test f rnds run = do 18 | res <- replicateM rnds run 19 | let res' = catMaybes res 20 | let rnds' = length res' 21 | let app str = appendFile logFile (str ++ "\n") 22 | let avg vals = sum vals / fromIntegral rnds' 23 | let med vals = sort vals !! (rnds' `div` 2) 24 | let times = fst $ unzip res' 25 | let szs :: [Double] 26 | szs = map fromIntegral (snd $ unzip res') 27 | let stdDev vals = sqrt (avg distances) 28 | where 29 | distances = map (\x -> (x - m)^(2::Integer)) vals 30 | m = avg vals 31 | let percentile n vals = sort vals !! ((rnds' `div` 100) * n) 32 | -- http://en.wikipedia.org/wiki/Median_absolute_deviation 33 | let medAbsDev vals = med (map dist vals) 34 | where dist v = abs (v - median) 35 | median = med vals 36 | 37 | app "***************" 38 | print res 39 | app $ "Num : " ++ show rnds' 40 | app $ "std dev : " ++ show (stdDev $ map (fromRational . toRational) times :: Double) 41 | ++ ", " ++ show (stdDev szs) 42 | app $ "Avg : " ++ show (avg times) ++ ", " ++ show (avg szs) 43 | app $ "Med : " ++ show (med times) ++ ", " ++ show (med szs) 44 | app $ "75% : " ++ show (percentile 75 times) ++ ", " ++ show (percentile 75 szs) 45 | app $ "95% : " ++ show (percentile 95 times) ++ ", " ++ show (percentile 95 szs) 46 | app $ "99% : " ++ show (percentile 99 times) ++ ", " ++ show (percentile 99 szs) 47 | app $ "MAD : " ++ show (medAbsDev times) ++ ", " ++ show (medAbsDev szs) 48 | app "" 49 | app "" 50 | 51 | -- Time and size of value. 52 | appendFile (f ++ "_time.csv") (mkCSV $ plot 200 times) 53 | appendFile (f ++ "_vals.csv") (mkCSV $ plot 50 szs) 54 | 55 | type Res = Maybe (Double, Int) 56 | 57 | -- test' :: IO (Maybe a) -> (a -> Int) -> IO Res 58 | -- test' run size = do 59 | -- start <- getCurrentTime 60 | -- res <- run 61 | -- stop <- getCurrentTime 62 | -- let diff = diffUTCTime stop start 63 | -- case res of 64 | -- Nothing -> return Nothing 65 | -- Just r -> return $ Just (fromRational $ toRational diff, size r) 66 | 67 | -- For gnuplot --------------------------------------- 68 | mkCSV :: Show a => [(a,a)] -> String 69 | mkCSV [] = "\n" 70 | mkCSV ((x,y):rst) = show x ++ ", " ++ show y ++ "\n" ++ mkCSV rst 71 | 72 | -- Make 100 compartments to put data in. 73 | plot :: Double -> [Double] -> [(Double,Double)] 74 | plot comparts vals = filter (\(_,n) -> n /= 0.0) $ cz vs (min' + compartSz, 0) 75 | where 76 | vs = sort vals 77 | (min',max') = (head vs, last vs) 78 | compartSz = (max' - min') / comparts 79 | 80 | -- Count how many values are in each compartment. (1st element is top of 81 | -- compartment, 2nd is how many seen.) 82 | cz :: [Double] -> (Double,Double) -> [(Double,Double)] 83 | cz [] _ = [] 84 | cz (v:vs') (c,n) | v <= c = cz vs' (c,n+1) 85 | | otherwise = (c,n) : cz (v:vs') (c + compartSz, 0) 86 | 87 | logFile :: String 88 | logFile = "regression.log" 89 | 90 | data Proxy a = Proxy 91 | 92 | proxy :: Proxy a 93 | proxy = Proxy 94 | 95 | runQC' :: (Testable prop, Read a) 96 | => Proxy a -> Args -> prop -> (a -> Int) -> IO Res 97 | runQC' _ args prop size = do 98 | start <- getCurrentTime 99 | res <- quickCheckWithResult args prop 100 | stop <- getCurrentTime 101 | let cex = fmap (read . (!!1)) (getOut res) 102 | let diff = diffUTCTime stop start 103 | return $ fmap (\r -> (fromRational $ toRational diff, size r)) cex 104 | 105 | getOut :: Result -> Maybe [String] 106 | getOut res = case res of 107 | Failure{} -> Just $ lines (output res) 108 | _ -> Nothing 109 | 110 | -- Little driver since we're not using the SC REPL during testing. 111 | runSC :: (Arbitrary b, Show b, Testable a, SubTypes b) 112 | => ScArgs -> (b -> a) -> (b -> Int) -> IO Res 113 | runSC args prop size = do 114 | start <- getCurrentTime 115 | (mres, prop') <- runQC (qcArgs args) prop 116 | res <- case mres of 117 | Nothing -> return Nothing 118 | Just r -> liftM Just $ smartRun args r prop' 119 | stop <- getCurrentTime 120 | let diff = diffUTCTime stop start 121 | return $ case res of 122 | Nothing -> Nothing 123 | Just r -> Just (fromRational $ toRational diff, size r) 124 | 125 | -------------------------------------------------------------------------------- 126 | -------------------------------------------------------------------------------- /regression/gnuplot-notes.txt: -------------------------------------------------------------------------------- 1 | http://www.cs.grinnell.edu/~weinman/courses/CSC213/2008F/labs/10-pingpong-regression.pdf 2 | 3 | http://www.phas.ubc.ca/~phys209/files/gnuplot_tutorial2.pdf 4 | 5 | best fit curves: 6 | http://www.manpagez.com/info/gnuplot/gnuplot-4.4.3/gnuplot_195.php 7 | 8 | -- Get a smoothing curve 9 | plot 'sc_vals.csv' using 1:2:(1.0) smooth acsplines 10 | 11 | -- Plot data and curves 12 | plot 'sc_vals.csv', 'sc_vals.csv' using 1:2:(1.0) smooth acsplines 13 | 14 | How can you output the plot to a postscript file? 15 | ----------------------------------------------- 16 | gnuplot> set term pdf landscape 17 | gnuplot> set output "filename.ps" 18 | gnuplot> plot x**2 title "x^2" 19 | 20 | 21 | load a script from a file 22 | ------------------------- 23 | load 'script.gnp' 24 | 25 | plot 'sc_vals.csv', 'sc_vals.csv' using 1:2:(1.0) smooth acsplines, 'qcNone_vals.csv', 'qcNone_vals.csv' using 1:2:(1.0) smooth acsplines 26 | 27 | -------------------------------------------------------------------------------- /smartcheck.cabal: -------------------------------------------------------------------------------- 1 | Name: smartcheck 2 | Version: 0.2.4 3 | Synopsis: A smarter QuickCheck. 4 | Homepage: https://github.com/leepike/SmartCheck 5 | Description: See the README.md: fast, small shrinking and generalization of failing test-cases from QuickCheck. 6 | License: BSD3 7 | License-file: LICENSE.md 8 | Author: Lee Pike 9 | Maintainer: leepike@gmail.com 10 | Copyright: copyright, Lee Pike 2012. 11 | Category: Testing 12 | Build-type: Simple 13 | Extra-source-files: 14 | 15 | Cabal-version: >=1.10 16 | 17 | source-repository head 18 | type: git 19 | location: https://github.com/leepike/SmartCheck.git 20 | 21 | flag regression-flag 22 | default: False 23 | description: add libraries for regression testing 24 | 25 | Library 26 | Exposed-modules: Test.SmartCheck, 27 | Test.SmartCheck.Args, 28 | Test.SmartCheck.ConstructorGen, 29 | Test.SmartCheck.DataToTree, 30 | Test.SmartCheck.Extrapolate, 31 | Test.SmartCheck.Matches, 32 | Test.SmartCheck.Reduce, 33 | Test.SmartCheck.Render, 34 | Test.SmartCheck.SmartGen, 35 | Test.SmartCheck.Test, 36 | Test.SmartCheck.Types 37 | 38 | if flag(regression-flag) 39 | Build-depends: base >= 4.0 && < 5, 40 | QuickCheck == 2.8.2, 41 | mtl, 42 | random >= 1.0.1.1, 43 | containers >= 0.4, 44 | generic-deriving >= 1.2.1, 45 | ghc-prim, 46 | lazysmallcheck 47 | else 48 | Build-depends: base >= 4.0 && < 5, 49 | QuickCheck == 2.8.2, 50 | mtl, 51 | random >= 1.0.1.1, 52 | containers >= 0.4, 53 | generic-deriving >= 1.2.1, 54 | ghc-prim 55 | 56 | default-language: Haskell2010 57 | 58 | hs-source-dirs: src 59 | 60 | ghc-options: 61 | -Wall 62 | -fwarn-tabs 63 | -fno-warn-orphans 64 | 65 | -- QuickCheck some basic properties about SmartCheck. 66 | executable sc-qc 67 | Hs-source-dirs: qc-tests 68 | Main-is: Tests.hs 69 | Build-depends: base >= 4.0 && < 5, 70 | smartcheck, 71 | QuickCheck == 2.8.2, 72 | mtl, 73 | random >= 1.0.1.1, 74 | containers >= 0.4, 75 | generic-deriving >= 1.2.1, 76 | ghc-prim 77 | Default-language: Haskell2010 78 | Ghc-options: -Wall 79 | -------------------------------------------------------------------------------- /src/Test/SmartCheck.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | 5 | -- | Interface module. 6 | 7 | module Test.SmartCheck 8 | ( 9 | -- ** Main SmartCheck interface. 10 | smartCheck 11 | 12 | -- ** User-suppplied counterexample interface. 13 | , smartCheckInput 14 | 15 | -- ** Run QuickCheck and get a result. 16 | , runQC 17 | 18 | -- ** Arguments 19 | , module Test.SmartCheck.Args 20 | 21 | -- ** Main type class based on Generics. 22 | , SubTypes(..) 23 | 24 | -- ** For constructing new instances of `SubTypes` 25 | , gst 26 | , grc 27 | , gtc 28 | , gsf 29 | -- , gsz 30 | ) where 31 | 32 | import Test.SmartCheck.Args 33 | import Test.SmartCheck.ConstructorGen 34 | import Test.SmartCheck.Extrapolate 35 | import Test.SmartCheck.Matches 36 | import Test.SmartCheck.Reduce 37 | import Test.SmartCheck.Render 38 | import Test.SmartCheck.Test 39 | import Test.SmartCheck.Types 40 | 41 | import qualified Test.QuickCheck as Q 42 | 43 | import Generics.Deriving 44 | import Control.Monad (when) 45 | 46 | -------------------------------------------------------------------------------- 47 | 48 | -- | Main interface function. 49 | smartCheck :: 50 | ( SubTypes a 51 | , Generic a, ConNames (Rep a) 52 | , Q.Testable prop 53 | ) => ScArgs -> (a -> prop) -> IO () 54 | smartCheck args scProp = 55 | smartCheckRun args =<< runQC (qcArgs args) scProp 56 | 57 | smartCheckInput :: forall a prop. 58 | ( SubTypes a 59 | , Generic a, ConNames (Rep a) 60 | , Q.Testable prop 61 | , Read a 62 | ) => ScArgs -> (a -> prop) -> IO () 63 | smartCheckInput args scProp = do 64 | smartPrtLn "Input value to SmartCheck:" 65 | mcex <- fmap Just (readLn :: IO a) 66 | smartCheckRun args (mcex, Q.property . scProp) 67 | 68 | smartCheckRun :: forall a. 69 | ( SubTypes a 70 | , Generic a, ConNames (Rep a) 71 | ) => ScArgs -> (Maybe a, a -> Q.Property) -> IO () 72 | smartCheckRun args (origMcex, origProp) = do 73 | putStrLn "" 74 | smartPrtLn $ "Analyzing the first argument of the property with SmartCheck..." 75 | smartPrtLn $ "(If any stage takes too long, modify SmartCheck's arguments.)" 76 | smartCheck' [] origMcex origProp 77 | where 78 | smartCheck' :: [(a, Replace Idx)] 79 | -> Maybe a 80 | -> (a -> Q.Property) 81 | -> IO () 82 | smartCheck' ds mcex prop = 83 | maybe (maybeDoneMsg >> return ()) go mcex 84 | where 85 | go cex = do 86 | -- Run the smart reduction algorithm. 87 | d <- smartRun args cex prop 88 | -- If we asked to extrapolate values, do so. 89 | valIdxs <- forallExtrap args d origProp 90 | -- If we asked to extrapolate constructors, do so, again with the 91 | -- original property. 92 | csIdxs <- existsExtrap args d valIdxs origProp 93 | 94 | let replIdxs = Replace valIdxs csIdxs 95 | -- If either kind of extrapolation pass yielded fruit, prettyprint it. 96 | showExtrapOutput args valIdxs csIdxs replIdxs d 97 | -- Try again? 98 | runAgainMsg 99 | 100 | s <- getLine 101 | if s == "" 102 | -- If so, then loop, with the new prop. 103 | then do let oldVals = (d,replIdxs):ds 104 | let matchesProp a = 105 | not (matchesShapes a oldVals) 106 | Q.==> prop a 107 | (mcex', _) <- runQC (qcArgs args) (Q.noShrinking . matchesProp) 108 | smartCheck' oldVals mcex' matchesProp 109 | else smartPrtLn "Done." 110 | 111 | maybeDoneMsg = smartPrtLn "No value to smart-shrink; done." 112 | 113 | -------------------------------------------------------------------------------- 114 | 115 | existsExtrap :: (Generic a, SubTypes a, ConNames (Rep a)) 116 | => ScArgs -> a -> [Idx] -> (a -> Q.Property) -> IO [Idx] 117 | existsExtrap args d valIdxs origProp = 118 | if runExists args 119 | then constrsGen args d origProp valIdxs 120 | else return [] 121 | 122 | -------------------------------------------------------------------------------- 123 | 124 | forallExtrap :: SubTypes a => ScArgs -> a -> (a -> Q.Property) -> IO [Idx] 125 | forallExtrap args d origProp = 126 | if runForall args 127 | then -- Extrapolate with the original property to see if we 128 | -- get a previously-visited value back. 129 | extrapolate args d origProp 130 | else return [] 131 | 132 | -------------------------------------------------------------------------------- 133 | 134 | showExtrapOutput :: SubTypes a1 135 | => ScArgs -> [a] -> [a] -> Replace Idx -> a1 -> IO () 136 | showExtrapOutput args valIdxs csIdxs replIdxs d = 137 | when (runForall args || runExists args) $ do 138 | if null (valIdxs ++ csIdxs) 139 | then smartPrtLn "Could not extrapolate a new value." 140 | else output 141 | where 142 | output = do 143 | putStrLn "" 144 | smartPrtLn "Extrapolated value:" 145 | renderWithVars (format args) d replIdxs 146 | 147 | -------------------------------------------------------------------------------- 148 | 149 | runAgainMsg :: IO () 150 | runAgainMsg = putStrLn $ 151 | "\nAttempt to find a new counterexample?\n" 152 | ++ " ('Enter' to continue;" 153 | ++ " any character then 'Enter' to quit.)" 154 | 155 | -------------------------------------------------------------------------------- 156 | 157 | -- | Run QuickCheck, to get a counterexamples for each argument, including the 158 | -- one we want to focus on for SmartCheck, which is the first argument. That 159 | -- argument is never shrunk by QuickCheck, but others may be shrunk by 160 | -- QuickCheck. Returns the value (if it exists) and a 'Property' (by applying 161 | -- the 'property' method to the 'Testable' value). In each iteration of 162 | -- 'runQC', non-SmartCheck arguments are not necessarily held constant 163 | runQC :: forall a prop . (Show a, Q.Arbitrary a, Q.Testable prop) 164 | => Q.Args -> (a -> prop) -> IO (Maybe a, a -> Q.Property) 165 | runQC args scProp = do 166 | smartPrtLn "Finding a counterexample with QuickCheck..." 167 | -- smartPrtLn " 168 | (mCex, res) <- scQuickCheckWithResult args scProp 169 | return $ if failureRes res 170 | then (mCex, Q.property . scProp) 171 | else (Nothing, Q.property . scProp) 172 | 173 | -- | Returns 'True' if a counterexample is returned and 'False' otherwise. 174 | failureRes :: Q.Result -> Bool 175 | failureRes res = 176 | case res of 177 | Q.Failure _ _ _ _ _ _ _ _ _ _ -> True 178 | _ -> False 179 | 180 | -------------------------------------------------------------------------------- 181 | 182 | -------------------------------------------------------------------------------- /src/Test/SmartCheck/Args.hs: -------------------------------------------------------------------------------- 1 | -- | SmartCheck arguments. 2 | 3 | module Test.SmartCheck.Args 4 | ( ScArgs(..) 5 | , scStdArgs 6 | , Format(..) 7 | ) where 8 | 9 | import qualified Test.QuickCheck as Q 10 | 11 | ------------------------------------------------------------------------------- 12 | 13 | data Format = PrintTree | PrintString 14 | deriving (Eq, Read, Show) 15 | 16 | data ScArgs = 17 | ScArgs { format :: Format -- ^ How to show extrapolated formula 18 | -------------- 19 | , qcArgs :: Q.Args -- ^ QuickCheck arguments 20 | -------------- 21 | , scMaxSize :: Int -- ^ Maximum size of data to generate, in 22 | -- terms of the size parameter of 23 | -- QuickCheck's Arbitrary instance for 24 | -- your data. 25 | -------------- 26 | , scMaxDepth :: Maybe Int -- ^ How many levels into the structure of 27 | -- the failed value should we descend 28 | -- when reducing or generalizing? 29 | -- Nothing means we go down to base 30 | -- types. 31 | -------------- 32 | -- Reduction 33 | , scMaxReduce :: Int -- ^ How hard (number of rounds) to look 34 | -- for failure in the reduction stage. 35 | -------------- 36 | -- Extrapolation 37 | , runForall :: Bool -- ^ Should we extrapolate? 38 | -------------- 39 | , scMaxForall :: Int -- ^ How hard (number of rounds) to look 40 | -- for failures during the extrapolation 41 | -- stage. 42 | -------------- 43 | , scMinForall :: Int -- ^ Minimum number of times a property's 44 | -- precondition must be passed to 45 | -- generalize it. 46 | -------------- 47 | -- Constructor generalization 48 | , runExists :: Bool -- ^ Should we try to generalize 49 | -- constructors? 50 | -------------- 51 | , scMaxExists :: Int -- ^ How hard (number of rounds) to look 52 | -- for failing values with each 53 | -- constructor. For "wide" sum types, this 54 | -- value should be increased. 55 | -------------- 56 | } deriving (Show, Read) 57 | 58 | -------------------------------------------------------------------------------- 59 | 60 | scStdArgs :: ScArgs 61 | scStdArgs = ScArgs { format = PrintTree 62 | , qcArgs = Q.stdArgs 63 | , scMaxSize = 10 64 | , scMaxDepth = Nothing 65 | --------------------- 66 | , scMaxReduce = 100 67 | --------------------- 68 | , runForall = True 69 | , scMaxForall = 20 70 | , scMinForall = 10 71 | --------------------- 72 | , runExists = True 73 | , scMaxExists = 20 74 | } 75 | 76 | -------------------------------------------------------------------------------- 77 | -------------------------------------------------------------------------------- /src/Test/SmartCheck/ConstructorGen.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | 3 | module Test.SmartCheck.ConstructorGen 4 | ( constrsGen 5 | ) where 6 | 7 | import Test.SmartCheck.Args 8 | import Test.SmartCheck.Types 9 | import Test.SmartCheck.DataToTree 10 | import Test.SmartCheck.SmartGen 11 | import Test.SmartCheck.Render 12 | 13 | import Prelude hiding (max) 14 | import Generics.Deriving 15 | import qualified Data.Set as S 16 | import Data.List 17 | import Control.Monad (liftM) 18 | 19 | import qualified Test.QuickCheck as Q 20 | 21 | -------------------------------------------------------------------------------- 22 | 23 | -- | Entry point to generalize constructors. We pass in a list of indexes from 24 | -- value generalizations so we don't try to generalize those constructors (or 25 | -- anything below). 26 | constrsGen :: (SubTypes a, Generic a, ConNames (Rep a)) 27 | => ScArgs -> a -> (a -> Q.Property) -> [Idx] -> IO [Idx] 28 | constrsGen args d prop vs = do 29 | putStrLn "" 30 | smartPrtLn "Extrapolating Constructors ..." 31 | (_, idxs) <- iter' forest (Idx 0 0) [] 32 | return idxs 33 | 34 | where 35 | forest = let forest' = mkSubstForest d True in 36 | -- This ensures we don't try to replace anything below the indexs 37 | -- from vs. It does NOT ensure we don't replace equal indexes. 38 | foldl' (\f idx -> forestReplaceChildren f idx False) forest' vs 39 | 40 | iter' = iter d test next prop (scMaxDepth args) 41 | 42 | -- Check if this has been generalized already during extrapolating values. 43 | test x idx = do res <- extrapolateConstrs args x idx prop 44 | return $ idx `notElem` vs && res 45 | 46 | -- Control-flow. 47 | next _ res forest' idx idxs = 48 | iter' (if res then forestReplaceChildren forest' idx False else forest') 49 | idx { column = column idx + 1 } idxs' 50 | 51 | where 52 | idxs' = if res then idx : idxs else idxs 53 | 54 | -------------------------------------------------------------------------------- 55 | 56 | -- | Return True if we can generalize; False otherwise. 57 | extrapolateConstrs :: (SubTypes a, Generic a, ConNames (Rep a)) 58 | => ScArgs -> a -> Idx -> (a -> Q.Property) -> IO Bool 59 | extrapolateConstrs args a idx prop = 60 | recConstrs $ S.singleton $ subConstr a idx $ scMaxDepth args 61 | where 62 | notProp = Q.expectFailure . prop 63 | allConstrs = S.fromList (conNames a) 64 | 65 | recConstrs :: S.Set String -> IO Bool 66 | recConstrs constrs = 67 | let newConstr x = subConstr x idx (scMaxDepth args) `S.insert` constrs in 68 | -- Check if every possible constructor is an element of constrs passed in. 69 | if allConstrs `S.isSubsetOf` constrs 70 | then return True 71 | else do v <- arbSubset args a idx notProp constrs 72 | case v of 73 | Result x -> recConstrs (newConstr x) 74 | FailedPreCond -> return False 75 | FailedProp -> return False 76 | BaseType -> return False 77 | 78 | -------------------------------------------------------------------------------- 79 | 80 | -- | For a value a (used just for typing), and a list of representations of 81 | -- constructors cs, arbSubset generages a new value b, if possible, such that b 82 | -- has the same type as a, and b's constructor is not found in cs. 83 | -- 84 | -- Assumes there is some new constructor to test with. 85 | arbSubset :: (SubTypes a, Generic a, ConNames (Rep a)) 86 | => ScArgs -> a -> Idx -> (a -> Q.Property) 87 | -> S.Set String -> IO (Result a) 88 | arbSubset args a idx prop constrs = 89 | liftM snd $ iterateArbIdx a (idx, scMaxDepth args) 90 | (scMaxExists args) (scMaxSize args) prop' 91 | where 92 | prop' b = newConstr b Q.==> prop b 93 | -- Make sure b's constructor is a new one. 94 | newConstr b = not $ subConstr b idx (scMaxDepth args) `S.member` constrs 95 | 96 | -------------------------------------------------------------------------------- 97 | 98 | -- | Get the constructor at an index in x. 99 | subConstr :: SubTypes a => a -> Idx -> Maybe Int -> String 100 | subConstr x idx max = 101 | case getAtIdx x idx max of 102 | Nothing -> errorMsg "constrs'" 103 | Just x' -> subTconstr x' 104 | 105 | where 106 | subTconstr (SubT v) = toConstr v 107 | 108 | -------------------------------------------------------------------------------- 109 | -------------------------------------------------------------------------------- /src/Test/SmartCheck/DataToTree.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables #-} 2 | 3 | module Test.SmartCheck.DataToTree 4 | ( forestReplaceChildren 5 | , getAtIdx 6 | , replaceAtIdx 7 | , getIdxForest 8 | , breadthLevels 9 | , mkSubstForest 10 | , depth 11 | , tooDeep 12 | ) where 13 | 14 | import Test.SmartCheck.Types 15 | 16 | import Data.Tree 17 | import Data.List 18 | import Data.Maybe 19 | import Data.Typeable 20 | 21 | -------------------------------------------------------------------------------- 22 | -- Operations on Trees and Forests. 23 | -------------------------------------------------------------------------------- 24 | 25 | -- | Return the list of values at each level in a Forest Not like levels in 26 | -- Data.Tree (but what I imagined it should have done!). 27 | breadthLevels :: Forest a -> [[a]] 28 | breadthLevels forest = 29 | takeWhile (not . null) go 30 | where 31 | go = map (getLevel forest) [0..] 32 | 33 | -------------------------------------------------------------------------------- 34 | 35 | -- | Return the elements at level i from a forest. 0-based indexing. 36 | getLevel :: Forest a -> Int -> [a] 37 | getLevel fs 0 = map rootLabel fs 38 | getLevel fs n = concatMap (\fs' -> getLevel (subForest fs') (n-1)) fs 39 | 40 | -------------------------------------------------------------------------------- 41 | 42 | -- | Get the depth of a Forest. 0-based (an empty Forest has depth 0). 43 | depth :: Forest a -> Int 44 | depth forest = if null ls then 0 else maximum ls 45 | where 46 | ls = map depth' forest 47 | depth' (Node _ []) = 1 48 | depth' (Node _ forest') = 1 + depth forest' 49 | 50 | -------------------------------------------------------------------------------- 51 | 52 | -- | How many members are at level i in the Tree? 53 | levelLength :: Int -> Tree a -> Int 54 | levelLength 0 t = length (subForest t) 55 | levelLength n t = sum $ map (levelLength (n-1)) (subForest t) 56 | 57 | -------------------------------------------------------------------------------- 58 | 59 | -- | Get the tree at idx in a forest. Nothing if the index is out-of-bounds. 60 | getIdxForest :: Forest a -> Idx -> Maybe (Tree a) 61 | getIdxForest forest (Idx (0 :: Int) n) = 62 | if length forest > n then Just (forest !! n) 63 | else Nothing 64 | getIdxForest forest idx = 65 | -- Should be a single Just x in the list, holding the value. 66 | listToMaybe . catMaybes . snd $ acc 67 | 68 | where 69 | acc = mapAccumL findTree (column idx) (map Just forest) 70 | 71 | l = level idx - 1 72 | -- Invariant: not at the right level yet. 73 | findTree :: Int -> Maybe (Tree a) -> (Int, Maybe (Tree a)) 74 | findTree n Nothing = (n, Nothing) 75 | findTree n (Just t) = 76 | let len = levelLength l t in 77 | if n < 0 -- Already found index 78 | then (n, Nothing) 79 | else if n < len -- Big enough to index, so we climb down this one. 80 | then let t' = getIdxForest (subForest t) (Idx l n) in 81 | (n-len, t') 82 | else (n-len, Nothing) 83 | 84 | -------------------------------------------------------------------------------- 85 | 86 | -- Morally, we should be using generic zippers and a nice, recursive breadth-first search function, e.g. 87 | 88 | {- 89 | 90 | data Tree = N Int Tree Tree 91 | | E 92 | 93 | index :: Int -> Tree -> Tree 94 | index = index' [] 95 | where 96 | index' :: [Tree] -> Int -> Tree -> Tree 97 | index' _ 0 t = t 98 | index' [] idx (N i t0 t1) = index' [t1] (idx-1) t0 99 | index' (k:ks) idx E = index' ks (idx-1) k 100 | index' (k:ks) idx (N i t0 t1) = index' (ks ++ [t0, t1]) (idx-1) k 101 | 102 | -} 103 | 104 | -- | Returns the value at index idx. Returns nothing if the index is out of 105 | -- bounds. 106 | getAtIdx :: SubTypes a 107 | => a -- ^ Value 108 | -> Idx -- ^ Index of hole 109 | -> Maybe Int -- ^ Maximum depth we want to extract 110 | -> Maybe SubT 111 | getAtIdx d Idx { level = l, column = c } maxDepth 112 | | tooDeep l maxDepth = Nothing 113 | | length lev > c = Just (lev !! c) 114 | | otherwise = Nothing 115 | where 116 | lev = getLevel (subTypes d) l 117 | 118 | -------------------------------------------------------------------------------- 119 | 120 | tooDeep :: Int -> Maybe Int -> Bool 121 | tooDeep l = maybe False (l >) 122 | 123 | -------------------------------------------------------------------------------- 124 | 125 | data SubStrat = Parent -- ^ Replace everything in the path from the root to 126 | -- here. Used as breadcrumbs to the value. Chop the 127 | -- subforest. 128 | | Children -- ^ Replace a value and all of its subchildren. 129 | deriving (Show, Read, Eq) 130 | 131 | -------------------------------------------------------------------------------- 132 | 133 | forestReplaceParent, forestReplaceChildren :: Forest a -> Idx -> a -> Forest a 134 | forestReplaceParent = sub Parent 135 | forestReplaceChildren = sub Children 136 | 137 | -------------------------------------------------------------------------------- 138 | 139 | sub :: SubStrat -> Forest a -> Idx -> a -> Forest a 140 | -- on right level, and we'll assume correct subtree. 141 | sub strat forest (Idx (0 :: Int) n) a = 142 | snd $ mapAccumL f 0 forest 143 | where 144 | f i node | i == n = ( i+1, news ) 145 | | otherwise = ( i+1, node ) 146 | 147 | where 148 | news = case strat of 149 | Parent -> Node a [] 150 | Children -> fmap (const a) (forest !! n) 151 | 152 | sub strat forest idx a = 153 | snd $ mapAccumL findTree (column idx) forest 154 | where 155 | l = level idx - 1 156 | -- Invariant: not at the right level yet. 157 | findTree n t 158 | -- Already found index 159 | | n < 0 = (n, t) 160 | -- Big enough to index, so we climb down this one. 161 | | n < len = (n-len, newTree) 162 | | otherwise = (n-len, t) 163 | where 164 | len = levelLength l t 165 | newTree = Node newRootLabel (sub strat (subForest t) (Idx l n) a) 166 | newRootLabel = case strat of 167 | Parent -> a 168 | Children -> rootLabel t 169 | 170 | -------------------------------------------------------------------------------- 171 | -- Operations on SubTypes. 172 | -------------------------------------------------------------------------------- 173 | 174 | -- | Make a substitution Forest (all proper children). Initially we don't 175 | -- replace anything. 176 | mkSubstForest :: SubTypes a => a -> b -> Forest b 177 | mkSubstForest a b = map tMap (subTypes a) 178 | where tMap = fmap (const b) 179 | 180 | -------------------------------------------------------------------------------- 181 | 182 | -- | Replace a value at index idx generically in a Tree/Forest generically. 183 | replaceAtIdx :: (SubTypes a, Typeable b) 184 | => a -- ^ Parent value 185 | -> Idx -- ^ Index of hole to replace 186 | -> b -- ^ Value to replace with 187 | -> Maybe a 188 | replaceAtIdx m idx = replaceChild m (forestReplaceParent subF idx Subst) 189 | where 190 | subF = mkSubstForest m Keep 191 | 192 | -------------------------------------------------------------------------------- 193 | -------------------------------------------------------------------------------- /src/Test/SmartCheck/Extrapolate.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables #-} 2 | 3 | module Test.SmartCheck.Extrapolate 4 | ( extrapolate 5 | ) where 6 | 7 | import Test.SmartCheck.Args 8 | import Test.SmartCheck.Types 9 | import Test.SmartCheck.DataToTree 10 | import Test.SmartCheck.SmartGen 11 | import Test.SmartCheck.Render 12 | 13 | import qualified Test.QuickCheck as Q 14 | 15 | -------------------------------------------------------------------------------- 16 | 17 | -- | Test d with arbitrary values replacing its children. For anything we get 18 | -- 100% failure for, we claim we can generalize it---any term in that hole 19 | -- fails. 20 | -- 21 | -- We extrapolate if there exists at least one test that satisfies the 22 | -- precondition, and for all tests that satisfy the precondition, they fail. 23 | 24 | -- We extrapolate w.r.t. the original property since extrapolation throws away 25 | -- any values that fail the precondition of the property (i.e., before the 26 | -- Q.==>). 27 | extrapolate :: SubTypes a 28 | => ScArgs -- ^ Arguments 29 | -> a -- ^ Current failed value 30 | -> (a -> Q.Property) -- ^ Original property 31 | -> IO ([Idx]) 32 | extrapolate args d origProp = do 33 | putStrLn "" 34 | smartPrtLn "Extrapolating values ..." 35 | (_, idxs) <- iter' forest (Idx 0 0) [] 36 | return idxs 37 | 38 | where 39 | forest = mkSubstForest d True 40 | iter' = iter d test next origProp (scMaxDepth args) 41 | 42 | -- In this call to iterateArb, we want to claim we can extrapolate iff at 43 | -- least one test passes a precondition, and for every test in which the 44 | -- precondition is passed, it fails. We test values of all possible sizes, up 45 | -- to Q.maxSize. 46 | test _ idx = iterateArbIdx d (idx, scMaxDepth args) (scMaxForall args) 47 | (scMaxSize args) origProp 48 | 49 | -- Control-flow. 50 | 51 | -- None of the tries satisfy prop (but something passed the precondition). 52 | -- Prevent recurring down this tree, since we can generalize. 53 | next _ (i, FailedProp) forest' idx idxs 54 | | scMinForall args < i = 55 | nextIter (forestReplaceChildren forest' idx False) idx (idx : idxs) 56 | next _ _ forest' idx idxs = nextIter forest' idx idxs 57 | 58 | nextIter f idx = iter' f idx { column = column idx + 1 } 59 | 60 | -------------------------------------------------------------------------------- 61 | -------------------------------------------------------------------------------- /src/Test/SmartCheck/LICENSE: -------------------------------------------------------------------------------- 1 | *** 2 | Note: this license/copyright covers all software files in this directory and 3 | subdirectories, unless those files explicitly contain a different license or 4 | copyright header, in which case that header applies to the subsequent file. 5 | *** 6 | 7 | (BSD3 license) 8 | 9 | Copyright (c) 2014, Lee Pike 10 | All rights reserved. 11 | 12 | Redistribution and use in source and binary forms, with or without modification, 13 | are permitted provided that the following conditions are met: 14 | 15 | 1. Redistributions of source code must retain the above copyright notice, this 16 | list of conditions and the following disclaimer. 17 | 18 | 2. Redistributions in binary form must reproduce the above copyright notice, 19 | this list of conditions and the following disclaimer in the documentation and/or 20 | other materials provided with the distribution. 21 | 22 | 3. Neither the name of the copyright holder nor the names of its contributors 23 | may be used to endorse or promote products derived from this software without 24 | specific prior written permission. 25 | 26 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND 27 | ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 28 | WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 29 | DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR 30 | ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES 31 | (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; 32 | LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON 33 | ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 34 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 35 | SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 36 | -------------------------------------------------------------------------------- /src/Test/SmartCheck/Matches.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables #-} 2 | 3 | module Test.SmartCheck.Matches 4 | ( matchesShapes 5 | ) where 6 | 7 | import Test.SmartCheck.DataToTree 8 | import Test.SmartCheck.Types 9 | import Test.SmartCheck.SmartGen 10 | 11 | import Data.List 12 | import Data.Tree 13 | 14 | -------------------------------------------------------------------------------- 15 | 16 | -- | True if d matches any ds. Assume all ds are unequal to each other. 17 | matchesShapes :: SubTypes a => a -> [(a,Replace Idx)] -> Bool 18 | matchesShapes d = any (matchesShape d) 19 | 20 | -------------------------------------------------------------------------------- 21 | 22 | -- | At each index that we generalize (either value generalization or 23 | -- constructor generalization), we replace that value from b into a. At this 24 | -- point, we check for constructor equality between the two values, decending 25 | -- their structures. 26 | matchesShape :: forall a . SubTypes a => a -> (a, Replace Idx) -> Bool 27 | matchesShape a (b, Replace idxVals idxConstrs) 28 | | baseType a && baseType b = True 29 | | toConstr a /= toConstr b = False 30 | | Just a' <- aRepl = let x = subTypes a' in 31 | let y = subTypes b in 32 | all foldEqConstrs (zip x y) 33 | | otherwise = False 34 | 35 | where 36 | foldEqConstrs :: (Tree SubT, Tree SubT) -> Bool 37 | foldEqConstrs (Node (SubT l0) sts0, Node (SubT l1) sts1) 38 | | baseType l0 && baseType l1 = next 39 | | toConstr l0 == toConstr l1 = next 40 | | otherwise = False 41 | where next = all foldEqConstrs (zip sts0 sts1) 42 | 43 | bSub :: Idx -> Maybe SubT 44 | bSub idx = getAtIdx b idx Nothing 45 | 46 | updateA :: Idx -> a -> Maybe a 47 | updateA idx d = maybe Nothing (replace d idx) (bSub idx) 48 | 49 | aRepl :: Maybe a 50 | aRepl = foldl' go (Just a) (idxVals ++ idxConstrs) 51 | where go ma idx = maybe Nothing (updateA idx) ma 52 | 53 | -------------------------------------------------------------------------------- 54 | -------------------------------------------------------------------------------- /src/Test/SmartCheck/Reduce.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables #-} 2 | 3 | module Test.SmartCheck.Reduce 4 | (smartRun 5 | ) where 6 | 7 | import Test.SmartCheck.Args 8 | import Test.SmartCheck.Types 9 | import Test.SmartCheck.SmartGen 10 | import Test.SmartCheck.DataToTree 11 | import Test.SmartCheck.Render 12 | 13 | import qualified Test.QuickCheck as Q 14 | 15 | import Data.Typeable 16 | import Data.Tree 17 | import Data.Maybe 18 | 19 | import Control.Monad (liftM) 20 | 21 | -------------------------------------------------------------------------------- 22 | 23 | -- Smarter than shrinks. Does substitution. m is a value that failed QC that's 24 | -- been shrunk. We substitute successive children with strictly smaller (and 25 | -- increasingly larger) randomly-generated values until we find a failure, and 26 | -- return that result. (We call smartShrink recursively.) 27 | smartRun :: SubTypes a => ScArgs -> a -> (a -> Q.Property) -> IO a 28 | smartRun args res prop = do 29 | putStrLn "" 30 | smartPrtLn "Smart Shrinking ..." 31 | new <- smartShrink args res prop 32 | smartPrtLn "Smart-shrunk value:" 33 | print new 34 | return new 35 | 36 | -------------------------------------------------------------------------------- 37 | 38 | -- | Breadth-first traversal of d, trying to shrink it with *strictly* smaller 39 | -- children. We replace d whenever a successful shrink is found and try again. 40 | smartShrink :: forall a. SubTypes a => ScArgs -> a -> (a -> Q.Property) -> IO a 41 | smartShrink args d prop = 42 | liftM fst $ iter' d (mkForest d) (Idx 0 0) 43 | where 44 | mkForest x = mkSubstForest x True 45 | notProp = Q.expectFailure . prop 46 | 47 | iter' x forest_ idx' = 48 | iter x test next notProp (scMaxDepth args) forest_ idx' 49 | (errorMsg "next-idxs") 50 | 51 | -------------------------------------- 52 | 53 | -- next tells the iter what to do after running a test. 54 | next :: a -> Maybe a -> Forest Bool -> Idx -> [Idx] -> IO (a, [Idx]) 55 | next x res forest idx _ = 56 | case res of 57 | -- Found an ex that fails prop. We'll now test the ex, and start trying 58 | -- to reduce from the top! 59 | Just y -> iter' y (mkForest y) (Idx 0 0) 60 | -- Either couldn't satisfy the precondition or nothing satisfied the 61 | -- property. Either way, we can't shrink it. 62 | Nothing -> iter' x forest idx { column = column idx + 1 } 63 | 64 | -------------------------------------- 65 | 66 | -- Our test function. First, we'll see if we can just return the hole at idx, 67 | -- assuming it's (1) well-typed and (2), fails the test. Otherwise, we'll 68 | -- test x by replacing values at idx against (Q.expectFailure . prop). Make 69 | -- sure that values generated are strictly smaller than the value at 70 | -- idx. 71 | test :: a -> Idx -> IO (Maybe a) 72 | test x idx = do 73 | let vm = getAtIdx x idx (scMaxDepth args) 74 | case vm of 75 | Nothing -> errorMsg "smartShrink0" 76 | Just v -> do 77 | hole <- testHole v 78 | if isJust hole then return hole 79 | else do (_, r) <- iterateArb x v idx (scMaxReduce args) 80 | -- Maximum size of values to generate; the minimum 81 | -- of the value at the current index and the 82 | -- maxSize parameter. 83 | (min (subValSize x idx) (scMaxSize args)) 84 | notProp 85 | return $ resultToMaybe r 86 | 87 | where 88 | testHole :: SubT -> IO (Maybe a) 89 | testHole SubT { unSubT = v } = 90 | maybe (return Nothing) extractAndTest (cast v :: Maybe a) 91 | where 92 | extractAndTest :: a -> IO (Maybe a) 93 | extractAndTest y = do 94 | res <- resultify notProp y 95 | return $ resultToMaybe res 96 | 97 | resultToMaybe :: Result a -> Maybe a 98 | resultToMaybe res = 99 | case res of 100 | BaseType -> Nothing 101 | FailedPreCond -> Nothing 102 | FailedProp -> Nothing 103 | Result n -> Just n 104 | 105 | -------------------------------------------------------------------------------- 106 | 107 | -- | Get the maximum depth of d's subforest at idx. Intuitively, it's the 108 | -- maximum number of constructors you have *below* the constructor at idx. So 109 | -- for a unary constructor C, the value [C, C, C] 110 | -- 111 | -- (:) C 112 | -- (:) C 113 | -- (:) C [] 114 | -- 115 | -- At (Idx 0 0) in v, we're at C, so subValSize v (Idx 0 0) == 0. 116 | -- At (Idx 0 1) in v, we're at (C : C : []), so subValSize v (Idx 0 1) == 2, since 117 | -- we have the constructors :, C (or :, []) in the longest path underneath. 118 | -- Base-types have subValSize 0. So subValSize [1,2,3] idx == 0 for any idx. 119 | -- Note that if we have subValSize d idx == 0, then it is impossible to construct a 120 | -- *structurally* smaller value at hole idx. 121 | subValSize :: SubTypes a => a -> Idx -> Int 122 | subValSize d idx = maybe 0 depth forestIdx 123 | where 124 | forestIdx :: Maybe [Tree Bool] 125 | forestIdx = fmap subForest $ getIdxForest (mkSubstForest d True) idx 126 | 127 | -------------------------------------------------------------------------------- 128 | -------------------------------------------------------------------------------- /src/Test/SmartCheck/Render.hs: -------------------------------------------------------------------------------- 1 | -- | Rendering arbitrary data, and filling in holes in the data with variables. 2 | 3 | module Test.SmartCheck.Render 4 | ( renderWithVars 5 | , smartPrtLn 6 | ) where 7 | 8 | import Test.SmartCheck.Types 9 | import Test.SmartCheck.Args hiding (format) 10 | import Test.SmartCheck.DataToTree 11 | 12 | import Data.Maybe 13 | import Data.Tree 14 | import Data.List 15 | import Data.Char 16 | import Control.Monad 17 | 18 | -------------------------------------------------------------------------------- 19 | 20 | smartPrefix :: String 21 | smartPrefix = "*** " 22 | 23 | smartPrtLn :: String -> IO () 24 | smartPrtLn = putStrLn . (smartPrefix ++) 25 | 26 | -------------------------------------------------------------------------------- 27 | 28 | -- only print if variable list is non-empty. 29 | renderWithVars :: SubTypes a => Format -> a -> Replace Idx -> IO () 30 | renderWithVars format d idxs = do 31 | prtVars "values" valsLen valVars 32 | prtVars "constructors" constrsLen constrVars 33 | constrArgs 34 | putStrLn "" 35 | putStrLn $ replaceWithVars format d idxs' (Replace valVars constrVars) 36 | putStrLn "" 37 | 38 | where 39 | idxs' = let cs = unConstrs idxs \\ unVals idxs in 40 | idxs { unConstrs = cs } 41 | 42 | constrArgs = 43 | unless (constrsLen == 0) $ putStrLn " there exist arguments x̅ s.t." 44 | 45 | prtVars kind len vs = 46 | when (len > 0) 47 | ( putStrLn $ "forall " ++ kind ++ " " 48 | ++ unwords (take len vs) ++ ":") 49 | 50 | vars str = map (\(x,i) -> x ++ show i) (zip (repeat str) [0::Integer ..]) 51 | valVars = vars "x" 52 | constrVars = vars "C" 53 | 54 | valsLen = length (unVals idxs') 55 | constrsLen = length (unConstrs idxs') 56 | 57 | -------------------------------------------------------------------------------- 58 | 59 | type VarRepl = Either String String 60 | 61 | -- | At each index into d from idxs, replace the whole with a fresh value. 62 | replaceWithVars :: SubTypes a 63 | => Format -> a -> Replace Idx -> Replace String -> String 64 | replaceWithVars format d idxs vars = 65 | case format of 66 | PrintTree -> drawTree strTree 67 | -- We have to be careful here. We can't just show d and then find the 68 | -- matching substrings to replace, since the same substring may show up in 69 | -- multiple places. Rather, we have to recursively descend down the tree of 70 | -- substrings, finding matches, til we hit our variable. 71 | PrintString -> stitchTree strTree 72 | 73 | where 74 | strTree :: Tree String 75 | strTree = remSubVars (foldl' f t zipRepl) 76 | 77 | where 78 | -- Now we'll remove everything after the initial Rights, which are below 79 | -- variables. 80 | remSubVars (Node (Left s ) sf) = Node s (map remSubVars sf) 81 | remSubVars (Node (Right s) _ ) = Node s [] 82 | 83 | f :: Tree VarRepl -> (String, Idx) -> Tree VarRepl 84 | f tree (var, idx) = Node (rootLabel tree) $ 85 | case getIdxForest sf idx of 86 | Nothing -> errorMsg "replaceWithVars1" 87 | Just (Node (Right _) _) -> sf -- Don't replace anything 88 | Just (Node (Left _) _) -> forestReplaceChildren sf idx (Right var) 89 | 90 | where 91 | sf = subForest tree 92 | 93 | -- A tree representation of the data turned into a tree of Strings showing the 94 | -- data. showForest is one of our generic methods. 95 | t :: Tree VarRepl 96 | t = let forest = showForest d in 97 | if null forest then errorMsg "replaceWithVars2" 98 | else fmap Left (head forest) -- Should be a singleton 99 | 100 | -- Note: we put value idxs before constrs, since they take precedence. 101 | zipRepl :: [(String, Idx)] 102 | zipRepl = zip (unVals vars) (unVals idxs) 103 | ++ zip (unConstrs vars) (unConstrs idxs) 104 | 105 | -------------------------------------------------------------------------------- 106 | 107 | -- | Make a string out a Tree of Strings. Put parentheses around complex 108 | -- subterms, where "complex" means we have two or more items (i.e., there's a 109 | -- space). 110 | stitchTree :: Tree String -> String 111 | stitchTree = stitch 112 | where 113 | stitch (Node str forest) = str ++ " " ++ unwords (map stitchTree' forest) 114 | 115 | stitchTree' (Node str []) = if isJust $ find isSpace str 116 | then '(' : str ++ ")" 117 | else str 118 | stitchTree' node = '(' : stitch node ++ ")" 119 | 120 | -------------------------------------------------------------------------------- 121 | -------------------------------------------------------------------------------- /src/Test/SmartCheck/SmartGen.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables #-} 2 | 3 | module Test.SmartCheck.SmartGen 4 | ( iterateArbIdx 5 | , iterateArb 6 | , resultify 7 | , replace 8 | , iter 9 | ) where 10 | 11 | import Test.SmartCheck.Types 12 | import Test.SmartCheck.DataToTree 13 | 14 | import qualified Test.QuickCheck.Gen as Q 15 | import qualified Test.QuickCheck.Random as Q 16 | import qualified Test.QuickCheck as Q hiding (Result) 17 | import qualified Test.QuickCheck.Property as P 18 | 19 | import Prelude hiding (max) 20 | import System.Random 21 | import Data.Tree hiding (levels) 22 | 23 | -------------------------------------------------------------------------------- 24 | 25 | -- | Driver for iterateArb. 26 | iterateArbIdx :: SubTypes a 27 | => a -> (Idx, Maybe Int) -> Int -> Int 28 | -> (a -> P.Property) -> IO (Int, Result a) 29 | iterateArbIdx d (idx, max) tries sz prop = 30 | case getAtIdx d idx max of 31 | Nothing -> errorMsg "iterateArb 0" 32 | Just ext -> case ext of 33 | -- Don't analyze base types. 34 | SubT e -> if baseType e then return (0, BaseType) 35 | else iterateArb d ext idx tries sz prop 36 | 37 | -- | Replace the hole in d indexed by idx with a bunch of random values, and 38 | -- test the new d against the property. Returns the first new d (the full d but 39 | -- with the hole replaced) that succeeds. "Succeeds" is determined by the call 40 | -- to resultify---if we're expecting failure, then we succeed by getting a value 41 | -- that passes the precondition but fails the property; otherwise we succeed by 42 | -- getting a value that passes the precondition and satisfies the property. If 43 | -- no value ever satisfies the precondition, then we return FailedPreCond. 44 | -- (Thus, there's an implied linear order on the Result type: FailedPreCond < 45 | -- FailedProp < Result a.) 46 | iterateArb :: forall a. SubTypes a 47 | => a -- ^ Counterexample. 48 | -> SubT -- ^ Sub-value in the counterexample. 49 | -> Idx -- ^ Index of sub-value. 50 | -> Int -- ^ Maximum number of iterations. 51 | -> Int -- ^ Maximum size of value to generate. 52 | -> (a -> P.Property) -- ^ Property. 53 | -> IO (Int, Result a) -- ^ Number of times precondition is passed and returned 54 | -- result. 55 | iterateArb d ext idx tries max prop = do 56 | g <- Q.newQCGen 57 | iterateArb' (0, FailedPreCond) g 0 0 58 | where 59 | newMax SubT { unSubT = v } = valDepth v 60 | 61 | -- Main loop. We break out if we ever satisfy the property. Otherwise, we 62 | -- return the latest value. 63 | iterateArb' :: (Int, Result a) -> Q.QCGen -> Int -> Int -> IO (Int, Result a) 64 | iterateArb' (i, res) g try currMax 65 | -- We've exhausted the number of iterations. 66 | | try >= tries = return (i, res) 67 | -- The generated random value is too big. Start again sampling again with 68 | -- size at 0. 69 | | newMax s >= max = iterateArb' (i, res) g0 (try + 1) 0 70 | | otherwise = 71 | case replace d idx s of 72 | Nothing -> errorMsg "iterateArb 1" 73 | Just d' -> do 74 | res' <- resultify prop d' 75 | case res' of 76 | FailedPreCond -> rec (i , FailedPreCond) 77 | FailedProp -> rec (i+1, FailedProp) 78 | Result x -> return (i+1, Result x) 79 | BaseType -> errorMsg "baseType from resultify" 80 | where 81 | (size, g0) = randomR (0, currMax) g 82 | sample SubT { unSubT = v } = newVal v 83 | s = sample ext g size 84 | rec res' = 85 | iterateArb' res' g0 (try + 1) 86 | -- XXX what ratio is right to increase size of values? This gives us 87 | -- exponentail growth, but remember we're randomly chosing within the 88 | -- range of [0, max], so many values are significantly smaller than the 89 | -- max. Plus we reset the size whenever we get a value that's too big. 90 | -- Note the need for (+ 1), since we seed with 0. 91 | ((currMax + 1) * 2) 92 | 93 | -------------------------------------------------------------------------------- 94 | 95 | -- | Make a new random value given a generator and a max size. Based on the 96 | -- value's type's arbitrary instance. 97 | newVal :: forall a. (SubTypes a, Q.Arbitrary a) 98 | => a -> Q.QCGen -> Int -> SubT 99 | newVal _ g size = 100 | let Q.MkGen m = Q.resize size (Q.arbitrary :: Q.Gen a) in 101 | subT (m g size) 102 | 103 | -------------------------------------------------------------------------------- 104 | 105 | -- | Put a value v into a another value d at a hole idx, if v is well-typed. 106 | -- Return Nothing if dynamic typing fails. 107 | replace :: SubTypes a => a -> Idx -> SubT -> Maybe a 108 | replace d idx SubT { unSubT = v } = replaceAtIdx d idx v 109 | 110 | -------------------------------------------------------------------------------- 111 | 112 | -- | Make a QuickCheck Result by applying a property function to a value and 113 | -- then get out the Result using our result type. 114 | resultify :: (a -> P.Property) -> a -> IO (Result a) 115 | resultify prop a = do 116 | P.MkRose r _ <- res fs 117 | return $ maybe FailedPreCond -- Failed precondition (discard) 118 | -- If failed because of an exception, just say we failed. 119 | (\b -> if notExceptionFail r then get b r else FailedProp) 120 | (P.ok r) -- result of test case (True ==> passed) 121 | where 122 | get b r 123 | | b && P.expect r = Result a -- expected to pass and we did 124 | | not b && not (P.expect r) = Result a -- expected failure and got it 125 | | otherwise = FailedProp -- We'll just discard it. 126 | 127 | P.MkProperty { P.unProperty = Q.MkGen { Q.unGen = f } } 128 | = prop a :: P.Property 129 | fs = P.unProp $ f err err :: P.Rose P.Result 130 | res = P.protectRose . P.reduceRose 131 | 132 | -- XXX A hack! Means we failed the property because it failed, not because of 133 | -- an exception (i.e., with partial function tests). 134 | notExceptionFail r = let e = P.reason r in 135 | e == "Falsifiable" || e == "" 136 | 137 | err = errorMsg "resultify: should not evaluate." 138 | 139 | -------------------------------------------------------------------------------- 140 | 141 | type Test a b = a -> Idx -> IO b 142 | type Next a b = a -> b -> Forest Bool -> Idx -> [Idx] -> IO (a, [Idx]) 143 | 144 | -- Do a breadth-first traversal of the data. First, we find the next valid 145 | -- index we can use. Then we apply our test function, passing the result to our 146 | -- next function. 147 | iter :: SubTypes a 148 | => a -- ^ Failed value 149 | -> Test a b -- ^ Test to use 150 | -> Next a b -- ^ What to do after the test 151 | -> (a -> Q.Property) -- ^ Property 152 | -> Maybe Int -- ^ Max depth to analyze 153 | -> Forest Bool -- ^ Only evaluate at True indexes. 154 | -> Idx -- ^ Starting index to extrapolate 155 | -> [Idx] -- ^ List of generalized indices 156 | -> IO (a, [Idx]) 157 | iter d test nxt prop maxLevel forest idx idxs 158 | | done = return (d, idxs) 159 | | nextLevel = iter' 160 | | atFalse = iter' -- Must be last check or !! index below may be out of 161 | -- bounds! 162 | | otherwise = do tries <- test d idx 163 | nxt d tries forest idx idxs 164 | where 165 | -- Location is w.r.t. the forest, not the original data value. 166 | l = level idx 167 | levels = breadthLevels forest 168 | done = length levels <= l || tooDeep l maxLevel 169 | nextLevel = length (levels !! l) <= column idx 170 | atFalse = not $ (levels !! l) !! column idx 171 | iter' = iter d test nxt prop maxLevel forest 172 | idx { level = l + 1, column = 0 } idxs 173 | 174 | -------------------------------------------------------------------------------- 175 | 176 | -- | Get the maximum depth of a value, where depth is measured in the maximum 177 | -- depth of the tree representation, not counting base types (defined in 178 | -- Types.hs). 179 | valDepth :: SubTypes a => a -> Int 180 | valDepth d = depth (mkSubstForest d True) 181 | 182 | -------------------------------------------------------------------------------- 183 | -------------------------------------------------------------------------------- /src/Test/SmartCheck/Test.hs: -------------------------------------------------------------------------------- 1 | {- 2 | 3 | The following is modified by Lee Pike (2014) and still retains the following 4 | license: 5 | 6 | Copyright (c) 2000-2012, Koen Claessen 7 | Copyright (c) 2006-2008, Björn Bringert 8 | Copyright (c) 2009-2012, Nick Smallbone 9 | All rights reserved. 10 | 11 | Redistribution and use in source and binary forms, with or without 12 | modification, are permitted provided that the following conditions are met: 13 | 14 | - Redistributions of source code must retain the above copyright notice, 15 | this list of conditions and the following disclaimer. 16 | - Redistributions in binary form must reproduce the above copyright 17 | notice, this list of conditions and the following disclaimer in the 18 | documentation and/or other materials provided with the distribution. 19 | - Neither the names of the copyright owners nor the names of the 20 | contributors may be used to endorse or promote products derived 21 | from this software without specific prior written permission. 22 | 23 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 24 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 25 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 26 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 27 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 28 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 29 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 30 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 31 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 32 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 33 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 34 | -} 35 | 36 | {-# LANGUAGE ScopedTypeVariables #-} 37 | {-# LANGUAGE NamedFieldPuns #-} 38 | {-# LANGUAGE ExistentialQuantification #-} 39 | 40 | -- | SmartCheck's interface to QuickCheck. 41 | 42 | module Test.SmartCheck.Test 43 | ( scQuickCheckWithResult 44 | , stdArgs 45 | ) where 46 | 47 | -------------------------------------------------------------------------- 48 | -- imports 49 | 50 | import Prelude hiding (break) 51 | 52 | import Test.QuickCheck 53 | import Test.QuickCheck.Gen 54 | import Test.QuickCheck.Property hiding ( Result( reason, theException), labels ) 55 | import qualified Test.QuickCheck.Property as P 56 | import Test.QuickCheck.Text 57 | import qualified Test.QuickCheck.State as S 58 | import Test.QuickCheck.Exception 59 | import Test.QuickCheck.Random 60 | import System.Random (split) 61 | 62 | import qualified Data.Map as M 63 | import qualified Data.Set as Set 64 | import Data.Char 65 | ( isSpace 66 | ) 67 | 68 | import Data.List 69 | ( sort 70 | , group 71 | , intersperse 72 | ) 73 | 74 | -------------------------------------------------------------------------- 75 | -- quickCheck 76 | 77 | -- | Our SmartCheck reimplementation of the main QuickCheck driver. We want to 78 | -- distinguish the first argument to a 'Testable' property to be SmartChecked. 79 | -- In particular: the first argument will not be shrunk (even if there are 80 | -- default shrink instances for the type). However, the argument will be grown 81 | -- according to the the 'maxSize' argument to QuickCheck, in accordance with its 82 | -- generator. Other arguments will be shrunk, if they have shrinking instances. 83 | scQuickCheckWithResult :: forall a prop. (Show a, Arbitrary a, Testable prop) 84 | => Args -> (a -> prop) -> IO (Maybe a, Result) 85 | scQuickCheckWithResult a p = (if chatty a then withStdioTerminal else withNullTerminal) $ \tm -> do 86 | rnd <- case replay a of 87 | Nothing -> newQCGen 88 | Just (rnd,_) -> return rnd 89 | test S.MkState{ S.terminal = tm 90 | , S.maxSuccessTests = maxSuccess a 91 | , S.maxDiscardedTests = maxDiscardRatio a * maxSuccess a 92 | , S.computeSize = case replay a of 93 | Nothing -> computeSize' 94 | Just (_,s) -> computeSize' `at0` s 95 | , S.numSuccessTests = 0 96 | , S.numDiscardedTests = 0 97 | , S.labels = M.empty 98 | , S.numRecentlyDiscardedTests = 0 99 | , S.collected = [] 100 | , S.expectedFailure = False 101 | , S.randomSeed = rnd 102 | , S.numSuccessShrinks = 0 103 | , S.numTryShrinks = 0 104 | , S.numTotTryShrinks = 0 105 | } flipProp 106 | where computeSize' n d 107 | -- e.g. with maxSuccess = 250, maxSize = 100, goes like this: 108 | -- 0, 1, 2, ..., 99, 0, 1, 2, ..., 99, 0, 2, 4, ..., 98. 109 | | n `roundTo` maxSize a + maxSize a <= maxSuccess a || 110 | n >= maxSuccess a || 111 | maxSuccess a `mod` maxSize a == 0 = (n `mod` maxSize a + d `div` 10) `min` maxSize a 112 | | otherwise = 113 | ((n `mod` maxSize a) * maxSize a `div` (maxSuccess a `mod` maxSize a) + d `div` 10) `min` maxSize a 114 | n `roundTo` m = (n `div` m) * m 115 | at0 _f s 0 0 = s 116 | at0 f _s n d = f n d 117 | 118 | flipProp :: QCGen -> Int -> (a -> Prop) 119 | flipProp q i = \a' -> 120 | let p' = p a' in 121 | let g = unGen (unProperty (property p')) in 122 | g q i 123 | 124 | -------------------------------------------------------------------------- 125 | -- main test loop 126 | 127 | test :: Arbitrary a => S.State -> (QCGen -> Int -> (a -> Prop)) -> IO (Maybe a, Result) 128 | test st f 129 | | S.numSuccessTests st >= S.maxSuccessTests st = doneTesting st f 130 | | S.numDiscardedTests st >= S.maxDiscardedTests st = giveUp st f 131 | | otherwise = runATest st f 132 | 133 | doneTesting :: S.State -> (QCGen -> Int -> (a -> Prop)) -> IO (Maybe a, Result) 134 | doneTesting st _f = 135 | do -- CALLBACK done_testing? 136 | if S.expectedFailure st then 137 | putPart (S.terminal st) 138 | ( "+++ OK, passed " 139 | ++ show (S.numSuccessTests st) 140 | ++ " tests" 141 | ) 142 | else 143 | putPart (S.terminal st) 144 | ( bold ("*** Failed!") 145 | ++ " Passed " 146 | ++ show (S.numSuccessTests st) 147 | ++ " tests (expected failure)" 148 | ) 149 | success st 150 | theOutput <- terminalOutput (S.terminal st) 151 | return $ (Nothing, if S.expectedFailure st then 152 | Success{ labels = summary st, 153 | numTests = S.numSuccessTests st, 154 | output = theOutput } 155 | else NoExpectedFailure{ labels = summary st, 156 | numTests = S.numSuccessTests st, 157 | output = theOutput }) 158 | 159 | giveUp :: S.State -> (QCGen -> Int -> (a -> Prop)) -> IO (Maybe a, Result) 160 | giveUp st _f = 161 | do -- CALLBACK gave_up? 162 | putPart (S.terminal st) 163 | ( bold ("*** Gave up!") 164 | ++ " Passed only " 165 | ++ show (S.numSuccessTests st) 166 | ++ " tests" 167 | ) 168 | success st 169 | theOutput <- terminalOutput (S.terminal st) 170 | return ( Nothing 171 | , GaveUp{ numTests = S.numSuccessTests st 172 | , labels = summary st 173 | , output = theOutput 174 | } 175 | ) 176 | 177 | runATest :: forall a. (Arbitrary a) 178 | => S.State 179 | -> (QCGen -> Int -> (a -> Prop)) 180 | -> IO (Maybe a, Result) 181 | runATest st f = 182 | do -- CALLBACK before_test 183 | putTemp (S.terminal st) 184 | ( "(" 185 | ++ number (S.numSuccessTests st) "test" 186 | ++ concat [ "; " ++ show (S.numDiscardedTests st) ++ " discarded" 187 | | S.numDiscardedTests st > 0 188 | ] 189 | ++ ")" 190 | ) 191 | let size = S.computeSize st (S.numSuccessTests st) (S.numRecentlyDiscardedTests st) 192 | 193 | let p :: a -> Prop 194 | p = f rnd1 size 195 | 196 | let genA :: QCGen -> Int -> a 197 | genA = unGen arbitrary 198 | let rndA = genA rnd1 size 199 | 200 | let mkRes res = return (Just rndA, res) 201 | 202 | MkRose res ts <- protectRose (reduceRose (unProp (p rndA))) 203 | callbackPostTest st res 204 | 205 | let continue break st' | abort res = break st' 206 | | otherwise = test st' 207 | 208 | case res of 209 | MkResult{ok = Just True, stamp, expect} -> -- successful test 210 | do continue doneTesting 211 | st{ S.numSuccessTests = S.numSuccessTests st + 1 212 | , S.numRecentlyDiscardedTests = 0 213 | , S.randomSeed = rnd2 214 | , S.collected = stamp : S.collected st 215 | , S.expectedFailure = expect 216 | } f 217 | 218 | MkResult{ok = Nothing, expect = expect} -> -- discarded test 219 | do continue giveUp 220 | st{ S.numDiscardedTests = S.numDiscardedTests st + 1 221 | , S.numRecentlyDiscardedTests = S.numRecentlyDiscardedTests st + 1 222 | , S.randomSeed = rnd2 223 | , S.expectedFailure = expect 224 | } f 225 | 226 | MkResult{ok = Just False} -> -- failed test 227 | do if expect res 228 | then putPart (S.terminal st) (bold "*** Failed! ") 229 | else putPart (S.terminal st) "+++ OK, failed as expected. " 230 | (numShrinks, totFailed, lastFailed) <- foundFailure st res ts 231 | theOutput <- terminalOutput (S.terminal st) 232 | if not (expect res) then 233 | mkRes Success{ labels = summary st, 234 | numTests = S.numSuccessTests st+1, 235 | output = theOutput 236 | } 237 | else 238 | mkRes Failure{ -- correct! (this will be split first) 239 | usedSeed = S.randomSeed st 240 | , usedSize = size 241 | , numTests = S.numSuccessTests st+1 242 | , numShrinks = numShrinks 243 | , numShrinkTries = totFailed 244 | , numShrinkFinal = lastFailed 245 | , output = theOutput 246 | , reason = P.reason res 247 | , theException = P.theException res 248 | , labels = summary st 249 | } 250 | where 251 | (rnd1,rnd2) = split (S.randomSeed st) 252 | 253 | summary :: S.State -> [(String,Int)] 254 | summary st = reverse 255 | . sort 256 | . map (\ss -> (head ss, (length ss * 100) `div` S.numSuccessTests st)) 257 | . group 258 | . sort 259 | $ [ concat (intersperse ", " (Set.toList s)) 260 | | s <- S.collected st 261 | , not (Set.null s) 262 | ] 263 | 264 | success :: S.State -> IO () 265 | success st = 266 | case allLabels ++ covers of 267 | [] -> do putLine (S.terminal st) "." 268 | [pt] -> do putLine (S.terminal st) 269 | ( " (" 270 | ++ dropWhile isSpace pt 271 | ++ ")." 272 | ) 273 | cases -> do putLine (S.terminal st) ":" 274 | sequence_ [ putLine (S.terminal st) pt | pt <- cases ] 275 | where 276 | allLabels = reverse 277 | . sort 278 | . map (\ss -> (showP ((length ss * 100) `div` S.numSuccessTests st) ++ head ss)) 279 | . group 280 | . sort 281 | $ [ concat (intersperse ", " s') 282 | | s <- S.collected st 283 | , let s' = [ t | t <- Set.toList s, M.lookup t (S.labels st) == Just 0 ] 284 | , not (null s') 285 | ] 286 | 287 | covers = [ ("only " ++ show (labelPercentage l st) ++ "% " ++ l ++ ", not " ++ show reqP ++ "%") 288 | | (l, reqP) <- M.toList (S.labels st) 289 | , labelPercentage l st < reqP 290 | ] 291 | 292 | -- (x,_) `first` (y,_) = x == y 293 | 294 | showP p = (if p < 10 then " " else "") ++ show p ++ "% " 295 | 296 | labelPercentage :: String -> S.State -> Int 297 | labelPercentage l st = 298 | -- XXX in case of a disjunction, a label can occur several times, 299 | -- need to think what to do there 300 | (100 * occur) `div` S.maxSuccessTests st 301 | where 302 | occur = length [ l' | l' <- concat (map Set.toList (S.collected st)), l == l' ] 303 | 304 | -------------------------------------------------------------------------- 305 | -- main shrinking loop 306 | 307 | foundFailure :: S.State -> P.Result -> [Rose P.Result] -> IO (Int, Int, Int) 308 | foundFailure st res ts = 309 | do localMin st{ S.numTryShrinks = 0 } res res ts 310 | 311 | localMin :: S.State -> P.Result -> P.Result -> [Rose P.Result] -> IO (Int, Int, Int) 312 | localMin st MkResult{P.theException = Just e} lastRes _ 313 | | isInterrupt e = localMinFound st lastRes 314 | localMin st res _ ts = do 315 | putTemp (S.terminal st) 316 | ( short 26 (oneLine (P.reason res)) 317 | ++ " (after " ++ number (S.numSuccessTests st+1) "test" 318 | ++ concat [ " and " 319 | ++ show (S.numSuccessShrinks st) 320 | ++ concat [ "." ++ show (S.numTryShrinks st) | S.numTryShrinks st > 0 ] 321 | ++ " shrink" 322 | ++ (if S.numSuccessShrinks st == 1 323 | && S.numTryShrinks st == 0 324 | then "" else "s") 325 | | S.numSuccessShrinks st > 0 || S.numTryShrinks st > 0 326 | ] 327 | ++ ")..." 328 | ) 329 | r <- tryEvaluate ts 330 | case r of 331 | Left err -> 332 | localMinFound st 333 | (exception "Exception while generating shrink-list" err) { callbacks = callbacks res } 334 | Right ts' -> localMin' st res ts' 335 | 336 | localMin' :: S.State -> P.Result -> [Rose P.Result] -> IO (Int, Int, Int) 337 | localMin' st res [] = localMinFound st res 338 | localMin' st res (t:ts) = 339 | do -- CALLBACK before_test 340 | MkRose res' ts' <- protectRose (reduceRose t) 341 | callbackPostTest st res' 342 | if ok res' == Just False 343 | then localMin st{ S.numSuccessShrinks = S.numSuccessShrinks st + 1, 344 | S.numTryShrinks = 0 } res' res ts' 345 | else localMin st{ S.numTryShrinks = S.numTryShrinks st + 1, 346 | S.numTotTryShrinks = S.numTotTryShrinks st + 1 } res res ts 347 | 348 | localMinFound :: S.State -> P.Result -> IO (Int, Int, Int) 349 | localMinFound st res = 350 | do let report = concat [ 351 | "(after " ++ number (S.numSuccessTests st+1) "test", 352 | concat [ " and " ++ number (S.numSuccessShrinks st) "shrink" 353 | | S.numSuccessShrinks st > 0 354 | ], 355 | "): " 356 | ] 357 | if isOneLine (P.reason res) 358 | then putLine (S.terminal st) (P.reason res ++ " " ++ report) 359 | else do 360 | putLine (S.terminal st) report 361 | sequence_ 362 | [ putLine (S.terminal st) msg 363 | | msg <- lines (P.reason res) 364 | ] 365 | putLine (S.terminal st) "*** Non SmartChecked arguments:" 366 | 367 | callbackPostFinalFailure st res 368 | return (S.numSuccessShrinks st, S.numTotTryShrinks st - S.numTryShrinks st, S.numTryShrinks st) 369 | 370 | -------------------------------------------------------------------------- 371 | -- callbacks 372 | 373 | callbackPostTest :: S.State -> P.Result -> IO () 374 | callbackPostTest st res = 375 | sequence_ [ safely st (f st res) | PostTest _ f <- callbacks res ] 376 | 377 | callbackPostFinalFailure :: S.State -> P.Result -> IO () 378 | callbackPostFinalFailure st res = 379 | sequence_ [ safely st (f st res) | PostFinalFailure _ f <- callbacks res ] 380 | 381 | safely :: S.State -> IO () -> IO () 382 | safely st x = do 383 | r <- tryEvaluateIO x 384 | case r of 385 | Left e -> 386 | putLine (S.terminal st) 387 | ("*** Exception in callback: " ++ show e) 388 | Right x' -> 389 | return x' 390 | 391 | -------------------------------------------------------------------------- 392 | -- the end. 393 | -------------------------------------------------------------------------------- /src/Test/SmartCheck/Types.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeOperators #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | {-# LANGUAGE ExistentialQuantification #-} 5 | {-# LANGUAGE DefaultSignatures #-} 6 | {-# LANGUAGE ScopedTypeVariables #-} 7 | {-# LANGUAGE OverlappingInstances #-} 8 | 9 | module Test.SmartCheck.Types 10 | ( SubT(..) 11 | , subT 12 | , Result(..) 13 | , SubTypes(..) 14 | , Idx(..) 15 | , Subst(..) 16 | , Replace(..) 17 | , errorMsg 18 | -- ** For constructing new instances of `SubTypes` 19 | , gst 20 | , grc 21 | , gtc 22 | , gsf 23 | -- , gsz 24 | ) where 25 | 26 | import GHC.Generics 27 | import Data.Tree 28 | import Data.Typeable 29 | import Control.Monad (ap) 30 | 31 | -- For instances 32 | import Data.Word 33 | import Data.Int 34 | import Data.Ratio 35 | import Data.Complex 36 | 37 | import qualified Test.QuickCheck as Q 38 | 39 | ------------------------------------------------------------------------------- 40 | 41 | -- | Nominally, a list for value generalization indexes and existential 42 | -- generalization. 43 | data Replace a = Replace { unVals :: [a], unConstrs :: [a] } 44 | deriving (Show, Read, Eq) 45 | 46 | -------------------------------------------------------------------------------- 47 | -- Result type 48 | -------------------------------------------------------------------------------- 49 | 50 | -- | Possible results of iterateArb. 51 | data Result a = 52 | BaseType -- ^ Base type. Won't analyze. 53 | | FailedPreCond -- ^ Couldn't satisfy the precondition of a QuickCheck 54 | -- property 55 | | FailedProp -- ^ Failed the property---either we expect failure and it 56 | -- passes or we expect to pass it and we fail. 57 | | Result a -- ^ Satisfied it, with the satisfying value. 58 | deriving (Show, Read, Eq) 59 | 60 | instance Functor Result where 61 | fmap _ BaseType = BaseType 62 | fmap _ FailedPreCond = FailedPreCond 63 | fmap _ FailedProp = FailedProp 64 | fmap f (Result a) = Result (f a) 65 | 66 | instance Monad Result where 67 | return a = Result a 68 | BaseType >>= _ = BaseType 69 | FailedPreCond >>= _ = FailedPreCond 70 | FailedProp >>= _ = FailedProp 71 | Result a >>= f = f a 72 | 73 | instance Applicative Result where 74 | pure = return 75 | (<*>) = ap 76 | 77 | ------------------------------------------------------------------------------- 78 | -- Indexing 79 | ------------------------------------------------------------------------------- 80 | 81 | -- | Index into a Tree/Forest, where level is the depth from the root and column 82 | -- is the distance d is the dth value on the same level. Thus, all left-most 83 | -- nodes are in column 0. This is a "matrix view" of tree-structured data. 84 | data Idx = Idx { level :: Int, column :: Int } 85 | deriving Eq 86 | 87 | instance Show Idx where 88 | show (Idx l c) = foldr1 (++) ["Idx ", show l, " ", show c] 89 | 90 | -- | Keep or substitue a value in the tree. 91 | data Subst = Keep | Subst 92 | deriving (Show, Eq, Read) 93 | 94 | -- | Sort in order of depth first then left to right. 95 | instance Ord Idx where 96 | compare (Idx l0 c0) (Idx l1 c1) | l0 < l1 = LT 97 | | l0 > l1 = GT 98 | | c0 < c1 = LT 99 | | c0 > c1 = GT 100 | | True = EQ 101 | 102 | ------------------------------------------------------------------------------- 103 | -- User-defined subtypes of data 104 | ------------------------------------------------------------------------------- 105 | 106 | data SubT = forall a. (Q.Arbitrary a, SubTypes a) 107 | => SubT { unSubT :: a } 108 | 109 | subT :: (Q.Arbitrary a, SubTypes a) => a -> SubT 110 | subT = SubT 111 | 112 | -- Would require SubT to derive Eq. 113 | -- instance Eq SubT where 114 | -- SubT a == SubT b = cast a == Just b 115 | 116 | instance Show SubT where 117 | show (SubT t) = show t 118 | 119 | -- | This class covers algebraic datatypes that can be transformed into Trees. 120 | -- subTypes is the main method, placing values into trees. 121 | -- 122 | -- for a datatype with constructors A and C, 123 | -- 124 | -- > subTypes (A (C 0) 1) 125 | -- > [Node {rootLabel = C 0, subForest = []}] 126 | -- 127 | class (Q.Arbitrary a, Show a, Typeable a) => SubTypes a where 128 | ----------------------------------------------------------- 129 | -- | Turns algebraic data into a forest representation. 130 | subTypes :: a -> Forest SubT 131 | default subTypes :: (Generic a, GST (Rep a)) 132 | => a -> Forest SubT 133 | subTypes = gst . from 134 | ----------------------------------------------------------- 135 | -- | Base types (e.g., Int, Char) aren't analyzed. 136 | baseType :: a -> Bool 137 | baseType _ = False 138 | ----------------------------------------------------------- 139 | -- | Generically replace child i in m with value s. A total function: returns 140 | -- Nothing if you try to replace a child with an ill-typed child s. (Returns 141 | -- Just (the original data) if your index is out of bounds). 142 | replaceChild :: Typeable b => a -> Forest Subst -> b -> Maybe a 143 | default replaceChild :: (Generic a, GST (Rep a), Typeable b) 144 | => a -> Forest Subst -> b -> Maybe a 145 | replaceChild a forest b = fmap to $ grc (from a) forest b 146 | ----------------------------------------------------------- 147 | -- | Get the string representation of the constructor. 148 | toConstr :: a -> String 149 | default toConstr :: (Generic a, GST (Rep a)) => a -> String 150 | toConstr = gtc . from 151 | ----------------------------------------------------------- 152 | -- | showForest generically shows a value while preserving its structure (in a 153 | -- Tree). Always returns either a singleton list containing the tree (a 154 | -- degenerate forest) or an empty list for baseTypes. An invariant is that 155 | -- the shape of the tree produced by showForest is the same as the one 156 | -- produced by subTypes. 157 | showForest :: a -> Forest String 158 | default showForest :: (Generic a, GST (Rep a)) 159 | => a -> Forest String 160 | showForest = gsf . from 161 | ----------------------------------------------------------- 162 | 163 | 164 | ------------------------------------------------------------------------------- 165 | -- Generic representation 166 | ------------------------------------------------------------------------------- 167 | 168 | class GST f where 169 | -- Names are abbreviations of the corresponding method names above. 170 | gst :: f a -> Forest SubT 171 | grc :: Typeable b => f a -> Forest Subst -> b -> Maybe (f a) 172 | gtc :: f a -> String 173 | gsf :: f a -> Forest String 174 | gsz :: f a -> Int 175 | 176 | instance GST U1 where 177 | gst U1 = [] 178 | grc _ _ _ = Nothing 179 | gtc U1 = "" 180 | gsf U1 = [] 181 | gsz U1 = 0 182 | 183 | instance (GST a, GST b) => GST (a :*: b) where 184 | gst (a :*: b) = gst a ++ gst b 185 | 186 | grc (a :*: b) forest c = 187 | case forest of 188 | [] -> Just (a :*: b) 189 | ls -> do let (x,y) = splitAt (gsz a) ls 190 | left <- grc a x c 191 | right <- grc b y c 192 | return $ left :*: right 193 | 194 | gtc (a :*: b) = gtc a ++ gtc b 195 | gsf (a :*: b) = gsf a ++ gsf b 196 | gsz (a :*: b) = gsz a + gsz b 197 | 198 | instance (GST a, GST b) => GST (a :+: b) where 199 | gst (L1 a) = gst a 200 | gst (R1 b) = gst b 201 | 202 | grc (L1 a) forest c = grc a forest c >>= return . L1 203 | grc (R1 a) forest c = grc a forest c >>= return . R1 204 | 205 | gtc (L1 a) = gtc a 206 | gtc (R1 a) = gtc a 207 | 208 | gsf (L1 a) = gsf a 209 | gsf (R1 a) = gsf a 210 | 211 | gsz (L1 a) = gsz a 212 | gsz (R1 a) = gsz a 213 | 214 | -- Constructor meta-information 215 | instance (Constructor c, GST a) => GST (M1 C c a) where 216 | gst (M1 a) = gst a 217 | grc (M1 a) forest c = grc a forest c >>= return . M1 218 | gtc = conName 219 | 220 | gsf m@(M1 a) = [ Node (conName m) (gsf a) ] 221 | 222 | gsz (M1 a) = gsz a 223 | 224 | -- All the other meta-information (selector, module, etc.) 225 | instance GST a => GST (M1 i k a) where 226 | gst (M1 a) = gst a 227 | grc (M1 a) forest c = grc a forest c >>= return . M1 228 | gtc (M1 a) = gtc a 229 | gsf (M1 a) = gsf a 230 | gsz (M1 a) = gsz a 231 | 232 | instance (Show a, Q.Arbitrary a, SubTypes a, Typeable a) => GST (K1 i a) where 233 | gst (K1 a) = if baseType a 234 | then [ Node (subT a) [] ] 235 | else [ Node (subT a) (subTypes a) ] 236 | 237 | grc (K1 a) forest c = 238 | case forest of 239 | [] -> Just (K1 a) 240 | (Node Keep _ : _) -> Just (K1 a) 241 | (Node Subst [] : _) -> fmap K1 (cast c) 242 | (Node Subst ls : _) -> replaceChild a ls c >>= return . K1 243 | 244 | gtc _ = "" 245 | 246 | gsf (K1 a) = if baseType a then [ Node (show a) [] ] else showForest a 247 | 248 | gsz _ = 1 249 | 250 | ------------------------------------------------------------------------------- 251 | -- We cover the instances supported by QuickCheck: 252 | -- http://hackage.haskell.org/packages/archive/QuickCheck/2.4.2/doc/html/Test-QuickCheck-Arbitrary.html 253 | 254 | instance SubTypes Bool where 255 | subTypes _ = [] 256 | baseType _ = True 257 | replaceChild = replaceChild' 258 | toConstr = toConstr' 259 | showForest = showForest' 260 | instance SubTypes Char where 261 | subTypes _ = [] 262 | baseType _ = True 263 | replaceChild = replaceChild' 264 | toConstr = toConstr' 265 | showForest = showForest' 266 | instance SubTypes Double where 267 | subTypes _ = [] 268 | baseType _ = True 269 | replaceChild = replaceChild' 270 | toConstr = toConstr' 271 | showForest = showForest' 272 | instance SubTypes Float where 273 | subTypes _ = [] 274 | baseType _ = True 275 | replaceChild = replaceChild' 276 | toConstr = toConstr' 277 | showForest = showForest' 278 | instance SubTypes Int where 279 | subTypes _ = [] 280 | baseType _ = True 281 | replaceChild = replaceChild' 282 | toConstr = toConstr' 283 | showForest = showForest' 284 | instance SubTypes Integer where 285 | subTypes _ = [] 286 | baseType _ = True 287 | replaceChild = replaceChild' 288 | toConstr = toConstr' 289 | showForest = showForest' 290 | instance SubTypes Int8 where 291 | subTypes _ = [] 292 | baseType _ = True 293 | replaceChild = replaceChild' 294 | toConstr = toConstr' 295 | showForest = showForest' 296 | instance SubTypes Int16 where 297 | subTypes _ = [] 298 | baseType _ = True 299 | replaceChild = replaceChild' 300 | toConstr = toConstr' 301 | showForest = showForest' 302 | instance SubTypes Int32 where 303 | subTypes _ = [] 304 | baseType _ = True 305 | replaceChild = replaceChild' 306 | toConstr = toConstr' 307 | showForest = showForest' 308 | instance SubTypes Int64 where 309 | subTypes _ = [] 310 | baseType _ = True 311 | replaceChild = replaceChild' 312 | toConstr = toConstr' 313 | showForest = showForest' 314 | instance SubTypes Word where 315 | subTypes _ = [] 316 | baseType _ = True 317 | replaceChild = replaceChild' 318 | toConstr = toConstr' 319 | showForest = showForest' 320 | instance SubTypes Word8 where 321 | subTypes _ = [] 322 | baseType _ = True 323 | replaceChild = replaceChild' 324 | toConstr = toConstr' 325 | showForest = showForest' 326 | instance SubTypes Word16 where 327 | subTypes _ = [] 328 | baseType _ = True 329 | replaceChild = replaceChild' 330 | toConstr = toConstr' 331 | showForest = showForest' 332 | instance SubTypes Word32 where 333 | subTypes _ = [] 334 | baseType _ = True 335 | replaceChild = replaceChild' 336 | toConstr = toConstr' 337 | showForest = showForest' 338 | instance SubTypes Word64 where 339 | subTypes _ = [] 340 | baseType _ = True 341 | replaceChild = replaceChild' 342 | toConstr = toConstr' 343 | showForest = showForest' 344 | instance SubTypes () where baseType _ = True 345 | instance ( Q.Arbitrary a, SubTypes a, Typeable a) => SubTypes [a] 346 | instance (Integral a, Q.Arbitrary a, SubTypes a, Typeable a) 347 | => SubTypes (Ratio a) where 348 | subTypes _ = [] 349 | baseType _ = True 350 | replaceChild = replaceChild' 351 | toConstr = toConstr' 352 | showForest = showForest' 353 | instance (RealFloat a, Q.Arbitrary a, SubTypes a, Typeable a) 354 | => SubTypes (Complex a) where 355 | subTypes _ = [] 356 | baseType _ = True 357 | replaceChild = replaceChild' 358 | toConstr = toConstr' 359 | showForest = showForest' 360 | instance (Q.Arbitrary a, SubTypes a, Typeable a) => SubTypes (Maybe a) 361 | instance ( Q.Arbitrary a, SubTypes a, Typeable a 362 | , Q.Arbitrary b, SubTypes b, Typeable b) 363 | => SubTypes (Either a b) 364 | instance ( Q.Arbitrary a, SubTypes a, Typeable a 365 | , Q.Arbitrary b, SubTypes b, Typeable b) 366 | => SubTypes (a, b) 367 | instance ( Q.Arbitrary a, SubTypes a, Typeable a 368 | , Q.Arbitrary b, SubTypes b, Typeable b 369 | , Q.Arbitrary c, SubTypes c, Typeable c) 370 | => SubTypes (a, b, c) 371 | instance ( Q.Arbitrary a, SubTypes a, Typeable a 372 | , Q.Arbitrary b, SubTypes b, Typeable b 373 | , Q.Arbitrary c, SubTypes c, Typeable c 374 | , Q.Arbitrary d, SubTypes d, Typeable d) 375 | => SubTypes (a, b, c, d) 376 | instance ( Q.Arbitrary a, SubTypes a, Typeable a 377 | , Q.Arbitrary b, SubTypes b, Typeable b 378 | , Q.Arbitrary c, SubTypes c, Typeable c 379 | , Q.Arbitrary d, SubTypes d, Typeable d 380 | , Q.Arbitrary e, SubTypes e, Typeable e) 381 | => SubTypes (a, b, c, d, e) 382 | 383 | ------------------------------------------------------------------------------- 384 | -- Helpers 385 | 386 | -- These should never be directly called. We provide compatible instances anyway. 387 | toConstr' :: Show a => a -> String 388 | toConstr' = show 389 | 390 | replaceChild' :: (Typeable a, Typeable b) 391 | => a -> Forest Subst -> b -> Maybe a 392 | replaceChild' a [] _ = Just a 393 | replaceChild' a (Node Keep _ : _) _ = Just a 394 | replaceChild' _ (Node Subst _ : _) b = cast b 395 | 396 | showForest' :: Show a => a -> Forest String 397 | showForest' _ = [] 398 | 399 | ------------------------------------------------------------------------------- 400 | 401 | errorMsg :: String -> a 402 | errorMsg loc = error $ "SmartCheck error: unexpected error in " ++ loc 403 | ++ ". Please file a bug report at " 404 | ++ "." 405 | 406 | ------------------------------------------------------------------------------- 407 | --------------------------------------------------------------------------------