Permalink
Browse files

Use GHC.Generics to implement the SubTypes class generically.

  • Loading branch information...
1 parent 19483ad commit 1269ec474e23a77fc9e6c9a1017a0f19ab1ad347 @leepike committed May 10, 2012
View
@@ -1,4 +1,5 @@
{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE DeriveGeneric #-}
-- | Divide by 0 example in a simple arithmetic language.
@@ -8,22 +9,15 @@ import Test.QuickCheck
import Test.SmartCheck
import Control.Monad
import Data.Data
-import Data.Tree
+
+import GHC.Generics
data M = C Int
| A M M
| D M M
- deriving (Read, Show, Data, Typeable, Eq)
-
-mkTypes :: M -> M -> Forest SubT
-mkTypes m0 m1 = [ Node (subT m0) (subTypes m0)
- , Node (subT m1) (subTypes m1)
- ]
+ deriving (Read, Show, Data, Typeable, Eq, Generic)
-instance SubTypes M where
- subTypes (C _) = []
- subTypes (A m0 m1) = mkTypes m0 m1
- subTypes (D m0 m1) = mkTypes m0 m1
+instance SubTypes M
eval :: M -> Maybe Int
eval (C i) = Just i
@@ -45,9 +39,9 @@ instance Arbitrary M where
, liftM2 D mkM' mkM' ]
where mkM' = mkM =<< choose (0,n-1)
- shrink (C _) = []
- shrink (A a b) = [a, b]
- shrink (D a b) = [a, b]
+ -- shrink (C _) = []
+ -- shrink (A a b) = [a, b]
+ -- shrink (D a b) = [a, b]
-- property: so long as 0 isn't in the divisor, we won't try to divide by 0.
-- It's false: something might evaluate to 0 still.
@@ -67,8 +61,9 @@ divTest :: IO ()
divTest = smartCheck args div1
where
args = scStdArgs { qcArgs = stdArgs
- { maxSuccess = 100
+ { maxSuccess = 1000
, maxSize = 20 }
+ , treeShow = PrntString
}
---------------------------------------------------------------------------------
View
@@ -1,4 +1,6 @@
{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE DeriveGeneric #-}
module MutualRecData where
@@ -9,40 +11,25 @@ import Data.Tree
import Data.Data
import Control.Monad.State
+import GHC.Generics
+
---------------------------------------------------------------------------------
data M = M N N Int
| P
- deriving (Data, Typeable, Show, Eq, Read)
+ deriving (Data, Typeable, Show, Eq, Read, Generic)
+
+instance SubTypes M
data N = N M Int String
- deriving (Data, Typeable, Show, Eq, Read)
+ deriving (Data, Typeable, Show, Eq, Read, Generic)
-data O = O N String
- deriving (Data, Typeable, Show, Eq, Read)
+instance SubTypes N
----------------------------------------------------------------------------------
+data O = O N String
+ deriving (Data, Typeable, Show, Eq, Read, Generic)
-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 SubTypes O
---------------------------------------------------------------------------------
@@ -43,7 +43,7 @@ getLevel fs n = concatMap (\fs' -> getLevel (subForest fs') (n-1)) fs
---------------------------------------------------------------------------------
--- | Get the depth of a Forest.
+-- | Get the depth of a Forest. 0-based (an empty Forest has depth 0).
depth :: Forest a -> Int
depth forest = if null ls then 0 else maximum ls
where
@@ -93,7 +93,7 @@ getAtIdx d Idx { level = l
, column = c }
= if length lev > c then Just (lev !! c) else Nothing
where
- lev = getLevel (subTypes d) l
+ lev = getLevel (forestRep d) l
---------------------------------------------------------------------------------
@@ -157,7 +157,7 @@ sub args forest idx a =
-- | Make a substitution Forest (all proper children). Initially we don't
-- replace anything.
mkSubstForest :: SubTypes a => a -> Forest Subst
-mkSubstForest a = map tMap (subTypes a)
+mkSubstForest a = map tMap (forestRep a)
where tMap t = fmap (\_ -> Keep) t
---------------------------------------------------------------------------------
@@ -123,7 +123,7 @@ matchesShape a b idxs =
v <- getAtIdx a idx
replace b' idx v
- nextLevel x = map rootLabel (subTypes x)
+ nextLevel x = map rootLabel (forestRep x)
test (SubT x, SubT y) =
if isAlgType (dataTypeOf x)
@@ -50,6 +50,10 @@ smartShrink args d prop = iterReduce args d (Idx 0 0) notProp
iterReduce :: SubTypes a
=> Q.Args -> a -> Idx -> (a -> Q.Property) -> IO a
iterReduce args d idx prop = do
+ -- putStrLn (show d)
+ -- putStrLn (show idx)
+ -- putStrLn (show maxSize)
+
if done then return d
else if nextLevel
then iterReduce args d idx { column = 0
@@ -69,11 +73,8 @@ iterReduce args d idx prop = do
else mkTry args d idx prop (fromJust maxSize)
where
- -- Extract a tree from a forest and make sure it's big enough.
+ -- Extract a tree from a forest and make sure it's big enough to test.
--
- -- 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
@@ -90,15 +91,21 @@ iterReduce args d idx prop = do
mkTry :: forall a. SubTypes a
=> Q.Args -> a -> Idx -> (a -> Q.Property) -> Int -> IO a
mkTry args d idx prop maxSize = do
+ -- YYY
+ -- putStrLn (show d)
+ -- putStrLn (show idx)
+ -- putStrLn (show maxSize)
+
v <- mv
- if (isJust v) -- This sees if some subterm directly fails the property. If
- -- so, we'll take it, if it's well-typed.
+ if isJust v -- This sees if some subterm directly fails the property. If so,
+ -- we'll take it, if it's well-typed.
then iterReduce args (fromJust v) (Idx 0 0) prop
else do try <- iterateArb d idx (Q.maxDiscard args)
maxSize prop
case try of
-- Found a try that fails prop. We'll now test try, and start trying to
-- reduce from the top!
+ -- YYY
Result x -> iterReduce args x (Idx 0 0) prop
-- Either couldn't satisfy the precondition or nothing
-- satisfied the property. Either way, we can't shrink it.
@@ -1,16 +1,31 @@
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+-- {-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ExistentialQuantification #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE DefaultSignatures #-}
+
module Test.SmartCheck.Types
( SubT(..)
, subT
- , SubTypes(..)
+ , SubTypes(..) -- ^ The subTypes method should only be called for rendering.
+ -- Otherwise, use forestRep, which removes "base types" like
+ -- Int, Char, etc. --- unary constructors.
, Idx(..)
, Subst(..)
, ScArgs(..)
, Format(..)
, scStdArgs
+ , forestRep
) where
+import GHC.Generics
+
+import Data.List
import Data.Tree
import Data.Data
@@ -37,39 +52,92 @@ scStdArgs = ScArgs { chatty = False
}
---------------------------------------------------------------------------------
+-- 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 Eq
+
+instance Show Idx where
+ show (Idx l c) = foldr1 (++) ["Idx ", show l, " ", show c]
+
+-- | Keep or substitue a value in the tree.
+data Subst = Keep | Subst
+ deriving (Show, Eq, Read)
+
+---------------------------------------------------------------------------------
-- User-defined subtypes of data
---------------------------------------------------------------------------------
data SubT = forall a. (Data a, Q.Arbitrary a, Show a)
=> SubT { unSubT :: a }
+subT :: (Data a, Q.Arbitrary a, Show a) => a -> SubT
+subT = SubT
+
-- instance Eq SubT where
-- SubT a == SubT b = cast a == Just b
instance Show SubT where
show (SubT t) = show t
-subT :: (Data a, Q.Arbitrary a, Show a) => a -> SubT
-subT = SubT
-
class (Show a, Data a) => SubTypes a where
subTypes :: a -> Forest SubT
+ default subTypes :: (Generic a, GST (Rep a)) => a -> Forest SubT
+ subTypes = gst . from
+
---------------------------------------------------------------------------------
--- Indexing
+-- Generic representation
---------------------------------------------------------------------------------
--- | 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 Eq
+class GST f where
+ gst :: f a -> Forest SubT
-instance Show Idx where
- show (Idx l c) = foldr1 (++) ["Idx ", show l, " ", show c]
+instance GST U1 where
+ gst U1 = []
--- | Keep or substitue a value in the tree.
-data Subst = Keep | Subst
- deriving (Show, Eq, Read)
+instance (GST a, GST b) => GST (a :*: b) where
+ gst (a :*: b) = gst a ++ gst b
+
+instance (GST a, GST b) => GST (a :+: b) where
+ gst (L1 a) = gst a
+ gst (R1 b) = gst b
+
+instance GST a => GST (M1 i c a) where
+ gst (M1 x) = gst x
+
+instance (Show a, Data a, Q.Arbitrary a, SubTypes a) => GST (K1 i a) where
+ gst (K1 x) = [ Node (subT x) (subTypes x) ]
+ where
+
+---------------------------------------------------------------------------------
+
+mkSubT :: (Data a, Q.Arbitrary a, Show a) => a -> Forest SubT
+mkSubT i = [ Node (subT i) [] ]
+
+instance SubTypes Bool where subTypes _ = []
+instance SubTypes Int where subTypes _ = []
+instance SubTypes Char where subTypes _ = []
+
+--instance SubTypes String where subTypes = concatMap mkSubT
+
+instance (Q.Arbitrary a, SubTypes a) => SubTypes ([] a) where
+ subTypes = concatMap mkSubT
+
+---------------------------------------------------------------------------------
+
+-- | Remove all Nodes that contain no subforests from a Forest.
+remEmptySubF :: Forest a -> Forest a
+remEmptySubF ls = reverse (foldl' f [] ls)
+ where
+ f acc (Node _ []) = acc
+ f acc (Node y forest') = Node y (remEmptySubF forest') : acc
+
+forestRep :: SubTypes a => a -> Forest SubT
+forestRep = remEmptySubF . subTypes
---------------------------------------------------------------------------------

0 comments on commit 1269ec4

Please sign in to comment.