Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

Major refactoring.

 * Bug fixes.
 * Complete conversion from Data.Data to GHC.Generics.
  • Loading branch information...
commit 66fd52c966e98f9c0ac348381760e137aad04e3e 1 parent 477bb67
@leepike authored
View
5 README.md
@@ -1,3 +1,8 @@
+**We use [GHC
+ Generics](http://www.haskell.org/ghc/docs/7.4.1/html/libraries/ghc-prim-0.2.0.0/GHC-Generics.html).
+ You may have to define new instances in src/Test/SmartCheck/Types.hs . Email
+ <leepike at Gmail> if you need instances for other types.**
+
Synopsis
--------------------------------
View
1  TODO.md
@@ -26,6 +26,7 @@ TODO
* Make SubT from Forest into Tree(?) More natural and allows to index the head.
+* Check all methods to baseTypes and add additional baseTypes as needed.
Won't Do / Can't Do
-----------------------------------------------
View
5 examples/MutualRecData.hs
@@ -26,11 +26,6 @@ data N = N M Int String
instance SubTypes N
-data O = O N String
- deriving (Data, Typeable, Show, Eq, Read, Generic)
-
-instance SubTypes O
-
---------------------------------------------------------------------------------
instance Arbitrary M where
View
2  smartcheck.cabal
@@ -27,7 +27,7 @@ Library
QuickCheck >= 2.4.2,
mtl >= 2.0.1.0,
random >= 1.0.1.1,
- uniplate >= 1.6.6,
+-- uniplate >= 1.6.6,
containers >= 0.4,
ghc-prim
View
4 src/Test/SmartCheck.hs
@@ -14,12 +14,10 @@ import Test.SmartCheck.Render
import qualified Test.QuickCheck as Q
-import Data.Typeable
-
---------------------------------------------------------------------------------
-- | Main interface function.
-smartCheck :: (Read a, Q.Arbitrary a, SubTypes a, Typeable a)
+smartCheck :: (Read a, Q.Arbitrary a, SubTypes a)
=> ScArgs -> (a -> Q.Property) -> IO ()
smartCheck args prop = smartCheck' prop []
View
2  src/Test/SmartCheck/Common.hs
@@ -57,8 +57,6 @@ iterateArb d idx tries sz prop =
case getAtIdx d idx of
Nothing -> error "iterateArb 0"
Just v -> do rnds <- mkVals v
- -- YYY
- putStrLn "iterateArb"
forM_ rnds (\a -> if isNothing $ replace d idx a
then do putStrLn (show a)
putStrLn (show idx)
View
2  src/Test/SmartCheck/DataToTree.hs
@@ -164,7 +164,7 @@ mkSubstForest a = map tMap (subTypes a)
---------------------------------------------------------------------------------
-- | Replace a value at index idx generically in a Tree/Forest generically.
-replaceAtIdx :: (Typeable b, SubTypes a)
+replaceAtIdx :: (SubTypes a, Typeable b)
=> a -- ^ Parent value
-> Idx -- ^ Index of hole to replace
-> b -- ^ Value to replace with
View
41 src/Test/SmartCheck/Extrapolate.hs
@@ -23,7 +23,7 @@ import Data.List
-- We extrapolate w.r.t. the original property since extrapolation throws away
-- any values that fail the precondition of the property (i.e., before the
-- Q.==>). XXX
-extrapolate :: SubTypes a
+extrapolate :: SubTypes a
=> ScArgs -- ^ Arguments
-> a -- ^ Current failed value
-> (a -> Q.Property) -- ^ Original property
@@ -104,29 +104,20 @@ matchesShapes d ds idxs = foldl' f False ds
-- algebraic constructors only, (3) ignore differences in all values at holes
-- indexed by the indexes.
matchesShape :: SubTypes a => a -> a -> [Idx] -> Bool
-matchesShape a b idxs = error "Fixme-matchesshape"
--- (if isAlgType (dataTypeOf a)
--- -- then toConstr a == toConstr b
--- then error "FIXME-matches1"
--- else True)
--- && repIdxs
-
--- where
--- repIdxs = case foldl' f (Just b) idxs of
--- Nothing -> False
--- 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
--- then error "FIXME-matches2"
--- else True
+matchesShape a b idxs = test (subT a, subT b) && repIdxs
+
+ where
+ repIdxs = case foldl' f (Just b) idxs of
+ Nothing -> False
+ 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) = baseType x || toConstr x == toConstr y
---------------------------------------------------------------------------------
View
19 src/Test/SmartCheck/Reduce.hs
@@ -2,8 +2,6 @@
module Test.SmartCheck.Reduce
(smartRun
- -- YYY
- , smartShrink
) where
import Test.SmartCheck.Types
@@ -12,8 +10,8 @@ import Test.SmartCheck.DataToTree
import Test.SmartCheck.Render
import qualified Test.QuickCheck as Q
-import Data.Typeable
import Data.Tree
+import Data.Typeable
---------------------------------------------------------------------------------
@@ -21,7 +19,7 @@ import Data.Tree
-- 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 :: (SubTypes a, Typeable a)
+smartRun :: SubTypes a
=> Q.Args -> Maybe a -> (a -> Q.Property) -> IO (Maybe a)
smartRun args res prop =
case res of
@@ -43,14 +41,12 @@ smartRun args res prop =
-- | 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 :: (Typeable a, SubTypes a)
- => Q.Args -> a -> (a -> Q.Property) -> IO a
+smartShrink :: SubTypes a => Q.Args -> a -> (a -> Q.Property) -> IO a
smartShrink args d prop = iterReduce args d (Idx 0 0) notProp
where
notProp = Q.expectFailure . prop
-iterReduce :: (Typeable a, SubTypes a)
- => Q.Args -> a -> Idx -> (a -> Q.Property) -> IO a
+iterReduce :: SubTypes a => Q.Args -> a -> Idx -> (a -> Q.Property) -> IO a
iterReduce args d idx prop =
if done then return d
else if nextLevel
@@ -86,14 +82,9 @@ iterReduce args d idx prop =
---------------------------------------------------------------------------------
-mkTry :: forall a. (Typeable a, SubTypes a)
+mkTry :: forall a. SubTypes a
=> Q.Args -> a -> Idx -> (a -> Q.Property) -> Int -> IO a
mkTry args d idx prop maxSize = do
- putStrLn ("mkTry")
- putStrLn (show idx)
- putStrLn (show d)
- putStrLn (show maxSize)
-
v <- mv
case v of
-- This sees if some subterm directly fails the property. If so, we'll take
View
5 src/Test/SmartCheck/Render.hs
@@ -46,7 +46,7 @@ replaceWithVars format d idxs vars =
where
strTree = foldl' f t vis
- t = Node (show $ "FIXME" ) (strForest $ allSubTypes d)
+ t = Node (toConstr d) (strForest $ allSubTypes d)
vis = zip vars idxs
f :: Tree String -> (String, Idx) -> Tree String
@@ -86,8 +86,7 @@ prtTree (Node r forest) =
-- Strips a subforest, including possible parentheses enclosing the
-- expression. Strip trailing whitespace when done.
nubSubForest :: String -> String -> String
- nubSubForest str subTree =
- go [] str
+ nubSubForest str subTree = go [] str
where
go acc [] = reverse acc
View
85 src/Test/SmartCheck/Types.hs
@@ -64,10 +64,10 @@ data Subst = Keep | Subst
-- User-defined subtypes of data
---------------------------------------------------------------------------------
-data SubT = forall a. (Q.Arbitrary a, Show a, Typeable a)
+data SubT = forall a. (Q.Arbitrary a, SubTypes a)
=> SubT { unSubT :: a }
-subT :: (Q.Arbitrary a, Show a, Typeable a) => a -> SubT
+subT :: (Q.Arbitrary a, SubTypes a) => a -> SubT
subT = SubT
-- instance Eq SubT where
@@ -90,7 +90,7 @@ instance Show SubT where
--
-- > allSubTypes (A (C 0) 1)
-- > [Node {rootLabel = C 0, subForest = []},Node {rootLabel = 1, subForest = []}]
-class Show a => SubTypes a where
+class (Q.Arbitrary a, Show a, Typeable a) => SubTypes a where
-----------------------------------------------------------
subTypes :: a -> Forest SubT
default subTypes :: (Generic a, GST (Rep a))
@@ -114,10 +114,15 @@ class Show a => SubTypes a where
=> a -> Forest Subst -> b -> Maybe a
replaceChild a forest b = fmap to $ grp (from a) forest b
-----------------------------------------------------------
+ -- Grab the top contructor.
+ toConstr :: a -> String
+ default toConstr :: (Generic a, GST (Rep a)) => a -> String
+ toConstr = gtc . from
+ -----------------------------------------------------------
-- Grab the contructor and any baseType values that follow.
- toConstrAndBase :: a -> String
- default toConstrAndBase :: (Generic a, GST (Rep a)) => a -> String
- toConstrAndBase = gcb . from
+ -- toConstrAndBase :: a -> String
+ -- default toConstrAndBase :: (Generic a, GST (Rep a)) => a -> String
+ -- toConstrAndBase = gcb . from
-----------------------------------------------------------
---------------------------------------------------------------------------------
@@ -125,23 +130,27 @@ class Show a => SubTypes a where
---------------------------------------------------------------------------------
class GST f where
+ -- Names are abbreviations of the corresponding method names above.
gst :: f a -> Forest SubT
gat :: f a -> Forest SubT
grp :: Typeable b => f a -> Forest Subst -> b -> Maybe (f a)
- gcb :: f a -> String
+ gtc :: f a -> String
+-- gcb :: f a -> String
instance GST U1 where
gst U1 = []
gat U1 = []
grp _ _ _ = Nothing
- gcb U1 = ""
+ gtc U1 = ""
+-- gcb U1 = ""
instance (GST a, GST b) => GST (a :*: b) where
gst (a :*: b) = gst a ++ gst b
gat (a :*: b) = gat a ++ gat b
grp (a :*: b) forest c
- -- If the 1st element is a baseType, we skip it.
+ -- If the 1st element is a baseType, we skip it. Can't use baseTypes
+ -- directly here, so we see if the tree's subforest is empty.
| null (gst a) = grp b forest c >>= \x -> return (a :*: x)
| otherwise =
case forest of
@@ -151,12 +160,16 @@ instance (GST a, GST b) => GST (a :*: b) where
(Node Keep _ : rst) -> do right <- grp b rst c
return $ a :*: right
- gcb (a :*: b) = if null (gst a)
- then if null (gst b)
- then gcb a ++ ' ' : gcb b
- else gcb a
- else if null (gst b) then gcb b
- else ""
+ gtc (a :*: b) = gtc a ++ gtc b
+
+ -- If the element is a baseType, we use it. Can't use baseTypes directly
+ -- here, so we see if the tree's subforest is empty.
+ -- gcb (a :*: b) = if null (gst a)
+ -- then if null (gst b)
+ -- then addSpace (gcb a) (gcb b)
+ -- else gcb a
+ -- else if null (gst b) then gcb b
+ -- else ""
instance (GST a, GST b) => GST (a :+: b) where
gst (L1 a) = gst a
@@ -168,20 +181,25 @@ instance (GST a, GST b) => GST (a :+: b) where
grp (L1 a) forest c = grp a forest c >>= return . L1
grp (R1 a) forest c = grp a forest c >>= return . R1
- gcb (L1 a) = gcb a
- gcb (R1 a) = gcb a
+ gtc (L1 a) = gtc a
+ gtc (R1 a) = gtc a
+
+ -- gcb (L1 a) = gcb a
+ -- gcb (R1 a) = gcb a
instance (Constructor c, GST a) => GST (M1 C c a) where
gst (M1 a) = gst a
gat (M1 a) = gat a
grp (M1 a) forest c = grp a forest c >>= return . M1
- gcb m@(M1 a) = conName m ++ ' ' : gcb a
+ gtc m = conName m
+-- gcb m@(M1 a) = addSpace (conName m) (gcb a)
instance GST a => GST (M1 i k a) where
gst (M1 a) = gst a
gat (M1 a) = gat a
grp (M1 a) forest c = grp a forest c >>= return . M1
- gcb (M1 a) = gcb a
+ gtc (M1 a) = gtc a
+-- gcb (M1 a) = gcb a
instance (Show a, Q.Arbitrary a, SubTypes a, Typeable a) => GST (K1 i a) where
gst (K1 a) = if baseType a then []
@@ -196,8 +214,9 @@ instance (Show a, Q.Arbitrary a, SubTypes a, Typeable a) => GST (K1 i a) where
(Node Subst [] : _) -> fmap K1 (cast c)
(Node Subst ls : _) -> replaceChild a ls c >>= return . K1
- gcb (K1 a) = if baseType a then show a
- else ""
+ gtc _ = ""
+
+ -- gcb (K1 a) = if baseType a then show a else ""
---------------------------------------------------------------------------------
@@ -215,10 +234,9 @@ instance SubTypes Integer where
subTypes _ = []
baseType _ = True
allSubTypes _ = []
- replaceChild a [] _ = Just a
- replaceChild a (Node Keep _ : _) _ = Just a
- replaceChild _ (Node Subst _ : _) b = cast b
- toConstrAndBase a = show a
+ replaceChild = replaceChild'
+ toConstr _ = ""
+-- toConstrAndBase a = show a
instance SubTypes Char where
subTypes _ = []
@@ -229,9 +247,7 @@ instance SubTypes String where
subTypes _ = []
baseType _ = True
allSubTypes _ = []
- replaceChild a [] _ = Just a
- replaceChild a (Node Keep _ : _) _ = Just a
- replaceChild _ (Node Subst _ : _) b = cast b
+ replaceChild = replaceChild'
instance (Q.Arbitrary a, SubTypes a, Typeable a) => SubTypes [a] where
subTypes = concatMap subTypes
@@ -239,3 +255,16 @@ instance (Q.Arbitrary a, SubTypes a, Typeable a) => SubTypes [a] where
allSubTypes = concatMap allSubTypes
---------------------------------------------------------------------------------
+-- Helpers
+
+-- addSpace :: String -> String -> String
+-- addSpace a b = if null b then a else a ++ ' ': b
+
+replaceChild' :: (Typeable a, Typeable b)
+ => a -> Forest Subst -> b -> Maybe a
+replaceChild' a [] _ = Just a
+replaceChild' a (Node Keep _ : _) _ = Just a
+replaceChild' _ (Node Subst _ : _) b = cast b
+
+---------------------------------------------------------------------------------
+
Please sign in to comment.
Something went wrong with that request. Please try again.