module Test.SmartCheck.Types
( SubT(..)
, subT
, Result(..)
, SubTypes(..)
, Idx(..)
, Subst(..)
, Replace(..)
, errorMsg
, gst
, grc
, gtc
, gsf
, gsz
) where
import GHC.Generics
import Data.Tree
import Data.Typeable
import Control.Applicative
import Control.Monad (ap)
import Data.Word
import Data.Int
import Data.Ratio
import Data.Complex
import qualified Test.QuickCheck as Q
data Replace a = Replace { unVals :: [a], unConstrs :: [a] }
deriving (Show, Read, Eq)
data Result a = FailedPreCond
| FailedProp
| Result a
deriving (Show, Read, Eq)
instance Functor Result where
fmap _ FailedPreCond = FailedPreCond
fmap _ FailedProp = FailedProp
fmap f (Result a) = Result (f a)
instance Applicative Result where
pure = return
(<*>) = ap
instance Monad Result where
return a = Result a
FailedPreCond >>= _ = FailedPreCond
FailedProp >>= _ = FailedProp
Result a >>= f = f a
data Idx = Idx { level :: Int, column :: Int }
deriving Eq
instance Show Idx where
show (Idx l c) = foldr1 (++) ["Idx ", show l, " ", show c]
data Subst = Keep | Subst
deriving (Show, Eq, Read)
instance Ord Idx where
compare (Idx l0 c0) (Idx l1 c1) | l0 < l1 = LT
| l0 > l1 = GT
| c0 < c1 = LT
| c0 > c1 = GT
| True = EQ
data SubT = forall a. (Q.Arbitrary a, SubTypes a)
=> SubT { unSubT :: a }
subT :: (Q.Arbitrary a, SubTypes a) => a -> SubT
subT = SubT
instance Show SubT where
show (SubT t) = show t
class (Q.Arbitrary a, Show a, Typeable a) => SubTypes a where
subTypes :: a -> Forest SubT
default subTypes :: (Generic a, GST (Rep a))
=> a -> Forest SubT
subTypes = gst . from
baseType :: a -> Bool
baseType _ = False
replaceChild :: Typeable b => a -> Forest Subst -> b -> Maybe a
default replaceChild :: (Generic a, GST (Rep a), Typeable b)
=> a -> Forest Subst -> b -> Maybe a
replaceChild a forest b = fmap to $ grc (from a) forest b
toConstr :: a -> String
default toConstr :: (Generic a, GST (Rep a)) => a -> String
toConstr = gtc . from
showForest :: a -> Forest String
default showForest :: (Generic a, GST (Rep a))
=> a -> Forest String
showForest = gsf . from
class GST f where
gst :: f a -> Forest SubT
grc :: Typeable b => f a -> Forest Subst -> b -> Maybe (f a)
gtc :: f a -> String
gsf :: f a -> Forest String
gsz :: f a -> Int
instance GST U1 where
gst U1 = []
grc _ _ _ = Nothing
gtc U1 = ""
gsf U1 = []
gsz U1 = 0
instance (GST a, GST b) => GST (a :*: b) where
gst (a :*: b) = gst a ++ gst b
grc (a :*: b) forest c =
case forest of
[] -> Just (a :*: b)
ls -> do let (x,y) = splitAt (gsz a) ls
left <- grc a x c
right <- grc b y c
return $ left :*: right
gtc (a :*: b) = gtc a ++ gtc b
gsf (a :*: b) = gsf a ++ gsf b
gsz (a :*: b) = gsz a + gsz b
instance (GST a, GST b) => GST (a :+: b) where
gst (L1 a) = gst a
gst (R1 b) = gst b
grc (L1 a) forest c = grc a forest c >>= return . L1
grc (R1 a) forest c = grc a forest c >>= return . R1
gtc (L1 a) = gtc a
gtc (R1 a) = gtc a
gsf (L1 a) = gsf a
gsf (R1 a) = gsf a
gsz (L1 a) = gsz a
gsz (R1 a) = gsz a
instance (Constructor c, GST a) => GST (M1 C c a) where
gst (M1 a) = gst a
grc (M1 a) forest c = grc a forest c >>= return . M1
gtc = conName
gsf m@(M1 a) = [ tree ]
where
tree | null (gst a) = Node root []
| otherwise = Node (conName m) (gsf a)
root | null (gsf a) = conName m
| otherwise = conName m ++ " " ++ (rootLabel . head) (gsf a)
gsz (M1 a) = gsz a
instance GST a => GST (M1 i k a) where
gst (M1 a) = gst a
grc (M1 a) forest c = grc a forest c >>= return . M1
gtc (M1 a) = gtc a
gsf (M1 a) = gsf a
gsz (M1 a) = gsz a
instance (Show a, Q.Arbitrary a, SubTypes a, Typeable a) => GST (K1 i a) where
gst (K1 a) = if baseType a
then []
else [ Node (subT a) (subTypes a) ]
grc (K1 a) forest c =
case forest of
[] -> Just (K1 a)
(Node Keep _ : _) -> Just (K1 a)
(Node Subst [] : _) -> fmap K1 (cast c)
(Node Subst ls : _) -> replaceChild a ls c >>= return . K1
gtc _ = ""
gsf (K1 a) = if baseType a then [Node (show a) []] else showForest a
gsz (K1 a) = if baseType a then 0 else 1
instance SubTypes Bool where baseType _ = True
instance SubTypes Char where baseType _ = True
instance SubTypes Double where baseType _ = True
instance SubTypes Float where baseType _ = True
instance SubTypes Int where baseType _ = True
instance SubTypes Integer where
subTypes _ = []
baseType _ = True
replaceChild = replaceChild'
toConstr = toConstr'
showForest = showForest'
instance SubTypes Int8 where
subTypes _ = []
baseType _ = True
replaceChild = replaceChild'
toConstr = toConstr'
showForest = showForest'
instance SubTypes Int16 where
subTypes _ = []
baseType _ = True
replaceChild = replaceChild'
toConstr = toConstr'
showForest = showForest'
instance SubTypes Int32 where
subTypes _ = []
baseType _ = True
replaceChild = replaceChild'
toConstr = toConstr'
showForest = showForest'
instance SubTypes Int64 where
subTypes _ = []
baseType _ = True
replaceChild = replaceChild'
toConstr = toConstr'
showForest = showForest'
instance SubTypes Word where
subTypes _ = []
baseType _ = True
replaceChild = replaceChild'
toConstr = toConstr'
showForest = showForest'
instance SubTypes Word8 where
subTypes _ = []
baseType _ = True
replaceChild = replaceChild'
toConstr = toConstr'
showForest = showForest'
instance SubTypes Word16 where
subTypes _ = []
baseType _ = True
replaceChild = replaceChild'
toConstr = toConstr'
showForest = showForest'
instance SubTypes Word32 where
subTypes _ = []
baseType _ = True
replaceChild = replaceChild'
toConstr = toConstr'
showForest = showForest'
instance SubTypes Word64 where
subTypes _ = []
baseType _ = True
replaceChild = replaceChild'
toConstr = toConstr'
showForest = showForest'
instance SubTypes () where baseType _ = True
instance (Q.Arbitrary a, SubTypes a, Typeable a) => SubTypes [a] where
subTypes = gst . from
baseType _ = False
replaceChild x forest y = fmap to $ grc (from x) forest y
toConstr = gtc . from
showForest = gsf . from
instance (Integral a, Q.Arbitrary a, SubTypes a, Typeable a)
=> SubTypes (Ratio a) where
subTypes _ = []
baseType _ = True
replaceChild = replaceChild'
toConstr = toConstr'
showForest = showForest'
instance (RealFloat a, Q.Arbitrary a, SubTypes a, Typeable a)
=> SubTypes (Complex a) where
subTypes _ = []
baseType _ = True
replaceChild = replaceChild'
toConstr = toConstr'
showForest = showForest'
instance (Q.Arbitrary a, SubTypes a, Typeable a) => SubTypes (Maybe a)
instance ( Q.Arbitrary a, SubTypes a, Typeable a
, Q.Arbitrary b, SubTypes b, Typeable b)
=> SubTypes (Either a b)
instance ( Q.Arbitrary a, SubTypes a, Typeable a
, Q.Arbitrary b, SubTypes b, Typeable b)
=> SubTypes (a, b)
instance ( Q.Arbitrary a, SubTypes a, Typeable a
, Q.Arbitrary b, SubTypes b, Typeable b
, Q.Arbitrary c, SubTypes c, Typeable c)
=> SubTypes (a, b, c)
instance ( Q.Arbitrary a, SubTypes a, Typeable a
, Q.Arbitrary b, SubTypes b, Typeable b
, Q.Arbitrary c, SubTypes c, Typeable c
, Q.Arbitrary d, SubTypes d, Typeable d)
=> SubTypes (a, b, c, d)
instance ( Q.Arbitrary a, SubTypes a, Typeable a
, Q.Arbitrary b, SubTypes b, Typeable b
, Q.Arbitrary c, SubTypes c, Typeable c
, Q.Arbitrary d, SubTypes d, Typeable d
, Q.Arbitrary e, SubTypes e, Typeable e)
=> SubTypes (a, b, c, d, e)
toConstr' :: Show a => a -> String
toConstr' = show
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
showForest' :: Show a => a -> Forest String
showForest' _ = []
errorMsg :: String -> a
errorMsg loc = error $ "SmartCheck error: unexpected error in " ++ loc
++ ". Please file a bug report at "
++ "<https://github.com/leepike/SmartCheck/issues>."