From 9a42807d19260eebaef651befac0e5ddcfa7ea3a Mon Sep 17 00:00:00 2001 From: Stevan Andjelkovic Date: Tue, 24 Sep 2024 14:18:07 +0200 Subject: [PATCH] Start adding snippets of the latest version of the code. --- README-unprocessed.md | 18 ++++-- README.md | 134 ++++++++++++++---------------------------- src/QuickCheckV1.hs | 29 +++++++-- 3 files changed, 81 insertions(+), 100 deletions(-) diff --git a/README-unprocessed.md b/README-unprocessed.md index 22d6fdc..42944f7 100644 --- a/README-unprocessed.md +++ b/README-unprocessed.md @@ -238,26 +238,34 @@ using the internal notion of coverage that property-based testing already has? * Edsko de Vries' [Mini-QuickCheck](https://www.well-typed.com/blog/2019/05/integrated-shrinking/) -``` {.haskell include=src/Test.hs snippet=check} +``` {.haskell include=src/QuickCheckV1.hs snippet=Gen} ``` -``` {.haskell include=src/Test.hs snippet=shrink} +``` {.haskell include=src/QuickCheckV1.hs snippet=rand} ``` -``` {.haskell include=src/Test.hs snippet=mutate} +``` {.haskell include=src/QuickCheckV1.hs snippet=sized} ``` -``` {.haskell include=src/Coverage.hs snippet=Coverage} +``` {.haskell include=src/QuickCheckV1.hs snippet=coverCheck} ``` -``` {.haskell include=src/Generator.hs snippet=Gen} +``` {.haskell include=src/QuickCheckV1.hs snippet=testC} ``` +``` {.haskell include=src/QuickCheckV1.hs snippet=testCPrime} +``` + +``` {.haskell include=src/QuickCheckV1.hs snippet=classify} +``` The full source code is available [here](https://github.com/stevana/coverage-guided-pbt). ## Testing some examples with the prototype +``` {.haskell include=src/QuickCheckV1.hs snippet=bad} +``` + ## Conclusion and further work * Makes more sense for stateful systems than pure functions? Or atleast diff --git a/README.md b/README.md index 23c459b..31e412c 100644 --- a/README.md +++ b/README.md @@ -267,109 +267,46 @@ testing already has? [Mini-QuickCheck](https://www.well-typed.com/blog/2019/05/integrated-shrinking/) ``` haskell -type Seed = Int - -type Shrinking = Bool - -checkM :: forall a c. (Show a, Show c) - => Seed -> Int -> Gen a -> (Shrinking -> Coverage c -> [a] -> IO Bool) -> IO () -checkM seed numTests gen p = do - coverage <- emptyCoverage - mShrinkSteps <- go numTests coverage 0 [] - case mShrinkSteps of - Nothing -> do - putStrLn "\nOK" - cov <- readCoverage coverage - putStrLn $ "Coverage: " ++ show cov - Just shrinkSteps -> do - putStrLn $ "Failed: " ++ show (NonEmpty.head shrinkSteps) - putStrLn $ "Shrinking: " ++ show shrinkSteps - putStrLn $ "#Shrinks: " ++ show (NonEmpty.length shrinkSteps - 1) - putStrLn $ "Shrunk: " ++ show (NonEmpty.last shrinkSteps) - cov <- readCoverage coverage - putStrLn $ "Coverage: " ++ show cov - where - go :: Int -> Coverage c -> Int -> [a] -> IO (Maybe (NonEmpty [a])) - go 0 _cov _before _cmds = return Nothing - go n _cov before cmds = do - let sz = n * 3 `div` 2 - let cmd = generate sz (mkStdGen (seed + n)) gen - cmds' <- randomMutation cmds cmd - (ok, after) <- withCoverage (\cov -> p False cov cmds') - if ok - then do - let diff = compareCoverage before after - case diff of - Increased -> do - -- putStr "p" - go (n - 1) _cov after cmds' - Same -> do - -- putStr "p" - go (n - 1) _cov after cmds' - Decreased -> do - -- putStr "." - go (n - 1) _cov before cmds - else do - putStrLn "\n(Where `p` and `.` indicate picked and dropped values respectively.)" - Just <$> shrinker (p True _cov) (shrinkList (const [])) cmds' +newtype Gen a = Gen (Int -> StdGen -> a) + +generate :: Int -> StdGen -> Gen a -> a +generate n rnd (Gen m) = m size rnd' + where + (size, rnd') = randomR (0, n) rnd ``` ``` haskell +rand :: Gen StdGen +rand = Gen (\_n r -> r) ``` ``` haskell -randomMutation :: [a] -> a -> IO [a] -randomMutation [] x = return [x] -randomMutation xs x = do - appendOrUpdate <- randomIO -- XXX: nondet - if appendOrUpdate - then return (xs ++ [x]) - else do - ix <- randomRIO (0, length xs - 1) - return (update ix xs x) - where - update :: Int -> [a] -> a -> [a] - update ix xs0 x' = case splitAt ix xs0 of - (before, _x : after) -> before ++ x' : after - (_, []) -> error "update: impossible" +sized :: (Int -> Gen a) -> Gen a +sized fgen = Gen (\n r -> let Gen m = fgen n in m n r) ``` ``` haskell -newtype Coverage a = Coverage (IORef (Set a)) - -emptyCoverage :: IO (Coverage a) -emptyCoverage = Coverage <$> newIORef Set.empty - -addCoverage :: Ord a => Coverage a -> a -> IO () -addCoverage (Coverage ref) x = modifyIORef' ref (Set.insert x) - -readCoverage :: Coverage a -> IO (Set a) -readCoverage (Coverage ref) = readIORef ref - -checkCoverage :: Coverage a -> IO Int -checkCoverage (Coverage ref) = Set.size <$> readIORef ref - -data CoverageDiff = Decreased | Same | Increased - deriving Eq - -compareCoverage :: Int -> Int -> CoverageDiff -compareCoverage before after = case compare after before of - LT -> Decreased - EQ -> Same - GT -> Increased +coverCheck :: (Arbitrary a, Show a) => Config -> ([a] -> Property) -> IO () +coverCheck config prop = do + rnd <- newStdGen + testsC config arbitrary prop [] 0 rnd 0 0 [] +``` -withCoverage :: (Coverage c -> IO a) -> IO (a, Int) -withCoverage k = do - c <- emptyCoverage - x <- k c - after <- checkCoverage c - return (x, after) +``` haskell ``` ``` haskell -newtype Gen a = Gen (Size -> StdGen -> a) +``` -type Size = Int +``` haskell +label :: Testable a => String -> a -> Property +label s a = Prop (add `fmap` evaluate a) + where + add res = res{ stamp = s : stamp res } + +classify :: Testable a => Bool -> String -> a -> Property +classify True name = label name +classify False _ = property ``` The full source code is available @@ -377,6 +314,25 @@ The full source code is available ## Testing some examples with the prototype +``` haskell +bad :: String -> Property +bad s = coverage 0 'b' + $ coverage 1 'a' + $ coverage 2 'd' + $ coverage 3 '!' $ if s == "bad!" then False else True + + where + coverage :: Testable a => Int -> Char -> a -> Property + coverage i ch = classify (s !? i == Just ch) [ch] + + (!?) :: [a] -> Int -> Maybe a + xs !? i | i < length xs = Just (xs !! i) + | otherwise = Nothing + +testBad :: IO () +testBad = coverCheck (verbose { maxTest = 2^7*4*2 }) bad +``` + ## Conclusion and further work - Makes more sense for stateful systems than pure functions? Or atleast diff --git a/src/QuickCheckV1.hs b/src/QuickCheckV1.hs index 66cbad6..18b39f3 100644 --- a/src/QuickCheckV1.hs +++ b/src/QuickCheckV1.hs @@ -64,14 +64,18 @@ infix 1 `classify` newtype Gen a = Gen (Int -> StdGen -> a) -- end snippet +-- start snippet sized sized :: (Int -> Gen a) -> Gen a sized fgen = Gen (\n r -> let Gen m = fgen n in m n r) +-- end snippet resize :: Int -> Gen a -> Gen a resize n (Gen m) = Gen (\_ r -> m n r) +-- start snippet rand rand :: Gen StdGen -rand = Gen (\n r -> r) +rand = Gen (\_n r -> r) +-- end snippet promote :: (a -> Gen b) -> Gen (a -> b) promote f = Gen (\n r -> \a -> let Gen m = f a in m n r) @@ -82,6 +86,7 @@ variant v (Gen m) = Gen (\n r -> m n (rands r !! (v+1))) rands r0 = r1 : rands r2 where (r1, r2) = split r0 -- start snippet Gen + generate :: Int -> StdGen -> Gen a -> a generate n rnd (Gen m) = m size rnd' where @@ -115,7 +120,7 @@ elements :: [a] -> Gen a elements xs = (xs !!) `fmap` choose (0, length xs - 1) vector :: Arbitrary a => Int -> Gen [a] -vector n = sequence [ arbitrary | i <- [1..n] ] +vector n = sequence [ arbitrary | _i <- [1..n] ] oneof :: [Gen a] -> Gen a oneof gens = elements gens >>= id @@ -204,11 +209,13 @@ instance (Arbitrary a, Arbitrary b) => Arbitrary (a -> b) where -------------------------------------------------------------------- -- Testable +-- start snippet Result data Result = Result { ok :: Maybe Bool, stamp :: [String], arguments :: [String] } nothing :: Result nothing = Result{ ok = Nothing, stamp = [], arguments = [] } +-- end snippet newtype Property = Prop (Gen Result) @@ -249,6 +256,7 @@ forAll gen body = Prop $ True ==> a = property a False ==> a = property () +-- start snippet classify label :: Testable a => String -> a -> Property label s a = Prop (add `fmap` evaluate a) where @@ -257,6 +265,7 @@ label s a = Prop (add `fmap` evaluate a) classify :: Testable a => Bool -> String -> a -> Property classify True name = label name classify False _ = property +-- end snippet trivial :: Testable a => Bool -> a -> Property trivial = (`classify` "trivial") @@ -346,17 +355,22 @@ done mesg ntest stamps = -------------------------------------------------------------------- -- the end. +-- start snippet testsCPrime testsC' :: Show a => Config -> Gen a -> ([a] -> Property) -> StdGen -> Int -> Int -> [[String]] -> IO () testsC' config gen prop = tests config genResult where Prop genResult = forAll (genList gen) prop genList gen = sized $ \len -> replicateM len gen +-- end snippet -coverCheck :: (Arbitrary a, Show a) => ([a] -> Property) -> IO () -coverCheck prop = do +-- start snippet coverCheck +coverCheck :: (Arbitrary a, Show a) => Config -> ([a] -> Property) -> IO () +coverCheck config prop = do rnd <- newStdGen - testsC verbose { maxTest = 2^7*4*2 } arbitrary prop [] 0 rnd 0 0 [] + testsC config arbitrary prop [] 0 rnd 0 0 [] +-- end snippet +-- start snippet testsC testsC :: Show a => Config -> Gen a -> ([a] -> Property) -> [a] -> Int -> StdGen -> Int -> Int -> [[String]] -> IO () testsC config gen prop xs cov rnd0 ntest nfail stamps @@ -387,9 +401,11 @@ testsC config gen prop xs cov rnd0 ntest nfail stamps result = result_ {arguments = show xs' : arguments result_ } (rnd1,rnd2) = split rnd0 (rnd3,rnd4) = split rnd2 +-- end snippet ------------------------------------------------------------------------ +-- start snippet bad bad :: String -> Property bad s = coverage 0 'b' $ coverage 1 'a' @@ -405,4 +421,5 @@ bad s = coverage 0 'b' | otherwise = Nothing testBad :: IO () -testBad = coverCheck bad +testBad = coverCheck (verbose { maxTest = 2^7*4*2 }) bad +-- end snippet