Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

Initial commit.

  • Loading branch information...
commit 418548cfc457387e0f58eab836f6be61a68af298 0 parents
@leepike authored
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
2  Setup.hs
@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain
46 SmartCheck.cabal
@@ -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.
84 examples/MutualRecData.hs
@@ -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 []]]]
+
+---------------------------------------------------------------------------------
16 src/Test/SmartCheck.hs
@@ -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
61 src/Test/SmartCheck/Common.hs
@@ -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 = "*** "
+
+---------------------------------------------------------------------------------
183 src/Test/SmartCheck/DataToTree.hs
@@ -0,0 +1,183 @@
+{-# LANGUAGE Rank2Types #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+module Test.SmartCheck.DataToTree
+ ( sub
+ , getAtIdx
+ , replaceAtIdx
+ , getIdxForest
+ , mkShowTree
+ , breadthLevels
+ , mkSubstForest
+ , depth
+ ) where
+
+import Test.SmartCheck.Types
+
+import Control.Monad.State
+import Data.Tree
+import Data.Data
+import Data.List
+import Data.Maybe
+
+---------------------------------------------------------------------------------
+-- Operations on Trees and Forests.
+---------------------------------------------------------------------------------
+
+-- | Return the list of values at each level in a Forest Not like levels in
+-- Data.Tree (but what I imagined it should have done!).
+breadthLevels :: Forest a -> [[a]]
+breadthLevels forest =
+ takeWhile (not . null) go
+ where
+ go = map (getLevel forest) [0..]
+
+---------------------------------------------------------------------------------
+
+-- | Return the elements at level i from a forest. 0-based indexing.
+getLevel :: Forest a -> Int -> [a]
+getLevel fs 0 = map rootLabel fs
+getLevel fs n = concatMap (\fs' -> getLevel (subForest fs') (n-1)) fs
+
+---------------------------------------------------------------------------------
+
+-- | Get the depth of a Forest.
+depth :: Forest a -> Int
+depth forest = if null ls then 0 else maximum ls
+ where
+ ls = map depth' forest
+ depth' (Node _ []) = 1
+ depth' (Node _ forest') = 1 + depth forest'
+
+---------------------------------------------------------------------------------
+
+-- | How many members are at level i in the Tree?
+levelLength :: Int -> Tree a -> Int
+levelLength 0 t = length (subForest t)
+levelLength n t = sum $ map (levelLength (n-1)) (subForest t)
+
+---------------------------------------------------------------------------------
+
+-- | Get the tree at idx in a forest. Nothing if the index is out-of-bounds.
+getIdxForest :: Forest a -> Idx -> Maybe (Tree a)
+getIdxForest forest (Idx (0::Int) n) =
+ if length forest > n then Just (forest !! n) else Nothing
+getIdxForest forest idx =
+ -- Should be a single Just x in the list, holding the value.
+ listToMaybe . catMaybes . snd $ mapAccumL findTree (column idx) (map Just forest)
+ where
+ l = level idx - 1
+ -- Invariant: not at the right level yet.
+ findTree :: Int -> Maybe (Tree a) -> (Int, Maybe (Tree a))
+ findTree n Nothing = (n, Nothing)
+ findTree n (Just t) =
+ let len = levelLength l t in
+ if n < 0 -- Already found index
+ then (n, Nothing)
+ else if n < len -- Big enough to index, so we climb down this one.
+ then let t' = getIdxForest (subForest t) (Idx l n) in
+ (n-len, t')
+ else (n-len, Nothing)
+
+---------------------------------------------------------------------------------
+
+-- | Replace a tree at index Idx in a Forest. Return the original if the index
+-- is out of range. All subforests are removed.
+sub :: Forest a -> Idx -> a -> Forest a
+-- on right level, and we'll assume correct subtree.
+sub forest (Idx (0::Int) n) a =
+ take n forest ++ Node a [] : drop (n+1) forest
+sub forest idx a =
+ snd $ mapAccumL findTree (column idx) forest
+ where
+ l = level idx - 1
+ -- Invariant: not at the right level yet.
+ findTree n t =
+ let len = levelLength l t in
+ if n < 0 -- Already found index
+ then (n, t)
+ else if n < len -- Big enough to index, so we climb down this one.
+ then (n-len, Node (rootLabel t) (sub (subForest t) (Idx l n) a))
+ else (n-len, t)
+
+---------------------------------------------------------------------------------
+-- Operations on SubTypes.
+---------------------------------------------------------------------------------
+
+-- | Make a substitution Forest (all proper children). Initially we don't
+-- replace anything.
+-- mkSubstForest :: Data a => a -> Forest Subst
+-- mkSubstForest = gmapQ f
+-- where
+-- f :: forall d. Data d => d -> Tree Subst
+-- f x = Node Keep (mkSubstForest x)
+mkSubstForest :: SubTypes a => a -> Forest Subst
+mkSubstForest a = map tMap (subTypes a)
+ where tMap t = fmap (\_ -> Keep) t
+
+---------------------------------------------------------------------------------
+
+-- | Returns the value at index idx. Returns nothing if the index is out of
+-- bounds.
+getAtIdx :: SubTypes a
+ => a -- ^ Parent value
+ -> Idx -- ^ Index of hole to replace
+ -> Maybe SubT
+getAtIdx d Idx { level = l
+ , column = c }
+ = if length lev > c then Just (lev !! c) else Nothing
+ where
+ lev = getLevel (subTypes d) l
+
+---------------------------------------------------------------------------------
+
+-- | Replace a value at index idx generically in a Tree/Forest generically.
+replaceAtIdx :: (SubTypes a, Data b)
+ => a -- ^ Parent value
+ -> Idx -- ^ Index of hole to replace
+ -> b -- ^ Value to replace with
+ -> Maybe a
+replaceAtIdx m idx = replaceChild m (sub (mkSubstForest m) idx Subst)
+
+---------------------------------------------------------------------------------
+
+-- | Generically replace child i in m with value s. A total function: returns
+-- Nothing if you try to replace a child with an ill-typed child s. (Returns
+-- Just (the original data) if your index is out of bounds).
+replaceChild :: (Data a, Data b) => a -> Forest Subst -> b -> Maybe a
+replaceChild d idx s =
+ case runState (gmapM f d) (Left (), idx) of
+ (d', (Left _, _)) -> Just d'
+ (_ , (Right _, _)) -> Nothing
+
+ where
+ f :: forall b. Data b
+ => b -> State (Either () (), Forest Subst) b
+ f x = do
+ (lr, j) <- get
+ case j :: Forest Subst of
+ [] -> return x
+ ((Node Subst ls):rst) | null ls -> case cast s of
+ Just x' -> do put (lr, rst)
+ return x'
+ Nothing -> do put (Right (), rst)
+ return x
+ | True -> case replaceChild x ls s of
+ Just x' -> do put (lr, rst)
+ return x'
+ Nothing -> do put (Right (), rst)
+ return x
+ ((Node Keep _):rst) -> do put (lr, rst)
+ return x
+
+---------------------------------------------------------------------------------
+-- Rendering.
+---------------------------------------------------------------------------------
+
+mkShowTree :: SubTypes a => a -> Tree String
+mkShowTree d = Node (show $ toConstr d) (strForest $ subTypes d)
+
+strForest :: Forest SubT -> Forest String
+strForest = fmap (\(Node r forest) -> Node (show r) (strForest forest))
+
+---------------------------------------------------------------------------------
78 src/Test/SmartCheck/Extrapolate.hs
@@ -0,0 +1,78 @@
+{-# LANGUAGE ScopedTypeVariables #-}
+
+module Test.SmartCheck.Extrapolate
+ ( extrapolate
+ ) where
+
+import Test.SmartCheck.Types
+import Test.SmartCheck.DataToTree
+import Test.SmartCheck.Common
+
+import Data.Data
+import Data.Tree
+import Data.List
+import Data.Maybe
+
+---------------------------------------------------------------------------------
+
+-- | Test d with arbitrary values replacing its children. For anything we get
+-- 100% failure for, we claim we can generalize it---any term in that hole
+-- fails.
+extrapolate :: (Data a, SubTypes a)
+ => SmartArgs -> a -> (a -> Bool) -> IO ()
+extrapolate args d prop = do
+ putStrLn ""
+ putStrLn $ smartPrefix ++ "Extrapolating ..."
+ putStrLn $ smartPrefix ++ "Extrapolated value:"
+
+ idxs <- iter (mkSubstForest d) (Idx 0 0) []
+ renderWithVars d idxs
+
+ where
+ -- Do a breadth-first traversal of the data, trying to replace items. When we
+ -- find an index we can replace, add it's index to the index list. Recurse
+ -- down the structure, following subtrees that have *not* been replaced.
+ iter :: Forest Subst -> Idx -> [Idx] -> IO [Idx]
+ iter forest idx idxs =
+ if done then return idxs
+ else if nextLevel
+ then iter forest (idx { level = level idx + 1 }) idxs
+ -- XXX right ratio? Should I use a
+ -- user-specified arg?
+ else do tries <- iterateArb args d idx (grows args `div` 2) prop
+ if isNothing tries
+ -- None of the tries satisfy prop. Prevent recurring down
+ -- this tree, since we can generalize.
+ then iter (sub forest idx Keep)
+ (idx { column = column idx + 1 })
+ (idx:idxs)
+ -- Can't generalize.
+ else iter forest
+ (idx { column = column idx + 1 })
+ idxs
+
+ where
+ pts = breadthLevels forest
+ done = length pts <= level idx
+ nextLevel = length (pts !! level idx) <= column idx
+
+---------------------------------------------------------------------------------
+
+replaceWithVars :: SubTypes a => a -> [Idx] -> [String] -> Tree String
+replaceWithVars d idxs vars =
+ foldl' f (mkShowTree d) (zip vars idxs)
+ where
+ f :: Tree String -> (String, Idx) -> Tree String
+ f tree (var, idx) = let forest = sub (subForest tree) idx var in
+ Node (rootLabel tree) forest
+
+---------------------------------------------------------------------------------
+
+renderWithVars :: SubTypes a => a -> [Idx] -> IO ()
+renderWithVars d idxs = do
+ putStrLn $ "forall " ++ unwords (take (length idxs) vars) ++ ":"
+ putStrLn . drawTree $ replaceWithVars d idxs vars
+ where
+ vars = map (\(x,i) -> x ++ show i) $ zip (repeat "x") [0::Int ..]
+
+---------------------------------------------------------------------------------
91 src/Test/SmartCheck/Reduce.hs
@@ -0,0 +1,91 @@
+{-# LANGUAGE ScopedTypeVariables #-}
+
+module Test.SmartCheck.Reduce
+ where
+
+import Test.SmartCheck.Types
+import Test.SmartCheck.Common
+import Test.SmartCheck.DataToTree
+
+import qualified Test.QuickCheck as Q
+import Control.Monad
+import Data.Maybe
+import Data.Tree
+
+---------------------------------------------------------------------------------
+
+-- Smarter than shrinks. Does substitution. m is a value that failed QC that's
+-- been shrunk. We substitute successive children with strictly smaller (and
+-- increasingly larger) randomly-generated values until we find a failure, and
+-- return that result. (We call smartShrink recursively.)
+smartRun :: (Read a, Show a, Q.Arbitrary a, SubTypes a)
+ => SmartArgs -> (a -> Bool) -> IO a
+smartRun args prop = do
+ let genProp = Q.forAllShrink Q.arbitrary Q.shrink prop
+ res <- runQC (qcArgs args) genProp
+ unless (isJust res) (return ())
+ new <- smartShrink args (fromJust res) prop
+ putStrLn ""
+ putStrLn $ smartPrefix ++ "Smart Shrinking ... "
+ putStrLn $ smartPrefix ++ "Smart-shrunk value:"
+ print new
+ return new
+
+---------------------------------------------------------------------------------
+
+runQC :: forall a b. (Q.Testable b, Read a) => Q.Args -> Q.Gen b -> IO (Maybe a)
+runQC args propGen = do
+ res <- Q.quickCheckWithResult args propGen
+ case res of
+ -- XXX C'mon, QuickCheck, let me grab the result in a sane way rather than
+ -- parsing a string!
+ Q.Failure _ _ _ _ _ _ out -> do let ms = (lines out) !! 1
+ let m = (read ms) :: a
+ return $ Just m
+ _ -> return Nothing
+
+---------------------------------------------------------------------------------
+
+-- | Breadth-first traversal of d, trying to shrink it with *strictly* smaller
+-- children. We replace d whenever a successful shrink is found and try again.
+smartShrink :: SubTypes a
+ => SmartArgs -> a -> (a -> Bool) -> IO a
+smartShrink args d prop = iter d (Idx 0 0)
+
+ where
+ iter d' idx = do
+ if done then return d'
+ else if nextLevel
+ then iter d' (idx { level = level idx + 1 })
+ else do if isNothing maxSize
+ then iter d' (idx { column = column idx + 1 })
+ else mkTry
+
+ where
+ mkTry = do try <- iterateArb args d' idx (fromJust maxSize) notProp
+ -- first failing try
+ if isJust try
+ -- Found a try that satisfies prop. We'll now test try,
+ -- and start trying to reduce from the top!
+ then iter (fromJust try) (Idx 0 0)
+ -- Can't generalize.
+ else iter d' (idx { column = column idx + 1 })
+
+ forest = mkSubstForest d'
+ notProp = not . prop
+
+ -- XXX How do I know that the size of arbitrary relates to the depth of the
+ -- structure? However, things seem to work, but I'm not sure if it's
+ -- because of the instances I defined.
+ maxSize = case getIdxForest forest idx of
+ Nothing -> Nothing
+ Just t -> let dep = depth (subForest t) in
+ -- XXX figure this out.
+ if dep <= 1 then Nothing
+ else Just (dep-1)
+
+ pts = breadthLevels forest
+ done = length pts <= level idx
+ nextLevel = length (pts !! level idx) <= column idx
+
+---------------------------------------------------------------------------------
62 src/Test/SmartCheck/Types.hs
@@ -0,0 +1,62 @@
+{-# LANGUAGE ExistentialQuantification #-}
+
+module Test.SmartCheck.Types
+ ( SmartArgs(..)
+ , stdSmartArgs
+ , SubT(..)
+ , subT
+ , SubTypes(..)
+ , Idx(..)
+ , Subst(..)
+ ) where
+
+import Data.Tree
+import Data.Data
+import qualified Test.QuickCheck as Q
+
+---------------------------------------------------------------------------------
+-- Arguments
+---------------------------------------------------------------------------------
+
+data SmartArgs = SmartArgs
+ { qcArgs :: Q.Args
+ , shrinks :: Int -- How many tries to smart shrink the failed value?
+ , grows :: Int -- How many tries to generalize the smart-shrunk value?
+ }
+
+---------------------------------------------------------------------------------
+
+stdSmartArgs :: SmartArgs
+stdSmartArgs = SmartArgs Q.stdArgs 100 1000
+
+---------------------------------------------------------------------------------
+-- User-defined subtypes of data
+---------------------------------------------------------------------------------
+
+data SubT = forall a. (Data a, Q.Arbitrary a, Show a)
+ => SubT { unSubT :: a }
+
+instance Show SubT where
+ show (SubT t) = show t
+
+subT :: (Data a, Q.Arbitrary a, Show a) => a -> SubT
+subT = SubT
+
+class Data a => SubTypes a where
+ subTypes :: a -> Forest SubT
+
+---------------------------------------------------------------------------------
+-- Indexing
+---------------------------------------------------------------------------------
+
+-- | Index into a Tree/Forest, where level is the depth from the root and column
+-- is the distance d is the dth value on the same level. Thus, all left-most
+-- nodes are in column 0. This is a "matrix view" of tree-structured data.
+data Idx = Idx { level :: Int, column :: Int }
+ deriving (Show, Eq, Read)
+
+-- | Keep or substitue a value in the tree.
+data Subst = Keep | Subst
+ deriving (Show, Eq, Read)
+
+---------------------------------------------------------------------------------
Please sign in to comment.
Something went wrong with that request. Please try again.