Permalink
Browse files

Refactor to the read-eval-print in the SmartCheck module.

  • Loading branch information...
leepike committed Apr 22, 2012
1 parent 628e31b commit 77a9e3622aae0912f9993e427f5db122118d7eda
Showing with 49 additions and 33 deletions.
  1. +1 −3 examples/Div0.hs
  2. +2 −3 examples/MutualRecData.hs
  3. +24 −5 src/Test/SmartCheck.hs
  4. +19 −22 src/Test/SmartCheck/Extrapolate.hs
  5. +3 −0 src/Test/SmartCheck/Types.hs
View
@@ -63,9 +63,7 @@ div1 m = divSubTerms m ==> eval m /= Nothing
-- div0 _ = property True
main :: IO ()
-main = do result <- smartRun args div1
- extrapolate args result div1
-
+main = smartCheck args div1
where args = stdArgs { maxSuccess = 100
, maxSize = 20 }
@@ -64,10 +64,9 @@ prop0 (M _ _ a) = a < 100
prop0 _ = True
main :: IO ()
-main = do result <- smartRun args p
- extrapolate args result p
+main = smartCheck args p
where
- p = \a -> property (prop0 a)
+ p = \a -> property (prop0 a)
args = stdArgs { maxSuccess = 1000 }
---------------------------------------------------------------------------------
View
@@ -1,11 +1,7 @@
-- | Interface module.
module Test.SmartCheck
- ( -- SmartArgs (..)
- -- , stdSmartArgs
- smartRun
- , extrapolate
- -- SubTypes class
+ ( smartCheck
, SubT(..)
, subT
, SubTypes(..)
@@ -16,5 +12,28 @@ module Test.SmartCheck
import Test.SmartCheck.Reduce
import Test.SmartCheck.Extrapolate
import Test.SmartCheck.Types
+import Test.SmartCheck.Common
+import qualified Test.QuickCheck as Q
import Data.Tree
+import Data.Maybe
+
+---------------------------------------------------------------------------------
+
+smartCheck :: (Read a, Show a, Q.Arbitrary a, SubTypes a)
+ => Q.Args -> (a -> Q.Property) -> IO ()
+smartCheck args prop = do
+ d <- smartRun args prop
+ if isNothing d then return ()
+ else do prop' <- extrapolate args (fromJust d) prop
+ c <- continue
+ if c then smartCheck args prop'
+ else smartPrtLn "Done."
+
+ where
+ continue = do putStrLn $ "Attempt to find a new counterexample?"
+ ++ " (Enter to continue, 'n' to quit.)"
+ s <- getLine
+ return (s == "")
+
+---------------------------------------------------------------------------------
@@ -9,45 +9,32 @@ module Test.SmartCheck.Extrapolate
import Test.SmartCheck.Types
import Test.SmartCheck.DataToTree
import Test.SmartCheck.Common
-import Test.SmartCheck.Reduce
import qualified Test.QuickCheck as Q
import Data.Data
import Data.Tree
import Data.List
import Data.Maybe
-import Control.Monad
---------------------------------------------------------------------------------
-- | 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, Read a, Show a, Q.Arbitrary a)
- => Q.Args -> Maybe a -> (a -> Q.Property) -> IO ()
-extrapolate args md prop = do
+ => Q.Args -> a -> (a -> Q.Property) -> IO (a -> Q.Property)
+extrapolate args d prop = do
putStrLn ""
- when (isNothing md) (smartPrtLn "No value to extrapolate, done.")
- when (isJust md) $ do smartPrtLn "Extrapolating ..."
- smartPrtLn "Extrapolated value:"
- idxs <- iter (mkSubstForest d) (Idx 0 0) []
- renderWithVars d idxs
- c <- continue
- when c $ do d' <- smartRun args (prop' idxs)
- when (isJust d')
- (extrapolate args d' (prop' idxs))
- unless c (smartPrtLn "Done.")
+ smartPrtLn "Extrapolating ..."
+ smartPrtLn "Extrapolated value:"
+ idxs <- iter (mkSubstForest d) (Idx 0 0) []
+ renderWithVars d idxs
+ return (prop' idxs)
where
- continue = do putStrLn "Attempt to find a new counterexample? (Enter to continue, 'n' to quit.)"
- s <- getLine
- return (s == "")
-
prop' idxs a = (not $ matchesShape d a idxs) Q.==> prop a
- Just d = md -- use depends on laziness!
-
-- 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.
@@ -100,6 +87,9 @@ renderWithVars d idxs = do
-- | a matches the shape of b iff a and b have the same constructor, and for all
-- holes not indexed by the indexes from idxs, their immediate subchildren have
-- the same constructors.
+
+
+-- XXX redo documentation to be true!
--
-- > matchesShape (D (C 0) (A (C 1) (C 1))) (D (C 1) (A (A (C 0) (C 3)) (C 0))) []
-- > True
@@ -109,19 +99,26 @@ renderWithVars d idxs = do
--
-- > matchesShape (D (C 0) (A (C 1) (C 1))) (D (C 1) (D (A (C 1) (C 1)))) [Idx 0 1]
-- > True
-matchesShape :: (SubTypes a) => a -> a -> [Idx] -> Bool
+matchesShape :: SubTypes a => a -> a -> [Idx] -> Bool
matchesShape a b idxs =
toConstr a == toConstr b
&& repIdxs
where
repIdxs = case foldl' f (Just b) idxs of
Nothing -> False
- Just b' -> gmapQ toConstr a == gmapQ toConstr b'
+ Just b' -> and $ map test $ zip (nextLevel a) (nextLevel b')
f mb idx = do
b' <- mb
v <- getAtIdx a idx
replace b' idx v
+ nextLevel x = map rootLabel (subTypes x)
+
+ test (SubT x, SubT y) =
+ if isAlgType (dataTypeOf x)
+ then toConstr x == toConstr y
+ else True
+
---------------------------------------------------------------------------------
@@ -19,6 +19,9 @@ import qualified Test.QuickCheck as Q
data SubT = forall a. (Data a, Q.Arbitrary a, Show a)
=> SubT { unSubT :: a }
+-- instance Eq SubT where
+-- SubT a == SubT b = cast a == Just b
+
instance Show SubT where
show (SubT t) = show t

0 comments on commit 77a9e36

Please sign in to comment.