feat!: add size to generators

BREAKING CHANGE: this will break tests that rely on a particular seed.

TODO.md

@@ -46,8 +46,13 @@ Here's what I'm currently working on:
 #### Spex
 
 - allow for control of # of test cases vs test case length
+- change size over time
+  + verify
+  + mock
+- add max size?
 - use duration rather than numTests?
 - print progress while testing
+- test database with migration when generators change
 
 - Nice errors
   + Introduce FancyError datatype and display it in LibMain?

src/Spex/Mock.hs

@@ -27,13 +27,15 @@ import Spex.Verifier.Generator.Env
 
 runMock :: MockOptions -> Spec -> Prng -> IO ()
 runMock opts spec prng = do
-  state <- newIORef (MockState {prng = prng, genEnv = emptyGenEnv})
+  state <-
+    newIORef (MockState {prng = prng, size = 0, genEnv = emptyGenEnv})
   run
     opts.port
     (addResetEndpoint state prng (addHealthEndpoint (waiApp spec state)))
 
 data MockState = MockState
   { prng :: Prng
+  , size :: Size
   , genEnv :: GenEnv
   }
 
@@ -49,23 +51,22 @@ addResetEndpoint state origPrng baseApp req respond =
     ("DELETE", ["_reset"]) -> do
       atomicWriteIORef
         state
-        (MockState {prng = origPrng, genEnv = emptyGenEnv})
+        (MockState {prng = origPrng, size = 0, genEnv = emptyGenEnv})
       respond (responseLBS ok200 [] "OK")
     _ -> baseApp req respond
 
 waiApp :: Spec -> IORef MockState -> Application
-waiApp spec state req respond = do
+waiApp spec ref req respond = do
   let ctx = spec.component.typeDecls
   let opDecls = map item (spec.component.opDecls)
-  res <- atomicModifyIORef' state $ \s ->
-    let (prng', prng'') = splitPrng s.prng
-    in  case matchOp opDecls req of
-          Nothing -> (s, Left notFound404)
-          Just respTy ->
-            let val = runGenM (genValue respTy) ctx s.genEnv prng'
-            in  ( s {prng = prng'', genEnv = insertValue respTy val s.genEnv}
-                , Right val
-                )
+  res <- atomicModifyIORef' ref $ \state ->
+    case matchOp opDecls req of
+      Nothing -> (state, Left notFound404)
+      Just respTy ->
+        let (prng', val) = runGenM (genValue respTy) ctx state.genEnv state.prng state.size
+        in  ( state {prng = prng', genEnv = insertValue respTy val state.genEnv}
+            , Right val
+            )
   case res of
     Left err -> respond $ responseLBS err [] ""
     Right val -> respond $ responseLBS ok200 [] (encode val)

src/Spex/Verifier.hs

@@ -132,6 +132,7 @@ verify opts spec deployment prng = do
     opts.numTests
     []
     prng
+    0
     emptyGenEnv
     mempty
 
@@ -143,6 +144,7 @@ verifyLoop ::
   -> Word
   -> [Op]
   -> Prng
+  -> Size
   -> GenEnv
   -> Result
   -> App Result
@@ -152,14 +154,15 @@ verifyLoop opts spec deployment client = go
       Word
       -> [Op]
       -> Prng
+      -> Size
       -> GenEnv
       -> Result
       -> App Result
-    go 0 _ops _prng _genEnv res = do
+    go 0 _ops _prng _size _genEnv res = do
       debug_ ""
       return res
-    go n ops prng genEnv res = do
-      (op, prng', genEnv') <- generate spec prng genEnv
+    go n ops prng size genEnv res = do
+      (op, prng', genEnv') <- generate spec prng size genEnv
       debug (displayOp op)
       resp <- httpRequest client op
       debug_ $ "  ↳ " <> show resp.statusCode <> " " <> BS8.unpack resp.body
@@ -192,10 +195,12 @@ verifyLoop opts spec deployment client = go
                           res.failingTests
                       | otherwise = test : res.failingTests
                 return (Result failingTests' cov')
-          go (n - 1) [] prng' emptyGenEnv res'
+          let size' = (size * 3) `div` 2
+          go (n - 1) [] prng' size' emptyGenEnv res'
         Right val -> do
-          let genEnv'' = insertValue op.responseType val genEnv'
-          go (n - 1) (op : ops) prng' genEnv'' res {coverage = cov'}
+          let size' = (size * 3) `div` 2
+              genEnv'' = insertValue op.responseType val genEnv'
+          go (n - 1) (op : ops) prng' size' genEnv'' res {coverage = cov'}
 
     counterExample ::
       [Op]

src/Spex/Verifier/Generator.hs

@@ -9,6 +9,7 @@ import Control.Monad.Trans.Reader qualified as Reader
 import Data.Foldable (toList)
 import Data.List (find)
 import Data.Map qualified as Map
+import Data.Maybe (fromJust, isJust)
 import Data.Set qualified as Set
 import Data.Text (Text)
 import Data.Vector (Vector)
@@ -31,52 +32,132 @@ newPrng (Just seed) = return (Prng (mkStdGen seed), seed)
 mkPrng :: Int -> Prng
 mkPrng seed = Prng (mkStdGen seed)
 
-splitPrng :: Prng -> (Prng, Prng)
-splitPrng (Prng g) = (Prng g', Prng g'')
-  where
-    (g', g'') = split g
-
 ------------------------------------------------------------------------
 
-newtype Gen a = Gen (StdGen -> a)
+type Size = Int
+
+newtype Gen a = Gen (StdGen -> Size -> (a, StdGen))
 
 instance Monad Gen where
   return = pure
-  Gen f >>= k = Gen $ \prng ->
-    let
-      (prng', prng'') = split prng
-      Gen g = k (f prng')
-    in
-      g prng''
+  Gen f >>= k = Gen $ \stdGen size ->
+    let (x, stdGen') = f stdGen size
+        Gen g = k x
+    in  g stdGen' size
 
 instance Applicative Gen where
-  pure x = Gen (\_prng -> x)
+  pure x = Gen (\stdGen _size -> (x, stdGen))
   (<*>) = ap
 
 instance Functor Gen where
   fmap = liftM
 
-runGen :: Gen a -> Prng -> a
-runGen (Gen k) (Prng g) = k g
+runGen :: Gen a -> Prng -> Size -> (Prng, a)
+runGen (Gen k) (Prng stdGen) size = (Prng stdGen', x)
+  where
+    (x, stdGen') = k stdGen size
 
-rand :: Gen StdGen
-rand = Gen (\g -> g)
+sized :: (Int -> Gen a) -> Gen a
+sized k = Gen (\stdGen size -> let Gen f = k size in f stdGen size)
+
+getSize :: Gen Size
+getSize = sized pure
+
+resize :: Size -> Gen a -> Gen a
+resize size _ | size < 0 = error "resize: negative size"
+resize size (Gen f) = Gen (\stdGen _size -> f stdGen size)
 
 choose :: (Random a) => (a, a) -> Gen a
-choose bounds = (fst . randomR bounds) `fmap` rand
+choose rng = Gen (\stdGen _ -> randomR rng stdGen)
+
+-- NOTE: This can be optimised later (if needed), see QuickCheck.
+chooseInt :: (Int, Int) -> Gen Int
+chooseInt = choose
 
 elements :: [a] -> Gen a
-elements xs = (xs !!) `fmap` choose (0, length xs - 1)
+elements [] = error "elements used with empty list"
+elements xs = (xs !!) `fmap` chooseInt (0, length xs - 1)
+
+oneof :: [Gen a] -> Gen a
+oneof [] = error "oneof used with empty list"
+oneof gs = chooseInt (0, length gs - 1) >>= (gs !!)
+
+vectorOf :: Int -> Gen a -> Gen [a]
+vectorOf = replicateM
+
+listOf :: Gen a -> Gen [a]
+listOf gen = sized $ \n -> do
+  k <- choose (0, n)
+  vectorOf k gen
+
+chooseBounded :: (Random a, Bounded a) => Gen a
+chooseBounded = choose (minBound, maxBound)
+
+chooseFloat :: Gen Float
+chooseFloat = choose (0, 1)
+
+chooseDouble :: Gen Double
+chooseDouble = choose (0, 1)
+
+generate' :: Gen a -> IO a
+generate' (Gen g) = do
+  (Prng stdGen, _seed) <- newPrng Nothing
+  let size = 30
+  return (fst (g stdGen size))
 
-vector :: Gen a -> Int -> Gen [a]
-vector g n = replicateM n g
+sample' :: Gen a -> IO [a]
+sample' g =
+  generate' (sequence [resize n g | n <- [0, 2 .. 20]])
 
-genBounded :: (Random a, Bounded a) => Gen a
-genBounded = choose (minBound, maxBound)
+------------------------------------------------------------------------
+
+suchThat :: Gen a -> (a -> Bool) -> Gen a
+gen `suchThat` p = do
+  mx <- gen `suchThatMaybe` p
+  case mx of
+    Just x -> return x
+    Nothing -> sized (\n -> resize (n + 1) (gen `suchThat` p))
+
+suchThatMap :: Gen a -> (a -> Maybe b) -> Gen b
+gen `suchThatMap` f =
+  fmap fromJust $ fmap f gen `suchThat` isJust
+
+suchThatMaybe :: Gen a -> (a -> Bool) -> Gen (Maybe a)
+gen `suchThatMaybe` p = sized (\n -> try n (2 * n))
+  where
+    try m n
+      | m > n = return Nothing
+      | otherwise = do
+          x <- resize m gen
+          if p x then return (Just x) else try (m + 1) n
+
+------------------------------------------------------------------------
 
 genInt :: Gen Int
--- genInt = choose (minBound, maxBound)
-genInt = choose (-1000, 1000)
+genInt = arbitrarySizedIntegral
+
+arbitrarySizedIntegral :: (Integral a) => Gen a
+arbitrarySizedIntegral
+  | isNonNegativeType fromI = arbitrarySizedNatural
+  | otherwise = sized $ \n -> inBounds fromI (chooseInt (-n, n))
+  where
+    -- NOTE: this is a trick to make sure we get around lack of scoped type
+    -- variables by pinning the result-type of fromIntegral.
+    fromI = fromIntegral
+
+isNonNegativeType :: (Enum a) => (Int -> a) -> Bool
+isNonNegativeType fromI =
+  case enumFromThen (fromI 1) (fromI 0) of
+    [_, _] -> True
+    _ -> False
+
+arbitrarySizedNatural :: (Integral a) => Gen a
+arbitrarySizedNatural =
+  sized $ \n ->
+    inBounds fromIntegral (chooseInt (0, n))
+
+inBounds :: (Integral a) => (Int -> a) -> Gen Int -> Gen a
+inBounds fi g = fmap fi (g `suchThat` (\x -> toInteger x == toInteger (fi x)))
 
 genText :: Gen Text
 genText = elements ["foo", "bar", "qux"]
@@ -92,17 +173,18 @@ data GenMEnv = GenMEnv
 
 type GenM a = ReaderT GenMEnv Gen a
 
-runGenM :: GenM a -> GenCtx -> GenEnv -> Prng -> a
-runGenM m ctx env prng = runGen (Reader.runReaderT m (GenMEnv ctx env)) prng
+runGenM :: GenM a -> GenCtx -> GenEnv -> Prng -> Size -> (Prng, a)
+runGenM m ctx env prng size =
+  runGen (Reader.runReaderT m (GenMEnv ctx env)) prng size
 
-generate :: Spec -> Prng -> GenEnv -> App (Op, Prng, GenEnv)
-generate spec prng env = do
+generate :: Spec -> Prng -> Size -> GenEnv -> App (Op, Prng, GenEnv)
+generate spec prng size env = do
   let ctx = spec.component.typeDecls
-      (prng', prng'') = splitPrng prng
-      (decl, op) = runGenM (genOp (map item spec.component.opDecls)) ctx env prng'
+      (prng', (decl, op)) =
+        runGenM (genOp (map item spec.component.opDecls)) ctx env prng size
       env' = newValues ctx env decl op
   trace $ "generate, new values: " <> show env'
-  return (op, prng'', env')
+  return (op, prng', env')
 
 newValues :: GenCtx -> GenEnv -> OpDecl -> Op -> GenEnv
 newValues ctx old decl op =
@@ -137,9 +219,9 @@ removeRecordType ty = [ty]
 genOp :: [OpDecl] -> GenM (OpDecl, Op)
 genOp opdecls = do
   opdecl <- lift (elements opdecls)
+  hs <- genHeaders opdecl.headers
   p <- genPath opdecl.path
   b <- genBody opdecl.body
-  hs <- genHeaders opdecl.headers
   return
     ( opdecl
     , Op
@@ -165,7 +247,7 @@ data Mode = Normal | Abstract | Unique
 
 genValue :: Type -> GenM Value
 genValue UnitT = return UnitV
-genValue BoolT = BoolV <$> lift genBounded
+genValue BoolT = BoolV <$> lift chooseBounded
 genValue IntT = remembering IntT (IntV <$> genInt) Normal
 genValue StringT = StringV <$> lift genText
 genValue (ArrayT tys) = genArray tys
@@ -176,7 +258,7 @@ genValue (UniqueT ty) = genValue' ty Unique
 
 genValue' :: Type -> Mode -> GenM Value
 genValue' UnitT _mode = return UnitV
-genValue' BoolT _mode = BoolV <$> lift genBounded
+genValue' BoolT _mode = BoolV <$> lift chooseBounded
 genValue' IntT mode = remembering IntT (IntV <$> genInt) mode
 genValue' StringT _mode = StringV <$> lift genText
 genValue' (ArrayT tys) _mode = genArray tys

test/Main.hs

@@ -23,19 +23,17 @@ tests tmpDir =
         ( zipWith
             withPetstore
             [ test
-                [ "verify"
-                , "example/petstore-basic.spex"
-                , "--seed"
-                , "2503963955766725184"
-                ]
-            , test
                 [ "verify"
                 , "example/petstore-modal-faults.spex"
-                , "--tests"
-                , "2000"
                 , "--seed"
-                , "3967796076964233976"
+                , "8800299288541500217"
                 ]
+                -- test
+                --     [ "verify"
+                --     , "example/petstore-basic.spex"
+                --     , "--seed"
+                --     , "2503963955766725184"
+                --     ]
             ]
             [0 ..] -- Used to compute the ports used by the tests.
         )