Added generator tests

Author: Soupstraw

bin/Main.hs

@@ -4,21 +4,12 @@ module Main (main) where
 
 import Codec.CBOR.Cuddle.CBOR.Gen (generateCBORTerm)
 import Codec.CBOR.Cuddle.CBOR.Validator
-import Codec.CBOR.Cuddle.CDDL (
-  CDDL (..),
-  Name (..),
-  TopLevel (..),
-  XRule,
-  XTerm,
-  XXType2,
-  fromRules,
-  sortCDDL,
- )
+import Codec.CBOR.Cuddle.CDDL (Name (..), fromRules, sortCDDL)
 import Codec.CBOR.Cuddle.CDDL.Postlude (appendPostlude)
 import Codec.CBOR.Cuddle.CDDL.Resolve (
   fullResolveCDDL,
  )
-import Codec.CBOR.Cuddle.IndexMappable (IndexMappable (..))
+import Codec.CBOR.Cuddle.IndexMappable (IndexMappable (..), mapCDDLDropExt)
 import Codec.CBOR.Cuddle.Parser (pCDDL)
 import Codec.CBOR.Cuddle.Pretty (PrettyStage)
 import Codec.CBOR.FlatTerm (toFlatTerm)
@@ -186,15 +177,6 @@ main = do
 
 run :: Opts -> IO ()
 run (Opts cmd cddlFile) = do
-  let
-    mapRule ::
-      ( IndexMappable XXType2 i j
-      , IndexMappable XTerm i j
-      , IndexMappable XRule i j
-      ) =>
-      TopLevel i -> [TopLevel j]
-    mapRule (TopLevelRule r) = [TopLevelRule $ mapIndex r]
-    mapRule (XXTopLevel _) = []
   parseFromFile pCDDL cddlFile >>= \case
     Left err -> do
       putStrLnErr $ errorBundlePretty err
@@ -210,20 +192,20 @@ run (Opts cmd cddlFile) = do
             putDocW 80 . pretty $ mapIndex @_ @_ @PrettyStage defs
         Validate vOpts ->
           let
-            CDDL r tls _
+            cddl
               | vNoPrelude vOpts = res
               | otherwise = appendPostlude res
            in
-            case fullResolveCDDL $ CDDL (mapIndex r) (foldMap mapRule tls) mempty of
+            case fullResolveCDDL $ mapCDDLDropExt cddl of
               Left err -> putStrLnErr (show err) >> exitFailure
               Right _ -> exitSuccess
         (GenerateCBOR gOpts) ->
           let
-            CDDL r tls _
+            cddl
               | gNoPrelude gOpts = res
               | otherwise = appendPostlude res
            in
-            case fullResolveCDDL $ CDDL (mapIndex r) (foldMap mapRule tls) mempty of
+            case fullResolveCDDL $ mapCDDLDropExt cddl of
               Left err -> putStrLnErr (show err) >> exitFailure
               Right mt -> do
                 stdGen <- getStdGen
@@ -237,11 +219,11 @@ run (Opts cmd cddlFile) = do
                       AsPrettyCBOR -> putStrLn . prettyHexEnc $ encodeTerm term
         ValidateCBOR vcOpts ->
           let
-            CDDL r tls _
+            cddl
               | vcNoPrelude vcOpts = res
               | otherwise = res
            in
-            case fullResolveCDDL $ CDDL (mapIndex r) (foldMap mapRule tls) mempty of
+            case fullResolveCDDL $ mapCDDLDropExt cddl of
               Left err -> putStrLnErr (show err) >> exitFailure
               Right mt -> do
                 cbor <- BSC.readFile (vcInput vcOpts)

cuddle.cabal

@@ -136,6 +136,7 @@ test-suite cuddle-test
     Paths_cuddle
     Test.Codec.CBOR.Cuddle.CDDL.Examples
     Test.Codec.CBOR.Cuddle.CDDL.Gen
+    Test.Codec.CBOR.Cuddle.CDDL.GeneratorSpec
     Test.Codec.CBOR.Cuddle.CDDL.Parser
     Test.Codec.CBOR.Cuddle.CDDL.Pretty
     Test.Codec.CBOR.Cuddle.Huddle
@@ -148,13 +149,16 @@ test-suite cuddle-test
     QuickCheck >=2.14,
     base,
     bytestring,
+    cborg,
+    containers,
     cuddle,
     data-default-class,
     generic-random,
     hspec >=2.11,
     hspec-megaparsec >=2.2,
     megaparsec,
     prettyprinter,
+    random,
     string-qq >=0.0.6,
     text,
     tree-diff,

src/Codec/CBOR/Cuddle/CDDL/CBORGenerator.hs

@@ -20,4 +20,4 @@ data WrappedTerm
 newtype CBORGenerator = CBORGenerator (forall g m. StatefulGen g m => g -> m WrappedTerm)
 
 class HasGenerator a where
-  generatorL :: Lens' a CBORGenerator
+  generatorL :: Lens' a (Maybe CBORGenerator)

src/Codec/CBOR/Cuddle/Huddle.hs

@@ -101,7 +101,7 @@ where
 
 import Codec.CBOR.Cuddle.CDDL (CDDL, XRule)
 import Codec.CBOR.Cuddle.CDDL qualified as C
-import Codec.CBOR.Cuddle.CDDL.CBORGenerator (CBORGenerator, HasGenerator (..))
+import Codec.CBOR.Cuddle.CDDL.CBORGenerator (CBORGenerator (..), HasGenerator (..), WrappedTerm)
 import Codec.CBOR.Cuddle.CDDL.CtlOp qualified as CtlOp
 import Codec.CBOR.Cuddle.Comments (Comment (..), HasComment (..))
 import Codec.CBOR.Cuddle.Comments qualified as C
@@ -125,6 +125,7 @@ import GHC.Exts (IsList (Item, fromList, toList))
 import GHC.Generics (Generic)
 import Optics.Core (lens, view, (%), (%~), (&), (^.))
 import Optics.Core qualified as L
+import System.Random.Stateful (StatefulGen)
 import Prelude hiding ((/))
 
 type data HuddleStage
@@ -169,6 +170,9 @@ data Rule = Rule
   }
   deriving (Generic)
 
+instance HasGenerator Rule where
+  generatorL = #ruleExtra % #hxrGenerator
+
 instance HasComment Rule where
   commentL = #ruleExtra % #hxrComment
 
@@ -1307,5 +1311,5 @@ toCDDL' HuddleConfig {..} hdl =
         gps =
           C.GenericParam $ fmap (\(GRef t) -> C.Name t) (args gr)
 
-withGenerator :: HasGenerator a => CBORGenerator -> a -> a
-withGenerator = L.set generatorL
+withGenerator :: HasGenerator a => (forall g m. StatefulGen g m => g -> m WrappedTerm) -> a -> a
+withGenerator f = L.set generatorL (Just $ CBORGenerator f)

src/Codec/CBOR/Cuddle/IndexMappable.hs

@@ -30,7 +30,14 @@ import Codec.CBOR.Cuddle.CDDL.CTree (
   XTerm (..),
   XXType2 (..),
  )
-import Codec.CBOR.Cuddle.Huddle (HuddleStage, XCddl (..), XTerm (..), XXTopLevel (..), XXType2 (..))
+import Codec.CBOR.Cuddle.Huddle (
+  HuddleStage,
+  XCddl (..),
+  XRule (..),
+  XTerm (..),
+  XXTopLevel (..),
+  XXType2 (..),
+ )
 import Codec.CBOR.Cuddle.Parser (
   ParserStage,
   XCddl (..),
@@ -247,6 +254,9 @@ instance IndexMappable XXType2 HuddleStage CTreePhase where
 instance IndexMappable XTerm HuddleStage CTreePhase where
   mapIndex _ = CTreeXTerm
 
+instance IndexMappable XRule HuddleStage CTreePhase where
+  mapIndex (HuddleXRule _ g) = CTreeXRule g
+
 -- HuddleStage -> PrettyStage
 
 instance IndexMappable XCddl HuddleStage PrettyStage where

test/Main.hs

@@ -2,6 +2,7 @@ module Main (main) where
 
 import System.IO (BufferMode (..), hSetBuffering, hSetEncoding, stdout, utf8)
 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)
 import Test.Codec.CBOR.Cuddle.Huddle (huddleSpec)
 import Test.Hspec
@@ -18,6 +19,7 @@ main = do
   hSetBuffering stdout LineBuffering
   hSetEncoding stdout utf8
   hspecWith hspecConfig $ do
-    describe "cddlParser" parserSpec
+    describe "Parser" parserSpec
     describe "Huddle" huddleSpec
     describe "Examples" Examples.spec
+    describe "Generator" Generator.spec

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

@@ -0,0 +1,57 @@
+{-# LANGUAGE OverloadedLists #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module Test.Codec.CBOR.Cuddle.CDDL.GeneratorSpec (spec) where
+
+import Codec.CBOR.Cuddle.CBOR.Gen (generateCBORTerm)
+import Codec.CBOR.Cuddle.CDDL.CBORGenerator (WrappedTerm (..))
+import Codec.CBOR.Cuddle.CDDL.Resolve (fullResolveCDDL)
+import Codec.CBOR.Cuddle.Huddle (
+  Huddle,
+  HuddleItem (..),
+  a,
+  arr,
+  collectFrom,
+  toCDDL,
+  withGenerator,
+  (=:=),
+ )
+import Codec.CBOR.Cuddle.Huddle qualified as H
+import Codec.CBOR.Cuddle.IndexMappable (mapCDDLDropExt)
+import Codec.CBOR.Term (Term)
+import Codec.CBOR.Term qualified as C
+import System.Random (newStdGen)
+import Test.Hspec (Expectation, Spec, describe, it, shouldBe)
+
+foo :: H.Rule
+foo = withGenerator (\_ -> pure . S $ C.TString "bar") $ "foo" =:= arr [1, 2, 3]
+
+simpleTermExample :: Huddle
+simpleTermExample =
+  collectFrom
+    [ HIRule foo
+    ]
+
+refTermExample :: Huddle
+refTermExample =
+  collectFrom
+    [ HIRule foo
+    , HIRule $ "bar" =:= arr [0, a foo]
+    ]
+
+huddleShouldGenerate :: Huddle -> Term -> Expectation
+huddleShouldGenerate huddle term = do
+  g <- newStdGen
+  ct <- case fullResolveCDDL . mapCDDLDropExt $ toCDDL huddle of
+    Right x -> pure x
+    Left err -> fail $ "Failed to resolve CDDL: " <> show err
+  generateCBORTerm ct "foo" g `shouldBe` term
+
+spec :: Spec
+spec = do
+  describe "Custom generators" $ do
+    describe "Huddle" $ do
+      it "If a term has a custom generator then it is used" $
+        simpleTermExample `huddleShouldGenerate` C.TString "bar"
+      it "Custom generator works when called via reference" $
+        refTermExample `huddleShouldGenerate` C.TString "bar"