WIP

Author: Soupstraw

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

@@ -25,7 +25,17 @@ import Codec.CBOR.Cuddle.CDDL (
   Value (..),
   ValueVariant (..),
  )
-import Codec.CBOR.Cuddle.CDDL.CTree (CTree, CTreeRoot' (..))
+import Codec.CBOR.Cuddle.CDDL.CTree (
+  CTree,
+  CTreeRoot' (..),
+  WrappedTerm,
+  flattenWrappedList,
+  pairTermList,
+  singleTermList,
+  pattern G,
+  pattern P,
+  pattern S,
+ )
 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 (..))
@@ -53,6 +63,7 @@ import System.Random.Stateful (
   Random,
   RandomGen (..),
   StateGenM (..),
+  StatefulGen (..),
   UniformRange (uniformRM),
   randomM,
   uniformByteStringM,
@@ -207,53 +218,11 @@ genPostlude pt = case pt of
   PTNil -> pure TNull
   PTUndefined -> pure $ TSimple 23
 
---------------------------------------------------------------------------------
--- 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 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
-
 --------------------------------------------------------------------------------
 -- Generator functions
 --------------------------------------------------------------------------------
 
-genForCTree :: RandomGen g => CTree MonoRef -> M g WrappedTerm
+genForCTree :: forall g. RandomGen g => CTree MonoRef -> M g WrappedTerm
 genForCTree (CTree.Literal v) = S <$> genValue v
 genForCTree (CTree.Postlude pt) = S <$> genPostlude pt
 genForCTree (CTree.Map nodes) = do
@@ -362,6 +331,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
 
 genForNode :: RandomGen g => CTree.Node MonoRef -> M g WrappedTerm
 genForNode = genForCTree <=< resolveIfRef
@@ -446,7 +416,8 @@ generateCBORTerm cddl n stdGen =
       genState = GenState {randomSeed = stdGen, depth = 1}
    in evalGen (genForName n) genEnv genState
 
-generateCBORTerm' :: RandomGen g => CTreeRoot' Identity MonoRef -> Name -> g -> (Term, g)
+generateCBORTerm' ::
+  (RandomGen g, StatefulGen g (M g)) => CTreeRoot' Identity MonoRef -> 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

@@ -145,7 +145,9 @@ validateCBOR' bs rule cddl@(CTreeRoot tree) =
 -- spec
 validateTerm ::
   MonadReader CDDL m =>
-  Term -> Rule -> m CBORTermResult
+  Term ->
+  Rule ->
+  m CBORTermResult
 validateTerm term rule =
   let f = case term of
         TInt i -> validateInteger (fromIntegral i)
@@ -183,7 +185,9 @@ validateTerm term rule =
 -- Ints, so we convert everything to Integer.
 validateInteger ::
   MonadReader CDDL m =>
-  Integer -> Rule -> m CDDLResult
+  Integer ->
+  Rule ->
+  m CDDLResult
 validateInteger i rule =
   ($ rule) <$> do
     getRule rule >>= \case
@@ -308,7 +312,9 @@ controlInteger i Ne ctrl =
 -- | Validating a `Float16`
 validateHalf ::
   MonadReader CDDL m =>
-  Float -> Rule -> m CDDLResult
+  Float ->
+  Rule ->
+  m CDDLResult
 validateHalf f rule =
   ($ rule) <$> do
     getRule rule >>= \case
@@ -343,7 +349,9 @@ controlHalf f Ne ctrl =
 -- | Validating a `Float32`
 validateFloat ::
   MonadReader CDDL m =>
-  Float -> Rule -> m CDDLResult
+  Float ->
+  Rule ->
+  m CDDLResult
 validateFloat f rule =
   ($ rule) <$> do
     getRule rule >>= \case
@@ -383,7 +391,9 @@ controlFloat f Ne ctrl =
 -- | Validating a `Float64`
 validateDouble ::
   MonadReader CDDL m =>
-  Double -> Rule -> m CDDLResult
+  Double ->
+  Rule ->
+  m CDDLResult
 validateDouble f rule =
   ($ rule) <$> do
     getRule rule >>= \case
@@ -430,7 +440,9 @@ controlDouble f Ne ctrl =
 -- | Validating a boolean
 validateBool ::
   MonadReader CDDL m =>
-  Bool -> Rule -> m CDDLResult
+  Bool ->
+  Rule ->
+  m CDDLResult
 validateBool b rule =
   ($ rule) <$> do
     getRule rule >>= \case
@@ -463,7 +475,9 @@ controlBool b Ne ctrl =
 -- | Validating a `TSimple`. It is unclear if this is used for anything else than undefined.
 validateSimple ::
   MonadReader CDDL m =>
-  Word8 -> Rule -> m CDDLResult
+  Word8 ->
+  Rule ->
+  m CDDLResult
 validateSimple 23 rule =
   ($ rule) <$> do
     getRule rule >>= \case
@@ -498,7 +512,9 @@ validateNull rule =
 -- | Validating a byte sequence
 validateBytes ::
   MonadReader CDDL m =>
-  BS.ByteString -> Rule -> m CDDLResult
+  BS.ByteString ->
+  Rule ->
+  m CDDLResult
 validateBytes bs rule =
   ($ rule) <$> do
     getRule rule >>= \case
@@ -517,7 +533,11 @@ validateBytes bs rule =
 -- | Controls for byte strings
 controlBytes ::
   forall m.
-  MonadReader CDDL m => BS.ByteString -> CtlOp -> Rule -> m (Either (Maybe CBORTermResult) ())
+  MonadReader CDDL m =>
+  BS.ByteString ->
+  CtlOp ->
+  Rule ->
+  m (Either (Maybe CBORTermResult) ())
 controlBytes bs Size ctrl =
   getRule ctrl >>= \case
     Literal (Value (VUInt (fromIntegral -> sz)) _) -> pure $ boolCtrl $ BS.length bs == sz
@@ -568,7 +588,9 @@ controlBytes bs Cborseq ctrl =
 -- | Validating text strings
 validateText ::
   MonadReader CDDL m =>
-  T.Text -> Rule -> m CDDLResult
+  T.Text ->
+  Rule ->
+  m CDDLResult
 validateText txt rule =
   ($ rule) <$> do
     getRule rule >>= \case
@@ -607,7 +629,10 @@ controlText s Regexp ctrl =
 -- | Validating a `TTagged`
 validateTagged ::
   MonadReader CDDL m =>
-  Word64 -> Term -> Rule -> m CDDLResult
+  Word64 ->
+  Term ->
+  Rule ->
+  m CDDLResult
 validateTagged tag term rule =
   ($ rule) <$> do
     getRule rule >>= \case
@@ -633,25 +658,25 @@ flattenGroup :: CDDL -> [Rule] -> [Rule]
 flattenGroup cddl nodes =
   mconcat
     [ case resolveIfRef cddl rule of
-        Literal {} -> [rule]
-        Postlude {} -> [rule]
-        Map {} -> [rule]
-        Array {} -> [rule]
-        Choice {} -> [rule]
-        KV {} -> [rule]
-        Occur {} -> [rule]
-        Range {} -> [rule]
-        Control {} -> [rule]
-        Enum e -> case resolveIfRef cddl e of
-          Group g -> flattenGroup cddl g
-          _ -> error "Malformed cddl"
-        Unwrap g -> case resolveIfRef cddl g of
-          Map n -> flattenGroup cddl n
-          Array n -> flattenGroup cddl n
-          Tag _ n -> [n]
-          _ -> error "Malformed cddl"
-        Tag {} -> [rule]
+      Literal {} -> [rule]
+      Postlude {} -> [rule]
+      Map {} -> [rule]
+      Array {} -> [rule]
+      Choice {} -> [rule]
+      KV {} -> [rule]
+      Occur {} -> [rule]
+      Range {} -> [rule]
+      Control {} -> [rule]
+      Enum e -> case resolveIfRef cddl e of
         Group g -> flattenGroup cddl g
+        _ -> error "Malformed cddl"
+      Unwrap g -> case resolveIfRef cddl g of
+        Map n -> flattenGroup cddl n
+        Array n -> flattenGroup cddl n
+        Tag _ n -> [n]
+        _ -> error "Malformed cddl"
+      Tag {} -> [rule]
+      Group g -> flattenGroup cddl g
     | rule <- nodes
     ]
 
@@ -725,7 +750,9 @@ isOptional rule =
 validateListWithExpandedRules ::
   forall m.
   MonadReader CDDL m =>
-  [Term] -> [Rule] -> m [(Rule, CBORTermResult)]
+  [Term] ->
+  [Rule] ->
+  m [(Rule, CBORTermResult)]
 validateListWithExpandedRules terms rules =
   go (zip terms rules)
   where
@@ -795,7 +822,9 @@ validateList terms rule =
 validateMapWithExpandedRules ::
   forall m.
   MonadReader CDDL m =>
-  [(Term, Term)] -> [Rule] -> m ([AMatchedItem], Maybe ANonMatchedItem)
+  [(Term, Term)] ->
+  [Rule] ->
+  m ([AMatchedItem], Maybe ANonMatchedItem)
 validateMapWithExpandedRules =
   go
   where
@@ -853,7 +882,9 @@ validateExpandedMap terms rules = go rules
 
 validateMap ::
   MonadReader CDDL m =>
-  [(Term, Term)] -> Rule -> m CDDLResult
+  [(Term, Term)] ->
+  Rule ->
+  m CDDLResult
 validateMap terms rule =
   ($ rule) <$> do
     getRule rule >>= \case
@@ -899,7 +930,10 @@ dummyRule = MRuleRef (Name "dummy" mempty)
 -- | Validate both rules
 ctrlAnd ::
   Monad m =>
-  (Rule -> m CDDLResult) -> Rule -> Rule -> m (Rule -> CDDLResult)
+  (Rule -> m CDDLResult) ->
+  Rule ->
+  Rule ->
+  m (Rule -> CDDLResult)
 ctrlAnd v tgt ctrl =
   v tgt >>= \case
     Valid _ ->

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

@@ -1,4 +1,5 @@
 {-# LANGUAGE DataKinds #-}
+{-# LANGUAGE PatternSynonyms #-}
 
 module Codec.CBOR.Cuddle.CDDL.CTree where
 
@@ -10,11 +11,55 @@ import Codec.CBOR.Cuddle.CDDL (
  )
 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
 
 --------------------------------------------------------------------------------
 
@@ -44,7 +89,7 @@ data CTree f
   | Enum (Node f)
   | Unwrap (Node f)
   | Tag Word64 (Node f)
-  deriving (Generic)
+  | WithGen (forall g m. StatefulGen g m => g -> m WrappedTerm) (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)
@@ -70,6 +115,7 @@ traverseCTree atNode (Control o t c) = do
 traverseCTree atNode (Enum ref) = Enum <$> atNode ref
 traverseCTree atNode (Unwrap ref) = Unwrap <$> atNode ref
 traverseCTree atNode (Tag i ref) = Tag i <$> atNode ref
+traverseCTree atNode (WithGen g ref) = WithGen g <$> atNode ref
 
 type Node f = f (CTree f)