module Test.SmartCheck.ConstructorGen
( constrsGen
) where
import Test.SmartCheck.Args
import Test.SmartCheck.Types
import Test.SmartCheck.DataToTree
import Test.SmartCheck.SmartGen
import Test.SmartCheck.Render
import Prelude hiding (max)
import Generics.Deriving
import qualified Data.Set as S
import Data.List
import Control.Monad (liftM)
import qualified Test.QuickCheck as Q
constrsGen :: (SubTypes a, Generic a, ConNames (Rep a))
=> ScArgs -> a -> (a -> Q.Property) -> [Idx] -> IO [Idx]
constrsGen args d prop vs = do
putStrLn ""
smartPrtLn "Extrapolating Constructors ..."
(_, idxs) <- iter' forest (Idx 0 0) []
return idxs
where
forest = let forest' = mkSubstForest d True in
foldl' (\f idx -> forestReplaceChildren f idx False) forest' vs
iter' = iter d test next prop (scMaxDepth args)
test x idx = do res <- extrapolateConstrs args x idx prop
return $ idx `notElem` vs && res
next _ res forest' idx idxs =
iter' (if res then forestReplaceChildren forest' idx False else forest')
idx { column = column idx + 1 } idxs'
where
idxs' = if res then idx : idxs else idxs
extrapolateConstrs :: (SubTypes a, Generic a, ConNames (Rep a))
=> ScArgs -> a -> Idx -> (a -> Q.Property) -> IO Bool
extrapolateConstrs args a idx prop =
recConstrs $ S.singleton $ subConstr a idx $ scMaxDepth args
where
notProp = Q.expectFailure . prop
allConstrs = S.fromList (conNames a)
recConstrs :: S.Set String -> IO Bool
recConstrs constrs =
let newConstr x = subConstr x idx (scMaxDepth args) `S.insert` constrs in
if allConstrs `S.isSubsetOf` constrs
then return True
else do v <- arbSubset args a idx notProp constrs
case v of
Result x -> recConstrs (newConstr x)
FailedPreCond -> return False
FailedProp -> return False
BaseType -> return False
arbSubset :: (SubTypes a, Generic a, ConNames (Rep a))
=> ScArgs -> a -> Idx -> (a -> Q.Property)
-> S.Set String -> IO (Result a)
arbSubset args a idx prop constrs =
liftM snd $ iterateArbIdx a (idx, scMaxDepth args)
(scMaxExists args) (scMaxSize args) prop'
where
prop' b = newConstr b Q.==> prop b
newConstr b = not $ subConstr b idx (scMaxDepth args) `S.member` constrs
subConstr :: SubTypes a => a -> Idx -> Maybe Int -> String
subConstr x idx max =
case getAtIdx x idx max of
Nothing -> errorMsg "constrs'"
Just x' -> subTconstr x'
where
subTconstr (SubT v) = toConstr v