Permalink
Browse files

Refactoring, modifying prettying-printing of extrapolated data.

  • Loading branch information...
leepike committed May 3, 2012
1 parent 0ef74b8 commit 1d16a534e4bf8cd20fb4aea7d43a8ad6fc7a5ee1
View
@@ -4,10 +4,11 @@
module Div0 where
-import Test.QuickCheck
+import Test.QuickCheck
import Test.SmartCheck
import Control.Monad
import Data.Data
+import Data.Tree
data M = C Int
| A M M
@@ -64,7 +65,10 @@ div1 m = divSubTerms m ==> eval m /= Nothing
main :: IO ()
main = smartCheck args div1
- where args = stdArgs { maxSuccess = 100
- , maxSize = 20 }
+ where
+ args = scStdArgs { qcArgs = stdArgs
+ { maxSuccess = 100
+ , maxSize = 20 }
+ }
---------------------------------------------------------------------------------
View
@@ -15,11 +15,12 @@ Cabal-version: >=1.10
Library
Exposed-modules: Test.SmartCheck,
- Test.SmartCheck.Reduce
+ Test.SmartCheck.Reduce,
Test.SmartCheck.Extrapolate,
- Test.SmartCheck.Types
- Test.SmartCheck.Common
- Test.SmartCheck.DataToTree
+ Test.SmartCheck.Types,
+ Test.SmartCheck.Common,
+ Test.SmartCheck.DataToTree,
+ Test.SmartCheck.Render
Build-depends: base >= 4.0,
View
@@ -4,32 +4,29 @@
module Test.SmartCheck
( smartCheck
- , SubT(..)
- , subT
- , SubTypes(..)
- , Tree(..)
- , Forest
+ , module Test.SmartCheck.Types
) where
+import Test.SmartCheck.Types
import Test.SmartCheck.Reduce
import Test.SmartCheck.Extrapolate
-import Test.SmartCheck.Types
-import Test.SmartCheck.Common
+import Test.SmartCheck.Render
import qualified Test.QuickCheck as Q
-import Data.Tree
---------------------------------------------------------------------------------
-- | Main interface function.
smartCheck :: (Read a, Show a, Q.Arbitrary a, SubTypes a)
- => Q.Args -> (a -> Q.Property) -> IO ()
+ => ScArgs -> (a -> Q.Property) -> IO ()
smartCheck args prop = smartCheck' prop []
where
+ qc = qcArgs args
+
smartCheck' prop' ds = do
- res <- runQC args prop'
- d <- smartRun args res prop
+ res <- runQC qc prop'
+ d <- smartRun qc res prop
case d of
Nothing -> continue id ds
-- Extrapolate with the original property to see if we get a
@@ -4,7 +4,6 @@ module Test.SmartCheck.Common
, iterateArb
, extractResult
, resultify
- , smartPrtLn
, replace
) where
@@ -105,11 +104,3 @@ resultify prop a = do
err = error "in propify: should not evaluate."
---------------------------------------------------------------------------------
-
-smartPrefix :: String
-smartPrefix = "*** "
-
-smartPrtLn :: String -> IO ()
-smartPrtLn = putStrLn . (smartPrefix ++)
-
----------------------------------------------------------------------------------
@@ -6,7 +6,6 @@ module Test.SmartCheck.DataToTree
, getAtIdx
, replaceAtIdx
, getIdxForest
- , mkShowTree
, breadthLevels
, mkSubstForest
, depth
@@ -171,13 +170,3 @@ replaceChild d idx s =
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))
-
----------------------------------------------------------------------------------
@@ -2,11 +2,14 @@
module Test.SmartCheck.Extrapolate
( extrapolate
+ -- YYY
+ , renderWithVars
) where
import Test.SmartCheck.Types
import Test.SmartCheck.DataToTree
import Test.SmartCheck.Common
+import Test.SmartCheck.Render
import qualified Test.QuickCheck as Q
@@ -24,20 +27,20 @@ import Data.List
-- any values that fail the precondition of the property (i.e., before the
-- Q.==>). XXX
extrapolate :: SubTypes a
- => Q.Args -- ^ QuickCheck arguments
+ => ScArgs -- ^ Arguments
-> a -- ^ Current failed value
-> (a -> Q.Property) -- ^ Original property
-> [a] -- ^ Previous failed values
-> IO ((a -> Q.Property) -> a -> Q.Property)
extrapolate args d origProp ds = do
putStrLn ""
smartPrtLn "Extrapolating ..."
- idxs <- iter args (mkSubstForest d) d origProp (Idx 0 0) []
+ idxs <- iter (qcArgs args) (mkSubstForest d) d origProp (Idx 0 0) []
if matchesShapes d ds idxs
then do smartPrtLn "Could not extrapolate a new value; done."
return (prop' idxs)
else do smartPrtLn "Extrapolated value:"
- renderWithVars d idxs
+ renderWithVars (treeShow args) d idxs
return (prop' idxs)
where
@@ -122,23 +125,3 @@ matchesShape a b idxs =
else True
---------------------------------------------------------------------------------
--- PrettyPrinting
----------------------------------------------------------------------------------
-
--- | At each index into d from idxs, replace the whole with a fresh value.
-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 False 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 ..]
-
----------------------------------------------------------------------------------
@@ -7,6 +7,7 @@ module Test.SmartCheck.Reduce
import Test.SmartCheck.Types
import Test.SmartCheck.Common
import Test.SmartCheck.DataToTree
+import Test.SmartCheck.Render
import qualified Test.QuickCheck as Q
import Data.Typeable
@@ -0,0 +1,99 @@
+module Test.SmartCheck.Render
+ ( renderWithVars
+ , smartPrtLn
+ ) where
+
+import Test.SmartCheck.Types
+import Test.SmartCheck.DataToTree
+
+import Data.Tree
+import Data.Data
+import Data.List
+
+---------------------------------------------------------------------------------
+
+smartPrefix :: String
+smartPrefix = "*** "
+
+smartPrtLn :: String -> IO ()
+smartPrtLn = putStrLn . (smartPrefix ++)
+
+---------------------------------------------------------------------------------
+
+-- Make a Tree out of a Data value. On each level, we just use the user-defined
+-- Show instance. This is good in that it's what user expects, but it's bad in
+-- that we show the entire subtree at each level.
+--
+-- XXX Also, it's inconsistent since toConstr is not part of the user-defined
+-- show instances.
+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))
+
+---------------------------------------------------------------------------------
+
+renderWithVars :: SubTypes a => Format -> a -> [Idx] -> IO ()
+renderWithVars format d idxs = do
+ putStrLn $ "forall " ++ unwords (take (length idxs) vars) ++ ":"
+ putStrLn ""
+ putStrLn $ replaceWithVars format d idxs vars
+ putStrLn ""
+ where
+ vars = map (\(x,i) -> x ++ show i) $ zip (repeat "x") [0::Int ..]
+
+---------------------------------------------------------------------------------
+
+-- | At each index into d from idxs, replace the whole with a fresh value.
+replaceWithVars :: SubTypes a
+ => Format -> a -> [Idx] -> [String] -> String
+replaceWithVars format d idxs vars =
+ case format of
+ PrntTree -> drawTree $ foldl' f t vis
+ -- We have to be careful here. We can't just show d and then find the
+ -- matching substrings to replace, since the same substring may show up in
+ -- multiple places. Rather, we have to recursively descend down the tree of
+ -- substrings, finding matches, til we hit our variable.
+-- PrntString -> foldl' g (show d) vis
+
+ where
+ t = mkShowTree d
+ vis = zip vars idxs
+
+ f :: Tree String -> (String, Idx) -> Tree String
+ f tree (var, idx) = let forest = sub (subForest tree) idx var False in
+ Node (rootLabel tree) forest
+
+ subF = mkSubstForest d
+
+ g :: String -> (String, Idx) -> String
+ g showTree (var, idx) =
+ let subPath = sub subF idx Subst True in
+ replaceStr showTree var idx subPath
+
+---------------------------------------------------------------------------------
+
+printTree :: Tree String -> String
+printTree (Node str forest) =
+ str ++ " " ++ concatMap printTree' forest
+ where
+ printTree' (Node s []) = s ++ " "
+ printTree' (Node s f) = "(" ++ s ++ ")" --" " ++ concatMap printTree' f ++ ")"
+
+---------------------------------------------------------------------------------
+
+replaceStr :: String -> String -> Idx -> Forest Subst -> String
+replaceStr tree var idx subPath = undefined
+
+---------------------------------------------------------------------------------
+
+-- -- Replace a value in a list.
+-- replaceElem :: Eq a => a -> [a] -> a -> [a]
+-- replaceElem a ls b =
+-- case elemIndex a ls of
+-- Nothing -> ls
+-- Just i -> take i ls ++ b : drop (i+1) ls
+
+---------------------------------------------------------------------------------
@@ -6,6 +6,9 @@ module Test.SmartCheck.Types
, SubTypes(..)
, Idx(..)
, Subst(..)
+ , ScArgs(..)
+ , Format(..)
+ , scStdArgs
) where
import Data.Tree
@@ -16,6 +19,26 @@ import qualified Test.QuickCheck as Q
-- User-defined subtypes of data
---------------------------------------------------------------------------------
+data Format = PrntTree | PrntString
+ deriving (Eq, Read, Show)
+
+data ScArgs =
+ ScArgs { chatty :: Bool -- ^ Verbose output while running SmartCheck
+ , treeShow :: Format -- ^ How to show extrapolated formula
+ , qcArgs :: Q.Args -- ^ QuickCheck arguments
+ }
+ deriving (Show, Read)
+
+scStdArgs :: ScArgs
+scStdArgs = ScArgs { chatty = False
+ , treeShow = PrntTree
+ , qcArgs = Q.stdArgs
+ }
+
+---------------------------------------------------------------------------------
+-- User-defined subtypes of data
+---------------------------------------------------------------------------------
+
data SubT = forall a. (Data a, Q.Arbitrary a, Show a)
=> SubT { unSubT :: a }
@@ -28,7 +51,7 @@ instance Show SubT where
subT :: (Data a, Q.Arbitrary a, Show a) => a -> SubT
subT = SubT
-class Data a => SubTypes a where
+class (Show a, Data a) => SubTypes a where
subTypes :: a -> Forest SubT
---------------------------------------------------------------------------------

0 comments on commit 1d16a53

Please sign in to comment.