Permalink
Browse files

Initial commit.

  • Loading branch information...
0 parents commit 418548cfc457387e0f58eab836f6be61a68af298 @leepike committed Apr 11, 2012
30 LICENSE
@@ -0,0 +1,30 @@
+Copyright (c)2012, Lee Pike
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+ * Redistributions of source code must retain the above copyright
+ notice, this list of conditions and the following disclaimer.
+
+ * Redistributions in binary form must reproduce the above
+ copyright notice, this list of conditions and the following
+ disclaimer in the documentation and/or other materials provided
+ with the distribution.
+
+ * Neither the name of Lee Pike nor the names of other
+ contributors may be used to endorse or promote products derived
+ from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
30 README
@@ -0,0 +1,30 @@
+SmartCheck takes the output of QuickCheck and does data-generic shrinking on it
+(you don't have to define shrink methods yourself). Once it's found the minimal
+value it can, it tries to generalize by replacing holes with arbitrary
+(well-typed) values. If for any replacement the test still fails, it
+conjectures that you plug anything into the holes.
+
+A typical example
+--------------------------------
+
+> cd SmartCheck/src/
+> ghci -Wall ../examples/MutualRecData.hs
+*MutualRecData> main
+
+*** Failed! Falsifiable (after 15 tests):
+M (N (M (N (M (N P (-5) "\GS(") (N (M (N P 35 "$<\rk\183\no\NUL") (N (M (N P 31 "d: \228\244\135\251&") (N P 31 "") 52) 62 "\234\STX\246R\204.P\205") 28) 17 "") (-48)) 29 "7\157[\186X6\242\191*") (N (M (N P (-4) "2f\151\DLE!EG\162/\128") (N (M (N P 2 "n<a\USLRLXK") (N (M (N P 23 "\rK\140\STXQ\b\155( ") (N P 9 "}\247\DLE") 42) (-36) "\SO 1MJL\ETX") (-14)) (-47) "_^") 4) 69 "(\\i") (-48)) (-256) "\vp\179\177\163") (N (M (N P 31 "") (N (M (N (M (N (M (N P (-9) "W\ETXi\DC1\b\201") (N (M (N P (-16) "\150=q") (N (M (N P 5 "\RS") (N P (-10) "]") (-18)) 6 "i\ESC") (-6)) (-16) "\238k") (-55)) (-35) "\NUL\"") (N P 6 "xC2HFW") (-57)) (-21) "\\\187\130\153lI^\EM") (N (M (N (M (N P (-27) "}\DC2") (N (M (N P 26 "P\SYN\ACK\226W8-") (N (M (N (M (N (M (N P (-8) "\199\DLE\144\180") (N (M (N (M (N P 2 "") (N P 1 "c\t") (-3)) 3 "=`") (N (M (N (M (N P (-1) "B") (N (M (N (M (N P 1 "") (N P 0 "") 1) 0 "d") (N P 1 "w") 2) 2 "") 2) (-1) "D\v\163") (N (M (N P (-1) "") (N P 1 "\232M") 0) (-2) "") 0) (-3) "1r[") (-5)) 1 "\DC4\EM") (-4)) 0 "H3\RS\239") (N P 8 "\f\DC1y\151d") 15) 15 "") (N P (-2) "") 28) (-20) "\US\NAKZ\DLEVt") (-10)) (-5) "!M\ACKk\DC4\DC1uY?") (-27)) (-14) "YE+\163\rJVS_4") (N (M (N (M (N (M (N (M (N P (-2) "\237\&4@") (N P 6 "") 6) 2 "^\DLEM\189y") (N P (-16) "\222\247(\DLE") (-14)) (-6) "\DEL\DC1iM\vn\218") (N (M (N P 8 "?\249KH\t\153") (N P 9 "") 26) (-16) "") 30) 14 "\STXOLy[\EOT") (N (M (N P 13 "\249%") (N (M (N (M (N (M (N (M (N P (-1) "x") (N (M (N P (-1) "!b") (N P (-2) "\240") 3) 4 "") 1) 5 "\207") (N (M (N P 4 "") (N (M (N (M (N P (-2) "") (N P (-1) "e") 2) 0 "") (N (M (N (M (N (M (N P 1 "") (N P 1 "") (-1)) 1 "") (N P (-1) "") (-1)) 1 "") (N P (-1) "") (-1)) (-1) "") 4) 3 "\144\b\217\n") 3) 8 "") 1) (-3) "3}`") (N P 3 "6\149") (-11)) (-8) "") (N (M (N (M (N P (-5) "e\222J") (N P 5 "/+G") 6) 1 "\151\151\&9") (N P (-7) "") (-12)) 2 "!\237") 18) (-9) "|R+C\186}c") 6) 14 "a\208\ACK\ENQ\SI!") 55) 10 "\158") (-52)) 14 "") (-45)) 90 "lg") (-12)) 177 "\224I\246\189F%\SOH\DC4-") 187
+
+*** Smart Shrinking ...
+*** Smart-shrunk value:
+M (N P 0 "") (N P 1 "") 187
+
+*** Extrapolating ...
+*** Extrapolated value:
+forall x0 x1:
+M
+|
++- x1
+|
++- x0
+|
+`- 187
@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain
@@ -0,0 +1,46 @@
+Name: SmartCheck
+Version: 0.1
+Synopsis: A smarter QuickCheck.
+License: BSD3
+License-file: LICENSE
+Author: Lee Pike
+Maintainer: leepike@gmail.com
+Copyright: copyright, Lee Pike 2012.
+Category: Testing
+Build-type: Simple
+Extra-source-files:
+
+Cabal-version: >=1.2
+
+Library
+ Exposed-modules: SmartCheck,
+ SmartCheck.ChildReplace,
+ SmartCheck.Extrapolate,
+ SmartCheck.TypeBi
+
+-- BinaryTrees, Protocol, Tests, Div0, BinarySearch, Rev, SmartCheck.Extrapolate, SmartCheck.TypeBi, SmartCheck.SmartCheck, SmartCheck.ChildReplace
+
+ Build-depends: base >= 4.0,
+ QuickCheck >= 2.4.2,
+ mtl >= 2.0.1.0,
+ random >= 1.0.1.1,
+ uniplate >= 1.6.6
+
+ default-language: Haskell2010
+
+ hs-source-dirs: src
+
+ ghc-options:
+ -Wall
+ -fwarn-tabs
+ -auto-all
+ -caf-all
+ -fno-warn-orphans
+
+ --enable-library-profiling
+
+
+ -- Other-modules:
+
+ -- Build-tools:
+
3 TODO
@@ -0,0 +1,3 @@
+* Rename Reduce to SmartShrink
+* Rename examples/Test to examples/MutRecData
+ * Rename it in the README, too.
@@ -0,0 +1,84 @@
+{-# LANGUAGE DeriveDataTypeable #-}
+
+module MutualRecData where
+
+import Test.SmartCheck
+
+import Data.Tree
+import Data.Data
+import Control.Monad.State
+import Test.QuickCheck hiding (Result)
+
+---------------------------------------------------------------------------------
+
+data M = M N N Int
+ | P
+ deriving (Data, Typeable, Show, Eq, Read)
+
+data N = N M Int String
+ deriving (Data, Typeable, Show, Eq, Read)
+
+data O = O N String
+ deriving (Data, Typeable, Show, Eq, Read)
+
+---------------------------------------------------------------------------------
+
+instance SubTypes M where
+ subTypes (M n0 n1 j) =
+ [ Node (subT n0) (subTypes n0)
+ , Node (subT n1) (subTypes n1)
+ , Node (subT j) []
+ ]
+ subTypes P = []
+
+instance SubTypes N where
+ subTypes (N m i s) =
+ [ Node (subT m) (subTypes m)
+ , Node (subT i) []
+ , Node (subT s) []
+ ]
+
+instance SubTypes O where
+ subTypes (O n s) =
+ [ Node (subT n) (subTypes n)
+ , Node (subT s) []
+ ]
+
+---------------------------------------------------------------------------------
+
+instance Arbitrary M where
+ arbitrary =
+ sized $ \n -> if n == 0 then return P
+ else oneof [ return P
+ , liftM3 M (resize (n-1) arbitrary)
+ (resize (n-1) arbitrary)
+ arbitrary
+ ]
+
+instance Arbitrary N where
+ arbitrary = liftM3 N arbitrary arbitrary arbitrary
+
+---------------------------------------------------------------------------------
+
+prop0 :: M -> Bool
+prop0 (M _ _ a) = a < 100
+prop0 _ = True
+
+main :: IO ()
+main = do result <- smartRun args prop0
+ extrapolate args result prop0
+ where
+ args = stdSmartArgs { qcArgs = stdArgs { maxSuccess = 1000 } }
+
+---------------------------------------------------------------------------------
+
+testProp :: M -> Bool
+testProp (M _ _ i) = i > 100
+testProp _ = True
+
+xx :: M
+xx = M (N (M (N P 1 "goo") (N P 7 "foo") 8) 3 "hi") (N P 4 "bye") 6
+yy :: Forest Int
+yy = [Node 0 [Node 1 [], Node 2 []], Node 3 [Node 4 [], Node 5 [Node 6 []]]]
+
+---------------------------------------------------------------------------------
@@ -0,0 +1,16 @@
+-- | Interface module.
+
+module Test.SmartCheck
+ ( SmartArgs (..)
+ , stdSmartArgs
+ , smartRun
+ , extrapolate
+ -- SubTypes class
+ , SubT(..)
+ , subT
+ , SubTypes(..)
+ ) where
+
+import Test.SmartCheck.Reduce
+import Test.SmartCheck.Extrapolate
+import Test.SmartCheck.Types
@@ -0,0 +1,61 @@
+module Test.SmartCheck.Common
+ ( samples
+ , iterateArb
+ , smartPrefix
+ ) where
+
+import Test.SmartCheck.Types
+import Test.SmartCheck.DataToTree
+
+import qualified Test.QuickCheck.Gen as Q
+import qualified Test.QuickCheck as Q
+import System.Random
+import Data.List
+import Data.Data
+import Data.Maybe
+import Control.Monad
+
+---------------------------------------------------------------------------------
+
+-- | Make some samples no larger than maxSz of the same type as value a.
+samples :: Q.Arbitrary a
+ => a -- ^ unused; just to type arbitrary.
+ -> Int -- ^ Number of tries.
+ -> Int -- ^ Maximum size of the structure generated.
+ -> IO [a]
+samples _ i maxSz = do
+ rnd0 <- newStdGen
+ when (maxSz < 0) (error "samples: maxSize less than 0.")
+ let ls = sort $ take i $ randomRs (0, maxSz) rnd0 -- XXX better distribution.
+ let rnds rnd = rnd1 : rnds rnd2
+ where (rnd1,rnd2) = split rnd
+ let Q.MkGen m = Q.arbitrary
+ return [ (m r n) | (r,n) <- rnds rnd0 `zip` ls ]
+
+---------------------------------------------------------------------------------
+
+-- | Replace the hole in d indexed by idx with a bunch of random values, and
+-- test the new d against the property. Returns the first new d that succeeds.
+iterateArb :: (Data a, SubTypes a)
+ => SmartArgs -> a -> Idx -> Int -> (a -> Bool) -> IO (Maybe a)
+iterateArb args d idx sz prop =
+ case getAtIdx d idx of
+ Nothing -> return Nothing
+ Just v -> do rnds <- mkVals v
+ let res = catMaybes $ map repl rnds
+ -- Catch errors
+ when (length res /= length rnds) (error "iterateArb")
+ return (find prop res)
+ where
+ mkVals SubT { unSubT = v } = do
+ rnds <- samples v (grows args) sz -- XXX should be a smartArgs parameter?
+ return $ map subT rnds
+
+ repl SubT { unSubT = v } = replaceAtIdx d idx v
+
+---------------------------------------------------------------------------------
+
+smartPrefix :: String
+smartPrefix = "*** "
+
+---------------------------------------------------------------------------------
Oops, something went wrong.

0 comments on commit 418548c

Please sign in to comment.