smartcheck 0.2 → 0.2.1
raw patch · 8 files changed
+54/−90 lines, 8 files
Files
- smartcheck.cabal +1/−1
- src/Test/SmartCheck.hs +6/−4
- src/Test/SmartCheck/ConstructorGen.hs +2/−1
- src/Test/SmartCheck/Matches.hs +2/−1
- src/Test/SmartCheck/Reduce.hs +3/−2
- src/Test/SmartCheck/SmartGen.hs +9/−5
- src/Test/SmartCheck/Test.hs +2/−0
- src/Test/SmartCheck/Types.hs +29/−76
smartcheck.cabal view
@@ -1,5 +1,5 @@ Name: smartcheck-Version: 0.2+Version: 0.2.1 Synopsis: A smarter QuickCheck. Homepage: https://github.com/leepike/SmartCheck Description: See the README.md.
src/Test/SmartCheck.hs view
@@ -25,7 +25,7 @@ , grc , gtc , gsf- , gsz+-- , gsz ) where import Test.SmartCheck.Args@@ -69,9 +69,9 @@ , Generic a, ConNames (Rep a) ) => ScArgs -> (Maybe a, a -> Q.Property) -> IO () smartCheckRun args (origMcex, origProp) = do- smartPrtLn $- "(If any stage takes too long, try modifying SmartCheck's standard "- ++ "arguments (see Args.hs).)"+ putStrLn ""+ smartPrtLn $ "Analyzing the first argument of the property with SmartCheck..."+ smartPrtLn $ "(If any stage takes too long, modify SmartCheck's arguments.)" smartCheck' [] origMcex origProp where smartCheck' :: [(a, Replace Idx)]@@ -162,6 +162,8 @@ runQC :: forall a prop . (Show a, Q.Arbitrary a, Q.Testable prop) => Q.Args -> (a -> prop) -> IO (Maybe a, a -> Q.Property) runQC args scProp = do+ smartPrtLn "Finding a counterexample with QuickCheck..."+-- smartPrtLn " (mCex, res) <- scQuickCheckWithResult args scProp return $ if failureRes res then (mCex, Q.property . scProp)
src/Test/SmartCheck/ConstructorGen.hs view
@@ -57,7 +57,7 @@ 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))+ recConstrs $ S.singleton $ subConstr a idx $ scMaxDepth args where notProp = Q.expectFailure . prop allConstrs = S.fromList (conNames a)@@ -73,6 +73,7 @@ Result x -> recConstrs (newConstr x) FailedPreCond -> return False FailedProp -> return False+ BaseType -> return False --------------------------------------------------------------------------------
src/Test/SmartCheck/Matches.hs view
@@ -25,6 +25,7 @@ -- their structures. matchesShape :: forall a . SubTypes a => a -> (a, Replace Idx) -> Bool matchesShape a (b, Replace idxVals idxConstrs)+ | baseType a && baseType b = True | toConstr a /= toConstr b = False | Just a' <- aRepl = let x = subTypes a' in let y = subTypes b in@@ -34,7 +35,7 @@ where foldEqConstrs :: (Tree SubT, Tree SubT) -> Bool foldEqConstrs (Node (SubT l0) sts0, Node (SubT l1) sts1)- -- Don't need a baseType test, since they don't ever appear in subTypes.+ | baseType l0 && baseType l1 = next | toConstr l0 == toConstr l1 = next | otherwise = False where next = all foldEqConstrs (zip sts0 sts1)
src/Test/SmartCheck/Reduce.hs view
@@ -54,8 +54,8 @@ next :: a -> Maybe a -> Forest Bool -> Idx -> [Idx] -> IO (a, [Idx]) next x res forest idx _ = case res of- -- Found a try that fails prop. We'll now test try, and start trying to- -- reduce from the top!+ -- Found an ex that fails prop. We'll now test the ex, and start trying+ -- to reduce from the top! Just y -> iter' y (mkForest y) (Idx 0 0) -- Either couldn't satisfy the precondition or nothing satisfied the -- property. Either way, we can't shrink it.@@ -97,6 +97,7 @@ resultToMaybe :: Result a -> Maybe a resultToMaybe res = case res of+ BaseType -> Nothing FailedPreCond -> Nothing FailedProp -> Nothing Result n -> Just n
src/Test/SmartCheck/SmartGen.hs view
@@ -27,9 +27,12 @@ => a -> (Idx, Maybe Int) -> Int -> Int -> (a -> P.Property) -> IO (Int, Result a) iterateArbIdx d (idx, max) tries sz prop =- maybe (errorMsg "iterateArb 0")- (\ext -> iterateArb d ext idx tries sz prop)- (getAtIdx d idx max)+ case getAtIdx d idx max of+ Nothing -> errorMsg "iterateArb 0"+ Just ext -> case ext of+ -- Don't analyze base types.+ SubT e -> if baseType e then return (0, BaseType)+ else iterateArb d ext idx tries sz prop -- | Replace the hole in d indexed by idx with a bunch of random values, and -- test the new d against the property. Returns the first new d (the full d but@@ -70,9 +73,10 @@ Just d' -> do res' <- resultify prop d' case res' of- FailedPreCond -> rec (i, FailedPreCond)- FailedProp -> rec (i+1, FailedProp)+ FailedPreCond -> rec (i , FailedPreCond)+ FailedProp -> rec (i+1, FailedProp) Result x -> return (i+1, Result x)+ BaseType -> errorMsg "baseType from resultify" where (size, g0) = randomR (0, currMax) g sample SubT { unSubT = v } = newVal v
src/Test/SmartCheck/Test.hs view
@@ -364,6 +364,8 @@ [ putLine (terminal st) msg | msg <- lines (P.reason res) ]+ putLine (terminal st) "*** Non SmartChecked arguments:"+ callbackPostFinalFailure st res return (numSuccessShrinks st, numTotTryShrinks st - numTryShrinks st, numTryShrinks st)
src/Test/SmartCheck/Types.hs view
@@ -20,7 +20,7 @@ , grc , gtc , gsf- , gsz+-- , gsz ) where import GHC.Generics@@ -49,29 +49,32 @@ -------------------------------------------------------------------------------- -- | Possible results of iterateArb.-data Result a = FailedPreCond -- ^ Couldn't satisfy the precondition of a- -- QuickCheck property- | FailedProp -- ^ Failed the property---either we expect- -- failure and it passes or we expect to pass it- -- and we fail.- | Result a -- ^ Satisfied it, with the satisfying value.+data Result a =+ BaseType -- ^ Base type. Won't analyze.+ | FailedPreCond -- ^ Couldn't satisfy the precondition of a QuickCheck+ -- property+ | FailedProp -- ^ Failed the property---either we expect failure and it+ -- passes or we expect to pass it and we fail.+ | Result a -- ^ Satisfied it, with the satisfying value. deriving (Show, Read, Eq) instance Functor Result where+ fmap _ BaseType = BaseType 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+ BaseType >>= _ = BaseType FailedPreCond >>= _ = FailedPreCond FailedProp >>= _ = FailedProp Result a >>= f = f a +instance Applicative Result where+ pure = return+ (<*>) = ap+ ------------------------------------------------------------------------------- -- Indexing -------------------------------------------------------------------------------@@ -124,11 +127,13 @@ -- class (Q.Arbitrary a, Show a, Typeable a) => SubTypes a where -----------------------------------------------------------+ -- | Turns algebraic data into a forest representation. subTypes :: a -> Forest SubT default subTypes :: (Generic a, GST (Rep a)) => a -> Forest SubT subTypes = gst . from -----------------------------------------------------------+ -- | Base types (e.g., Int, Char) aren't analyzed. baseType :: a -> Bool baseType _ = False -----------------------------------------------------------@@ -140,25 +145,16 @@ => a -> Forest Subst -> b -> Maybe a replaceChild a forest b = fmap to $ grc (from a) forest b ------------------------------------------------------------ -- Grab the top contructor.+ -- | Get the string representation of the constructor. toConstr :: a -> String default toConstr :: (Generic a, GST (Rep a)) => a -> String toConstr = gtc . from ----------------------------------------------------------- -- | showForest generically shows a value while preserving its structure (in a- -- Tree). You should always end up with either a singleton list containing- -- the tree or an empty list for baseTypes. Also, it must be the case that- -- for a value v,- --- -- null (subTypes v) iff null (showForest v)- -- and- -- if not . null (subTypes v), then subForest . head (showForest v)- -- has the same structure as subTypes v.- --- -- We can't just return a Tree String or Maybe (Tree String). The reason is- -- that in generically constructing the value, we have to deal with product- -- types. There is no sane way to join them other than list-like- -- concatenation (i.e., gsf (a :*: b) = gsf a ++ gsf b).+ -- Tree). Always returns either a singleton list containing the tree (a+ -- degenerate forest) or an empty list for baseTypes. An invariant is that+ -- the shape of the tree produced by showForest is the same as the one+ -- produced by subTypes. showForest :: a -> Forest String default showForest :: (Generic a, GST (Rep a)) => a -> Forest String@@ -222,18 +218,7 @@ grc (M1 a) forest c = grc a forest c >>= return . M1 gtc = conName - gsf m@(M1 a) = [ tree ]- where- -- When a tree has reached a constructor with a baseType value (e.g., A 3- -- for some constructor A), we want to show the constructor and the value,- -- but not have a subForest. So we check if the rest is a baseType (gst a- -- tells us that), and if so, we show the conName, and extract (rootLabel- -- . head) (gsf a), which is basically just showing the rest (look at gsf- -- (K1 a) below). Otherwise, we just want the constructor.- 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)+ gsf m@(M1 a) = [ Node (conName m) (gsf a) ] gsz (M1 a) = gsz a @@ -247,7 +232,7 @@ instance (Show a, Q.Arbitrary a, SubTypes a, Typeable a) => GST (K1 i a) where gst (K1 a) = if baseType a- then []+ then [ Node (subT a) [] ] else [ Node (subT a) (subTypes a) ] grc (K1 a) forest c =@@ -259,16 +244,13 @@ gtc _ = "" - -- Yes, this is right. For a baseType value v, showForest v will just yield- -- [] using showForest'. But to make the tree using generics, when we get- -- down to baseTypes, we need to actually show them, returing a Forest. We- -- extract the value in the rootLabel above.- gsf (K1 a) = if baseType a then [Node (show a) []] else showForest a+ gsf (K1 a) = if baseType a then [ Node (show a) [] ] else showForest a - gsz (K1 a) = if baseType a then 0 else 1+ gsz _ = 1 ---------------------------------------------------------------------------------- We try to cover the instances supported by QuickCheck: http://hackage.haskell.org/packages/archive/QuickCheck/2.4.2/doc/html/Test-QuickCheck-Arbitrary.html+-- We cover the instances supported by QuickCheck:+-- http://hackage.haskell.org/packages/archive/QuickCheck/2.4.2/doc/html/Test-QuickCheck-Arbitrary.html instance SubTypes Bool where baseType _ = True instance SubTypes Char where baseType _ = True@@ -336,38 +318,9 @@ toConstr = toConstr' showForest = showForest' instance SubTypes () where baseType _ = True----instance (Q.Arbitrary a, SubTypes a, Typeable a) => SubTypes [a]--- subTypes = concatMap subTypes--- baseType _ = True--- replaceChild = replaceChild'--- toConstr = toConstr'--- -- toConstrAndBase = toConstrAndBase'--- showForest = showForest'---- For example, this makes String a baseType automatically.--- instance (Q.Arbitrary a, SubTypes a, Typeable a) => SubTypes [a] where--- subTypes = if baseType (undefined :: a) then \_ -> []--- else gst . from--- baseType _ = baseType (undefined :: a)--- replaceChild x forest y = if baseType (undefined :: a)--- then replaceChild' x forest y--- else fmap to $ grc (from x) forest y--- toConstr = if baseType (undefined :: a) then toConstr'--- else gtc . from--- showForest = if baseType (undefined :: a) then showForest'--- else gsf . from---- For example, this makes String a baseType automatically.-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 ( Q.Arbitrary a, SubTypes a, Typeable a) => SubTypes [a] instance (Integral a, Q.Arbitrary a, SubTypes a, Typeable a)- => SubTypes (Ratio a) where+ => SubTypes (Ratio a) where subTypes _ = [] baseType _ = True replaceChild = replaceChild'