Added withGenerator

Author: Soupstraw

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

@@ -20,14 +20,11 @@ import Capability.Sink (HasSink)
 import Capability.Source (HasSource, MonadState (..))
 import Capability.State (HasState, get, modify)
 import Codec.CBOR.Cuddle.CDDL (
+  CBORGenerator (..),
   Name (..),
   OccurrenceIndicator (..),
   Value (..),
   ValueVariant (..),
- )
-import Codec.CBOR.Cuddle.CDDL.CTree (
-  CTree,
-  CTreeRoot' (..),
   WrappedTerm,
   flattenWrappedList,
   pairTermList,
@@ -36,6 +33,10 @@ import Codec.CBOR.Cuddle.CDDL.CTree (
   pattern P,
   pattern S,
  )
+import Codec.CBOR.Cuddle.CDDL.CTree (
+  CTree,
+  CTreeRoot' (..),
+ )
 import Codec.CBOR.Cuddle.CDDL.CTree qualified as CTree
 import Codec.CBOR.Cuddle.CDDL.CtlOp qualified as CtlOp
 import Codec.CBOR.Cuddle.CDDL.Postlude (PTerm (..))
@@ -331,7 +332,7 @@ 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.WithGen gen _) = gen StateGenM
+genForCTree (CTree.WithGen (CBORGenerator gen) _) = gen StateGenM
 
 genForNode :: RandomGen g => CTree.Node MonoRef -> M g WrappedTerm
 genForNode = genForCTree <=< resolveIfRef

src/Codec/CBOR/Cuddle/CDDL.hs

@@ -1,10 +1,12 @@
 {-# LANGUAGE DeriveAnyClass #-}
 {-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE PatternSynonyms #-}
 
 -- | This module defined the data structure of CDDL as specified in
 --   https://datatracker.ietf.org/doc/rfc8610/
 module Codec.CBOR.Cuddle.CDDL (
   CDDL (..),
+  CBORGenerator (..),
   sortCDDL,
   cddlTopLevel,
   cddlRules,
@@ -33,10 +35,18 @@ module Codec.CBOR.Cuddle.CDDL (
   GrpChoice (..),
   unwrap,
   compareRuleName,
+  WrappedTerm (..),
+  flattenWrappedList,
+  singleTermList,
+  pairTermList,
+  pattern S,
+  pattern G,
+  pattern P,
 ) where
 
 import Codec.CBOR.Cuddle.CDDL.CtlOp (CtlOp)
 import Codec.CBOR.Cuddle.Comments (CollectComments (..), Comment, HasComment (..))
+import Codec.CBOR.Term (Term)
 import Data.ByteString qualified as B
 import Data.Default.Class (Default (..))
 import Data.Function (on, (&))
@@ -51,14 +61,60 @@ import GHC.Generics (Generic)
 import Optics.Core ((%), (.~))
 import Optics.Getter (view)
 import Optics.Lens (lens)
+import System.Random.Stateful (StatefulGen)
+
+--------------------------------------------------------------------------------
+-- Kinds of terms
+--------------------------------------------------------------------------------
+
+data WrappedTerm
+  = SingleTerm Term
+  | PairTerm Term Term
+  | GroupTerm [WrappedTerm]
+  deriving (Eq, Show, Generic)
+
+-- | Recursively flatten wrapped list. That is, expand any groups out to their
+-- individual entries.
+flattenWrappedList :: [WrappedTerm] -> [WrappedTerm]
+flattenWrappedList [] = []
+flattenWrappedList (GroupTerm 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]
+singleTermList [] = Just []
+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
+
+newtype CBORGenerator
+  = CBORGenerator (forall g m. StatefulGen g m => g -> m WrappedTerm)
 
 -- | The CDDL constructor takes three arguments:
 --     1. Top level comments that precede the first definition
 --     2. The root definition
 --     3. All the other top level comments and definitions
 --   This ensures that `CDDL` is correct by construction.
 data CDDL = CDDL [Comment] Rule [TopLevel]
-  deriving (Eq, Generic, Show, ToExpr)
+  deriving (Generic)
 
 -- | Sort the CDDL Rules on the basis of their names
 -- Top level comments will be removed!
@@ -92,7 +148,7 @@ instance Semigroup CDDL where
 data TopLevel
   = TopLevelRule Rule
   | TopLevelComment Comment
-  deriving (Eq, Generic, Show, ToExpr)
+  deriving (Generic)
 
 -- |
 --  A name can consist of any of the characters from the set {"A" to
@@ -209,9 +265,9 @@ data Rule = Rule
   , ruleAssign :: Assign
   , ruleTerm :: TypeOrGroup
   , ruleComment :: Comment
+  , ruleGenerator :: Maybe CBORGenerator
   }
-  deriving (Eq, Generic, Show)
-  deriving anyclass (ToExpr)
+  deriving (Generic)
 
 instance HasComment Rule where
   commentL = lens ruleComment (\x y -> x {ruleComment = y})

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

@@ -1,65 +1,21 @@
 {-# LANGUAGE DataKinds #-}
-{-# LANGUAGE PatternSynonyms #-}
 
 module Codec.CBOR.Cuddle.CDDL.CTree where
 
 import Codec.CBOR.Cuddle.CDDL (
+  CBORGenerator,
   Name,
   OccurrenceIndicator,
   RangeBound,
   Value,
  )
 import Codec.CBOR.Cuddle.CDDL.CtlOp
 import Codec.CBOR.Cuddle.CDDL.Postlude (PTerm)
-import Codec.CBOR.Term (Term)
 import Data.Hashable (Hashable)
 import Data.List.NonEmpty qualified as NE
 import Data.Map.Strict qualified as Map
 import Data.Word (Word64)
 import GHC.Generics (Generic)
-import System.Random.Stateful (StatefulGen)
-
---------------------------------------------------------------------------------
--- Kinds of terms
---------------------------------------------------------------------------------
-
-data WrappedTerm
-  = SingleTerm Term
-  | PairTerm Term Term
-  | GroupTerm [WrappedTerm]
-  deriving (Eq, Show, Generic)
-
--- | Recursively flatten wrapped list. That is, expand any groups out to their
--- individual entries.
-flattenWrappedList :: [WrappedTerm] -> [WrappedTerm]
-flattenWrappedList [] = []
-flattenWrappedList (GroupTerm 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]
-singleTermList [] = Just []
-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
 
 --------------------------------------------------------------------------------
 
@@ -89,7 +45,7 @@ data CTree f
   | Enum (Node f)
   | Unwrap (Node f)
   | Tag Word64 (Node f)
-  | WithGen (forall g m. StatefulGen g m => g -> m WrappedTerm) (Node f)
+  | WithGen CBORGenerator (Node f)
 
 -- | Traverse the CTree, carrying out the given operation at each node
 traverseCTree :: Monad m => (Node f -> m (Node g)) -> CTree f -> m (CTree g)

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

@@ -91,7 +91,7 @@ asMap cddl = foldl' go Map.empty rules
     go x (TopLevelRule r) = assignOrExtend x r
 
     assignOrExtend :: CDDLMap -> Rule -> CDDLMap
-    assignOrExtend m (Rule n gps assign tog _) = case assign of
+    assignOrExtend m (Rule n gps assign tog _ _) = case assign of
       -- Equals assignment
       AssignEq -> Map.insert n (toParametrised tog gps) m
       AssignExt -> Map.alter (extend tog gps) n m