├── .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 |
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 |
--------------------------------------------------------------------------------