Upstream custom generator and validator combinators

CHANGELOG.md

@@ -2,6 +2,26 @@
 
 ## 1.8.1.0
 
+* Add custom generator/validator helpers:
+  - `arbitrary` (lifted to `MonadGen`)
+  - `scale` (lifted to `MonadGen`)
+  - `shuffle` (lifted to `MonadGen`)
+  - `genArrayTerm`
+  - `genBytesTerm`
+  - `genStringTerm`
+  - `genMapTerm`
+  - `ifTwiddle`
+  - `validateInt`
+  - `validateUInt`
+  - `validateNInt`
+  - `validateArrayTerm`
+  - `validateBytesTerm`
+  - `validateStringTerm`
+  - `validateMapTerm`
+  - `validateNonEmpty`
+  - `validateUniqueList`
+  - `unwrapSingle`
+* Add `canonicalEq`
 * Fix map generator so that it does not generate duplicate keys
 * Add `MapValidationDuplicateKeys`; validator now checks for duplicate elements
 * Add `Codec.CBOR.Cuddle.CBOR.Canonical`

cuddle.cabal

@@ -130,6 +130,8 @@ test-suite cuddle-test
   other-modules:
     Paths_cuddle
     Test.Codec.CBOR.Cuddle.CBOR.Canonical
+    Test.Codec.CBOR.Cuddle.CDDL.Custom.GeneratorSpec
+    Test.Codec.CBOR.Cuddle.CDDL.Custom.ValidatorSpec
     Test.Codec.CBOR.Cuddle.CDDL.Examples
     Test.Codec.CBOR.Cuddle.CDDL.Examples.Huddle
     Test.Codec.CBOR.Cuddle.CDDL.Gen

src/Codec/CBOR/Cuddle/CBOR/Canonical.hs

@@ -3,18 +3,20 @@
 module Codec.CBOR.Cuddle.CBOR.Canonical (
   CanonicalTerm (..),
   NInt,
+  toCanonical,
   toNInt,
   fromNInt,
-  toCanonical,
   uintMax,
   nintMin,
+  canonicalEq,
 ) where
 
 import Codec.CBOR.Term (Term (..))
 import Data.Bifunctor (bimap)
 import Data.ByteString (ByteString)
 import Data.ByteString qualified as BS
 import Data.ByteString.Lazy qualified as BSL
+import Data.Function (on)
 import Data.Map.Strict (Map)
 import Data.Map.Strict qualified as Map
 import Data.Text (Text)
@@ -153,3 +155,6 @@ uintMax = 2 ^ (64 :: Int) - 1
 
 nintMin :: Integer
 nintMin = -(2 ^ (64 :: Int))
+
+canonicalEq :: Term -> Term -> Bool
+canonicalEq = (==) `on` toCanonical

src/Codec/CBOR/Cuddle/CDDL/Custom/Generator.hs

@@ -14,18 +14,38 @@ module Codec.CBOR.Cuddle.CDDL.Custom.Generator (
   withLocalGenBindings,
   disableTwiddle,
   enableTwiddle,
+
+  -- * Lifted QuickCheck functions
+  arbitrary,
+  scale,
+  shuffle,
+
+  -- * Custom generator helpers
+  genArrayTerm,
+  genBytesTerm,
+  genStringTerm,
+  genMapTerm,
+  ifTwiddle,
 ) where
 
 import Codec.CBOR.Cuddle.CDDL (GRef (..), Name (..))
 import Codec.CBOR.Cuddle.CDDL.CTree (CTree, CTreeRoot (..), XXCTree)
 import Codec.CBOR.Cuddle.CDDL.Custom.Core (MonadCddl (..), RuleTerm)
+import Codec.CBOR.Term (Term (..))
 import Control.Monad.Reader (MonadReader (..), ReaderT (..), asks, mapReaderT)
+import Data.ByteString (ByteString)
+import Data.ByteString.Lazy qualified as LBS
 import Data.Map.Strict (Map)
 import Data.Map.Strict qualified as Map
+import Data.Text qualified as T
+import Data.Text.Lazy qualified as LT
 import GHC.Generics (Generic)
 import Optics.Lens (Lens')
 import Test.AntiGen (AntiGen)
+import Test.QuickCheck (Arbitrary)
+import Test.QuickCheck qualified as QC
 import Test.QuickCheck.GenT (MonadGen (..))
+import Test.QuickCheck.GenT qualified as GenT
 
 type data GenPhase
 
@@ -101,3 +121,37 @@ data instance XXCTree GenPhase
 
 class HasGenerator a where
   generatorL :: Lens' a (Maybe (CBORGen RuleTerm))
+
+-- Lifted Gen functions
+
+arbitrary :: forall a m. (MonadGen m, Arbitrary a) => m a
+arbitrary = liftGen QC.arbitrary
+
+scale :: MonadGen m => (Int -> Int) -> m a -> m a
+scale f m = sized $ \sz -> resize (f sz) m
+
+shuffle :: MonadGen m => [a] -> m [a]
+shuffle = liftGen . QC.shuffle
+
+-- Term generators
+
+genArrayTerm :: [Term] -> CBORGen Term
+genArrayTerm es =
+  ifTwiddle (GenT.elements [TList es, TListI es]) (pure $ TList es)
+
+genBytesTerm :: ByteString -> CBORGen Term
+genBytesTerm bs =
+  ifTwiddle (GenT.elements [TBytes bs, TBytesI $ LBS.fromStrict bs]) (pure $ TBytes bs)
+
+genStringTerm :: T.Text -> CBORGen Term
+genStringTerm t =
+  ifTwiddle (GenT.elements [TString t, TStringI $ LT.fromStrict t]) (pure $ TString t)
+
+genMapTerm :: [(Term, Term)] -> CBORGen Term
+genMapTerm m =
+  ifTwiddle (GenT.elements [TMap m, TMapI m]) (pure $ TMap m)
+
+ifTwiddle :: CBORGen a -> CBORGen a -> CBORGen a
+ifTwiddle yes no = do
+  twiddle <- asks (gcTwiddle . geConfig)
+  if twiddle then yes else no

src/Codec/CBOR/Cuddle/CDDL/Custom/Validator.hs

@@ -1,5 +1,6 @@
 {-# LANGUAGE TypeData #-}
 {-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE ViewPatterns #-}
 
 module Codec.CBOR.Cuddle.CDDL.Custom.Validator (
   TermValidator,
@@ -11,17 +12,38 @@ module Codec.CBOR.Cuddle.CDDL.Custom.Validator (
   ValidateEnv (..),
   withLocalValidateBindings,
   runValidator,
+
+  -- * Custom validator helpers
+  validateInt,
+  validateUInt,
+  validateNInt,
+  validateArrayTerm,
+  validateBytesTerm,
+  validateStringTerm,
+  validateMapTerm,
+  validateNonEmpty,
+  validateUniqueList,
+  unwrapSingle,
 ) where
 
+import Codec.CBOR.Cuddle.CBOR.Canonical (toCanonical)
 import Codec.CBOR.Cuddle.CDDL (GRef (..), Name (..))
-import Codec.CBOR.Cuddle.CDDL.CTree (CTree, CTreeRoot (..))
-import Codec.CBOR.Cuddle.CDDL.Custom.Core (MonadCddl (..), RuleTerm)
+import Codec.CBOR.Cuddle.CDDL.CTree (CTree, CTreeRoot (..), nintMin, uintMax)
+import Codec.CBOR.Cuddle.CDDL.Custom.Core (MonadCddl (..), RuleTerm (..))
 import Codec.CBOR.Cuddle.CDDL.Custom.Generator (XXCTree)
+import Codec.CBOR.Term (Term (..))
 import Control.Monad.Reader (MonadReader (..), ReaderT (..), asks)
+import Data.Bifunctor (Bifunctor (..))
+import Data.ByteString (ByteString)
+import Data.ByteString.Lazy qualified as LBS
+import Data.Foldable (Foldable (..))
+import Data.List.NonEmpty (NonEmpty, nonEmpty)
 import Data.Map.Strict (Map)
 import Data.Map.Strict qualified as Map
+import Data.Set qualified as Set
 import Data.Text (Text)
 import Data.Text qualified as T
+import Data.Text.Lazy qualified as LT
 import GHC.Generics (Generic)
 import Optics.Lens (Lens')
 
@@ -74,3 +96,67 @@ runValidator ::
 runValidator (Validator m) cddl =
   either CustomValidatorFailure (const CustomValidatorSuccess) $
     runReaderT m ValidateEnv {veRoot = cddl, veLocal = Map.empty}
+
+-- * Helpers
+
+validateInt :: Term -> Validator Integer
+validateInt (TInt (toInteger -> x))
+  | x >= nintMin && x <= uintMax = pure x
+  | otherwise = fail "Number not in int range"
+validateInt _ = fail "Expected int"
+
+validateUInt :: Term -> Validator Integer
+validateUInt (TInt (toInteger -> x))
+  | x >= 0 && x <= uintMax = pure x
+  | otherwise = fail "Number not in uint range"
+validateUInt _ = fail "Expected uint"
+
+validateNInt :: Term -> Validator Integer
+validateNInt (TInt (toInteger -> x))
+  | x >= nintMin && x < 0 = pure x
+  | otherwise = fail "Number not in nint range"
+validateNInt _ = fail "Expected nint"
+
+validateArrayTerm :: Term -> Validator [Term]
+validateArrayTerm (TList xs) = pure xs
+validateArrayTerm (TListI xs) = pure xs
+validateArrayTerm _ = fail "Expected list"
+
+validateBytesTerm :: Term -> Validator ByteString
+validateBytesTerm (TBytes bs) = pure bs
+validateBytesTerm (TBytesI bs) = pure $ LBS.toStrict bs
+validateBytesTerm _ = fail "Expected bytes"
+
+validateStringTerm :: Term -> Validator Text
+validateStringTerm (TString x) = pure x
+validateStringTerm (TStringI x) = pure $ LT.toStrict x
+validateStringTerm _ = fail "Expected string"
+
+validateMapTerm :: Term -> Validator [(Term, Term)]
+validateMapTerm (TMap xs) = validateUniqueMap xs >> pure xs
+validateMapTerm (TMapI xs) = validateUniqueMap xs >> pure xs
+validateMapTerm _ = fail "Expected map"
+
+-- | Fail if the collection is empty. A custom-validator stand-in for the CDDL
+-- @1*@ (non-empty) occurrence constraint, which is no longer enforced once a
+-- custom validator replaces the built-in array/map validation for a rule.
+validateNonEmpty :: Foldable t => t a -> Validator (NonEmpty a)
+validateNonEmpty = maybe (fail "Expected at least one element") pure . nonEmpty . toList
+
+validateUniqueMap :: [(Term, Term)] -> Validator ()
+validateUniqueMap xs
+  | Map.size m == length xs = pure ()
+  | otherwise = fail "Map contains duplicate keys"
+  where
+    m = Map.fromList $ first toCanonical <$> xs
+
+validateUniqueList :: [Term] -> Validator ()
+validateUniqueList xs
+  | Set.size s == length xs = pure ()
+  | otherwise = fail "List contains duplicate keys"
+  where
+    s = Set.fromList $ toCanonical <$> xs
+
+unwrapSingle :: RuleTerm -> Validator Term
+unwrapSingle (SingleTerm x) = pure x
+unwrapSingle _ = fail "Expected a single term"

test/Main.hs

@@ -2,6 +2,8 @@ module Main (main) where
 
 import System.IO (BufferMode (..), hSetBuffering, hSetEncoding, stdout, utf8)
 import Test.Codec.CBOR.Cuddle.CBOR.Canonical qualified as Canonical
+import Test.Codec.CBOR.Cuddle.CDDL.Custom.GeneratorSpec qualified as CustomGenerator
+import Test.Codec.CBOR.Cuddle.CDDL.Custom.ValidatorSpec qualified as CustomValidator
 import Test.Codec.CBOR.Cuddle.CDDL.Examples qualified as Examples
 import Test.Codec.CBOR.Cuddle.CDDL.GeneratorSpec qualified as Generator
 import Test.Codec.CBOR.Cuddle.CDDL.Parser (parserSpec)
@@ -29,6 +31,9 @@ main = do
     describe "Huddle" huddleSpec
     describe "Examples" Examples.spec
     describe "Generator" Generator.spec
+    describe "Custom" $ do
+      describe "Generator" CustomGenerator.spec
+      describe "Validator" CustomValidator.spec
     describe "Pretty" $ do
       describe "Golden" PrettyGolden.spec
       describe "Roundtrip" roundtripSpec

test/Test/Codec/CBOR/Cuddle/CDDL/Custom/GeneratorSpec.hs

@@ -0,0 +1,112 @@
+module Test.Codec.CBOR.Cuddle.CDDL.Custom.GeneratorSpec (spec) where
+
+import Codec.CBOR.Cuddle.CDDL.CTree (CTreeRoot (..))
+import Codec.CBOR.Cuddle.CDDL.Custom.Generator (
+  CBORGen,
+  GenConfig (..),
+  genArrayTerm,
+  genBytesTerm,
+  genMapTerm,
+  genStringTerm,
+  ifTwiddle,
+  runCBORGen,
+ )
+import Codec.CBOR.Cuddle.CDDL.Custom.Generator qualified as Gen
+import Codec.CBOR.Cuddle.CDDL.Custom.Validator (
+  validateArrayTerm,
+  validateBytesTerm,
+  validateMapTerm,
+  validateStringTerm,
+ )
+import Codec.CBOR.Term (Term (..))
+import Data.ByteString qualified as BS
+import Data.List (sort)
+import Data.Map.Strict qualified as Map
+import Data.Text qualified as T
+import Test.AntiGen (runAntiGen)
+import Test.Codec.CBOR.Cuddle.CDDL.Custom.ValidatorSpec (succeedsWith)
+import Test.Hspec (Spec, describe)
+import Test.Hspec.QuickCheck (prop)
+import Test.QuickCheck (
+  Gen,
+  chooseInt,
+  classify,
+  total,
+  (===),
+ )
+import Test.QuickCheck.GenT qualified as GenT
+
+runCustomGen :: Bool -> CBORGen a -> Gen a
+runCustomGen twiddle =
+  runAntiGen . runCBORGen GenConfig {gcRoot = CTreeRoot Map.empty, gcTwiddle = twiddle}
+
+isIndefinite :: Term -> Bool
+isIndefinite TListI {} = True
+isIndefinite TBytesI {} = True
+isIndefinite TStringI {} = True
+isIndefinite TMapI {} = True
+isIndefinite _ = False
+
+spec :: Spec
+spec = do
+  describe "term generators with twiddling disabled" $ do
+    prop "genArrayTerm yields a definite list" $ \is -> do
+      let ts = map TInt is
+      res <- runCustomGen False $ genArrayTerm ts
+      pure $ res === TList ts
+    prop "genBytesTerm yields definite bytes" $ \ws -> do
+      let bs = BS.pack ws
+      res <- runCustomGen False $ genBytesTerm bs
+      pure $ res === TBytes bs
+    prop "genStringTerm yields a definite string" $ \s -> do
+      let t = T.pack s
+      res <- runCustomGen False $ genStringTerm t
+      pure $ res === TString t
+    prop "genMapTerm yields a definite map" $ \(kvs :: [(Int, Int)]) -> do
+      let ts = [(TInt k, TInt v) | (k, v) <- kvs]
+      res <- runCustomGen False $ genMapTerm ts
+      pure $ res === TMap ts
+    prop "ifTwiddle takes the second branch" $ do
+      res <- runCustomGen False $ ifTwiddle (pure True) (pure False)
+      pure $ res === False
+
+  describe "term generators with twiddling enabled" $ do
+    prop "genArrayTerm roundtrips through validateArrayTerm" $ \is -> do
+      let ts = map TInt is
+      res <- runCustomGen True $ genArrayTerm ts
+      pure
+        . classify (isIndefinite res) "indefinite"
+        $ validateArrayTerm res `succeedsWith` ts
+    prop "genBytesTerm roundtrips through validateBytesTerm" $ \ws -> do
+      let bs = BS.pack ws
+      res <- runCustomGen True $ genBytesTerm bs
+      pure
+        . classify (isIndefinite res) "indefinite"
+        $ validateBytesTerm res `succeedsWith` bs
+    prop "genStringTerm roundtrips through validateStringTerm" $ \s -> do
+      let t = T.pack s
+      res <- runCustomGen True $ genStringTerm t
+      pure
+        . classify (isIndefinite res) "indefinite"
+        $ validateStringTerm res `succeedsWith` t
+    prop "genMapTerm roundtrips through validateMapTerm" $ \(kvs :: [(Int, Int)]) -> do
+      let ts = [(TInt k, TInt v) | (k, v) <- kvs]
+      res <- runCustomGen True $ genMapTerm ts
+      pure
+        . classify (isIndefinite res) "indefinite"
+        $ validateMapTerm res `succeedsWith` ts
+    prop "ifTwiddle takes the first branch" $ do
+      res <- runCustomGen True $ ifTwiddle (pure True) (pure False)
+      pure $ res === True
+
+  describe "lifted QuickCheck functions" $ do
+    prop "shuffle returns a permutation" $ \(xs :: [Int]) -> do
+      ys <- runCustomGen True $ Gen.shuffle xs
+      pure $ sort ys === sort xs
+    prop "scale sets the size seen by the generator" $ do
+      k <- chooseInt (0, 99)
+      sz <- runCustomGen True $ Gen.scale (const k) (GenT.sized pure)
+      pure $ sz === k
+    prop "arbitrary lifts into CBORGen" $ do
+      n <- runCustomGen True (Gen.arbitrary :: CBORGen Int)
+      pure . classify (n /= 0) "non-zero" $ total n