Custom generators

bin/Main.hs

@@ -9,7 +9,7 @@ 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)
@@ -192,24 +192,24 @@ run (Opts cmd cddlFile) = do
             putDocW 80 . pretty $ mapIndex @_ @_ @PrettyStage defs
         Validate vOpts ->
           let
-            res'
+            cddl
               | vNoPrelude vOpts = res
               | otherwise = appendPostlude res
            in
-            case fullResolveCDDL $ mapIndex res' of
+            case fullResolveCDDL $ mapCDDLDropExt cddl of
               Left err -> putStrLnErr (show err) >> exitFailure
               Right _ -> exitSuccess
         (GenerateCBOR gOpts) ->
           let
-            res'
+            cddl
               | gNoPrelude gOpts = res
               | otherwise = appendPostlude res
            in
-            case fullResolveCDDL $ mapIndex res' of
+            case fullResolveCDDL $ mapCDDLDropExt cddl of
               Left err -> putStrLnErr (show err) >> exitFailure
               Right mt -> do
                 stdGen <- getStdGen
-                let term = generateCBORTerm mt (Name (itemName gOpts) mempty) stdGen
+                let term = generateCBORTerm mt (Name $ itemName gOpts) stdGen
                  in case outputFormat gOpts of
                       AsTerm -> print term
                       AsFlatTerm -> print $ toFlatTerm (encodeTerm term)
@@ -219,15 +219,15 @@ run (Opts cmd cddlFile) = do
                       AsPrettyCBOR -> putStrLn . prettyHexEnc $ encodeTerm term
         ValidateCBOR vcOpts ->
           let
-            res'
+            cddl
               | vcNoPrelude vcOpts = res
               | otherwise = res
            in
-            case fullResolveCDDL $ mapIndex res' of
+            case fullResolveCDDL $ mapCDDLDropExt cddl of
               Left err -> putStrLnErr (show err) >> exitFailure
               Right mt -> do
                 cbor <- BSC.readFile (vcInput vcOpts)
-                validateCBOR cbor (Name (vcItemName vcOpts) mempty) mt
+                validateCBOR cbor (Name $ vcItemName vcOpts) (mapIndex mt)
 
 putStrLnErr :: String -> IO ()
 putStrLnErr = hPutStrLn stderr

cuddle.cabal

@@ -44,6 +44,7 @@ library
     Codec.CBOR.Cuddle.CBOR.Gen
     Codec.CBOR.Cuddle.CBOR.Validator
     Codec.CBOR.Cuddle.CDDL
+    Codec.CBOR.Cuddle.CDDL.CBORGenerator
     Codec.CBOR.Cuddle.CDDL.CTree
     Codec.CBOR.Cuddle.CDDL.CtlOp
     Codec.CBOR.Cuddle.CDDL.Postlude
@@ -135,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
@@ -147,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,

nix/shell.nix

@@ -36,10 +36,6 @@ let
         enable = true;
         package = tools.fourmolu;
       };
-      hlint = {
-        enable = true;
-        package = tools.hlint;
-      };
       nixpkgs-fmt = {
         enable = true;
         package = pkgs.nixpkgs-fmt;

src/Codec/CBOR/Cuddle/CBOR/Gen.hs

@@ -11,6 +11,8 @@
 
 #if MIN_VERSION_random(1,3,0)
 {-# OPTIONS_GHC -Wno-deprecations #-} -- Due to usage of `split`
+{-# LANGUAGE TypeData #-}
+{-# LANGUAGE TypeFamilies #-}
 #endif
 -- | Generate example CBOR given a CDDL specification
 module Codec.CBOR.Cuddle.CBOR.Gen (generateCBORTerm, generateCBORTerm') where
@@ -25,10 +27,10 @@ import Codec.CBOR.Cuddle.CDDL (
   Value (..),
   ValueVariant (..),
  )
-import Codec.CBOR.Cuddle.CDDL.CTree (CTree, CTreePhase, CTreeRoot (..), PTerm (..))
+import Codec.CBOR.Cuddle.CDDL.CTree (CTree (..), CTreeRoot (..), PTerm (..), foldCTree)
 import Codec.CBOR.Cuddle.CDDL.CTree qualified as CTree
 import Codec.CBOR.Cuddle.CDDL.CtlOp qualified as CtlOp
-import Codec.CBOR.Cuddle.CDDL.Resolve (MonoRef (..), MonoReferenced)
+import Codec.CBOR.Cuddle.CDDL.Resolve (MonoReferenced, XXCTree (..))
 import Codec.CBOR.Term (Term (..))
 import Codec.CBOR.Term qualified as CBOR
 import Codec.CBOR.Write qualified as CBOR
@@ -59,8 +61,21 @@ import System.Random.Stateful (
 import System.Random.Stateful (
   SplitGen (..)
   )
+import Codec.CBOR.Cuddle.CDDL.CBORGenerator (WrappedTerm (..), CBORGenerator (..))
+import Codec.CBOR.Cuddle.IndexMappable (IndexMappable (..))
 #endif
 
+type data MonoDropGen
+
+newtype instance XXCTree MonoDropGen = MDGRef Name
+  deriving (Show)
+
+instance IndexMappable CTree MonoReferenced MonoDropGen where
+  mapIndex = foldCTree mapExt mapIndex
+    where
+      mapExt (MRuleRef n) = CTreeE $ MDGRef n
+      mapExt (MGenerator _ x) = mapIndex x
+
 --------------------------------------------------------------------------------
 -- Generator infrastructure
 --------------------------------------------------------------------------------
@@ -209,23 +224,14 @@ genPostlude pt = case pt of
 -- Kinds of terms
 --------------------------------------------------------------------------------
 
-data WrappedTerm
-  = SingleTerm Term
-  | PairTerm Term Term
-  | GroupTerm [WrappedTerm]
-  deriving (Eq, Show)
-
 -- | Recursively flatten wrapped list. That is, expand any groups out to their
 -- individual entries.
 flattenWrappedList :: [WrappedTerm] -> [WrappedTerm]
 flattenWrappedList [] = []
-flattenWrappedList (GroupTerm xxs : xs) =
+flattenWrappedList (G xxs : xs) =
   flattenWrappedList xxs <> flattenWrappedList xs
 flattenWrappedList (y : xs) = y : flattenWrappedList xs
 
-pattern S :: Term -> WrappedTerm
-pattern S t = SingleTerm t
-
 -- | Convert a list of wrapped terms to a list of terms. If any 'PairTerm's are
 -- present, we just take their "value" part.
 singleTermList :: [WrappedTerm] -> Maybe [Term]
@@ -234,18 +240,15 @@ singleTermList (S x : xs) = (x :) <$> singleTermList xs
 singleTermList (P _ y : xs) = (y :) <$> singleTermList xs
 singleTermList _ = Nothing
 
-pattern P :: Term -> Term -> WrappedTerm
-pattern P t1 t2 = PairTerm t1 t2
-
 -- | Convert a list of wrapped terms to a list of pairs of terms, or fail if any
 -- 'SingleTerm's are present.
 pairTermList :: [WrappedTerm] -> Maybe [(Term, Term)]
 pairTermList [] = Just []
 pairTermList (P x y : xs) = ((x, y) :) <$> pairTermList xs
 pairTermList _ = Nothing
 
-pattern G :: [WrappedTerm] -> WrappedTerm
-pattern G xs = GroupTerm xs
+showDropGen :: CTree MonoReferenced -> String
+showDropGen = show . mapIndex @_ @_ @MonoDropGen
 
 --------------------------------------------------------------------------------
 -- Generator functions
@@ -284,9 +287,9 @@ genForCTree (CTree.KV key value _cut) = do
     _ ->
       error $
         "Non single-term generated outside of group context: "
-          <> show key
+          <> showDropGen key
           <> " => "
-          <> show value
+          <> showDropGen value
 genForCTree (CTree.Occur item occurs) =
   applyOccurenceIndicator occurs (genForCTree item)
 genForCTree (CTree.Range from to _bounds) = do
@@ -306,11 +309,11 @@ genForCTree (CTree.Control op target controller) = do
     (CtlOp.Le, CTree.Literal (Value (VUInt n) _)) -> case target of
       CTree.Postlude PTUInt -> S . TInteger <$> genUniformRM (0, fromIntegral n)
       _ -> error "Cannot apply le operator to target"
-    (CtlOp.Le, _) -> error $ "Invalid controller for .le operator: " <> show controller
+    (CtlOp.Le, _) -> error $ "Invalid controller for .le operator: " <> showDropGen controller
     (CtlOp.Lt, CTree.Literal (Value (VUInt n) _)) -> case target of
       CTree.Postlude PTUInt -> S . TInteger <$> genUniformRM (0, fromIntegral n - 1)
       _ -> error "Cannot apply lt operator to target"
-    (CtlOp.Lt, _) -> error $ "Invalid controller for .lt operator: " <> show controller
+    (CtlOp.Lt, _) -> error $ "Invalid controller for .lt operator: " <> showDropGen controller
     (CtlOp.Size, CTree.Literal (Value (VUInt n) _)) -> case target of
       CTree.Postlude PTText -> S . TString <$> genText (fromIntegral n)
       CTree.Postlude PTBytes -> S . TBytes <$> genBytes (fromIntegral n)
@@ -328,15 +331,15 @@ genForCTree (CTree.Control op target controller) = do
           CTree.Postlude PTUInt ->
             S . TInteger
               <$> genUniformRM (fromIntegral f1, fromIntegral t1)
-          _ -> error $ "Cannot apply size operator to target: " <> show target
+          _ -> error $ "Cannot apply size operator to target: " <> showDropGen target
         _ ->
           error $
             "Invalid controller for .size operator: "
-              <> show controller
+              <> showDropGen controller
     (CtlOp.Size, _) ->
       error $
         "Invalid controller for .size operator: "
-          <> show controller
+          <> showDropGen controller
     (CtlOp.Cbor, _) -> do
       enc <- genForCTree controller
       case enc of
@@ -355,15 +358,16 @@ genForCTree (CTree.Tag tag node) = do
   case enc of
     S x -> pure $ S $ TTagged tag x
     _ -> error "Tag controller does not correspond to a single term"
-genForCTree (CTree.CTreeE x) = genForNode x
+genForCTree (CTree.CTreeE (MRuleRef n)) = genForNode n
+genForCTree (CTree.CTreeE (MGenerator (CBORGenerator gen) _)) = gen StateGenM
 
-genForNode :: RandomGen g => CTree.Node MonoReferenced -> M g WrappedTerm
+genForNode :: RandomGen g => Name -> M g WrappedTerm
 genForNode = genForCTree <=< resolveRef
 
 -- | Take a reference and resolve it to the relevant Tree, following multiple
 -- links if necessary.
-resolveRef :: RandomGen g => CTree.Node MonoReferenced -> M g (CTree MonoReferenced)
-resolveRef (MRuleRef n) = do
+resolveRef :: RandomGen g => Name -> M g (CTree MonoReferenced)
+resolveRef n = do
   (CTreeRoot cddl) <- ask @"cddl"
   -- Since we follow a reference, we increase the 'depth' of the gen monad.
   modify @"depth" (+ 1)
@@ -379,7 +383,7 @@ resolveRef (MRuleRef n) = do
 -- This will throw an error if the generated item does not correspond to a
 -- single CBOR term (e.g. if the name resolves to a group, which cannot be
 -- generated outside a context).
-genForName :: RandomGen g => Name CTreePhase -> M g Term
+genForName :: RandomGen g => Name -> M g Term
 genForName n = do
   (CTreeRoot cddl) <- ask @"cddl"
   case Map.lookup n cddl of
@@ -433,13 +437,13 @@ genValueVariant (VBool b) = pure $ TBool b
 -- Generator functions
 --------------------------------------------------------------------------------
 
-generateCBORTerm :: RandomGen g => CTreeRoot MonoReferenced -> Name CTreePhase -> g -> Term
+generateCBORTerm :: RandomGen g => CTreeRoot MonoReferenced -> Name -> g -> Term
 generateCBORTerm cddl n stdGen =
   let genEnv = GenEnv {cddl}
       genState = GenState {randomSeed = stdGen, depth = 1}
    in evalGen (genForName n) genEnv genState
 
-generateCBORTerm' :: RandomGen g => CTreeRoot MonoReferenced -> Name CTreePhase -> g -> (Term, g)
+generateCBORTerm' :: RandomGen g => CTreeRoot MonoReferenced -> Name -> g -> (Term, g)
 generateCBORTerm' cddl n stdGen =
   let genEnv = GenEnv {cddl}
       genState = GenState {randomSeed = stdGen, depth = 1}

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

@@ -1,5 +1,7 @@
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeData #-}
+{-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE ViewPatterns #-}
 
 module Codec.CBOR.Cuddle.CBOR.Validator (
@@ -12,7 +14,8 @@ module Codec.CBOR.Cuddle.CBOR.Validator (
 import Codec.CBOR.Cuddle.CDDL hiding (CDDL, Group, Rule)
 import Codec.CBOR.Cuddle.CDDL.CTree
 import Codec.CBOR.Cuddle.CDDL.CtlOp
-import Codec.CBOR.Cuddle.CDDL.Resolve
+import Codec.CBOR.Cuddle.CDDL.Resolve (MonoReferenced, XXCTree (..))
+import Codec.CBOR.Cuddle.IndexMappable (IndexMappable (..))
 import Codec.CBOR.Read
 import Codec.CBOR.Term
 import Control.Exception
@@ -37,8 +40,25 @@ import System.Exit
 import System.IO
 import Text.Regex.TDFA
 
-type CDDL = CTreeRoot MonoReferenced
-type Rule = CTree MonoReferenced
+type data ValidatorStage
+
+data instance XTerm ValidatorStage = ValidatorXTerm
+  deriving (Show)
+
+newtype instance XXCTree ValidatorStage = VRuleRef Name
+  deriving (Show)
+
+instance IndexMappable CTreeRoot MonoReferenced ValidatorStage where
+  mapIndex (CTreeRoot m) = CTreeRoot $ mapIndex <$> m
+
+instance IndexMappable CTree MonoReferenced ValidatorStage where
+  mapIndex = foldCTree mapExt mapIndex
+    where
+      mapExt (MRuleRef n) = CTreeE $ VRuleRef n
+      mapExt (MGenerator _ x) = mapIndex x
+
+type CDDL = CTreeRoot ValidatorStage
+type Rule = CTree ValidatorStage
 
 data CBORTermResult = CBORTermResult Term CDDLResult
   deriving (Show)
@@ -114,7 +134,7 @@ data AMatchedItem = AMatchedItem
 --------------------------------------------------------------------------------
 -- Main entry point
 
-validateCBOR :: BS.ByteString -> Name CTreePhase -> CDDL -> IO ()
+validateCBOR :: BS.ByteString -> Name -> CDDL -> IO ()
 validateCBOR bs rule cddl =
   ( case validateCBOR' bs rule cddl of
       ok@(CBORTermResult _ (Valid _)) -> do
@@ -131,7 +151,7 @@ validateCBOR bs rule cddl =
             )
 
 validateCBOR' ::
-  BS.ByteString -> Name CTreePhase -> CDDL -> CBORTermResult
+  BS.ByteString -> Name -> CDDL -> CBORTermResult
 validateCBOR' bs rule cddl@(CTreeRoot tree) =
   case deserialiseFromBytes decodeTerm (BSL.fromStrict bs) of
     Left e -> error $ show e
@@ -1016,7 +1036,7 @@ validateChoice v rules = go rules
                 . ($ dummyRule)
 
 dummyRule :: Rule
-dummyRule = CTreeE $ MRuleRef (Name "dummy" mempty)
+dummyRule = CTreeE $ VRuleRef "dummy"
 
 --------------------------------------------------------------------------------
 -- Control helpers
@@ -1108,7 +1128,7 @@ getIndicesOfEnum g =
 -- Resolving rules from the CDDL spec
 
 resolveIfRef :: CDDL -> Rule -> Rule
-resolveIfRef ct@(CTreeRoot cddl) (CTreeE (MRuleRef n)) = do
+resolveIfRef ct@(CTreeRoot cddl) (CTreeE (VRuleRef n)) = do
   case Map.lookup n cddl of
     Nothing -> error $ "Unbound reference: " <> show n
     Just val -> resolveIfRef ct val