Start adding snippets of the latest version of the code.

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

README.md

@@ -267,116 +267,72 @@ 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
 [here](https://github.com/stevana/coverage-guided-pbt).
 
 ## 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

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