cuddle 1.7.0.0 → 1.8.0.0

raw patch · 20 files changed

+252/−164 lines, 20 filesdep ~tree-diffPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: tree-diff

API changes (from Hackage documentation)

Files

• CHANGELOG.md +16/−6
• bin/Main.hs +4/−1
• cuddle.cabal +2/−2
• src/Codec/CBOR/Cuddle/CBOR/Gen.hs +1/−22
• src/Codec/CBOR/Cuddle/CBOR/Validator.hs +16/−8
• src/Codec/CBOR/Cuddle/CBOR/Validator/Trace.hs +14/−49
• src/Codec/CBOR/Cuddle/CDDL.hs +2/−39
• src/Codec/CBOR/Cuddle/CDDL/CtlOp.hs +0/−2
• src/Codec/CBOR/Cuddle/CDDL/Resolve.hs +42/−6
• src/Codec/CBOR/Cuddle/Comments.hs +1/−2
• src/Codec/CBOR/Cuddle/Huddle.hs +11/−0
• src/Codec/CBOR/Cuddle/Parser.hs +5/−6
• src/Codec/CBOR/Cuddle/Pretty.hs +5/−6
• test/Test/Codec/CBOR/Cuddle/CDDL/GeneratorSpec.hs +5/−6
• test/Test/Codec/CBOR/Cuddle/CDDL/Parser.hs +1/−0
• test/Test/Codec/CBOR/Cuddle/CDDL/Pretty.hs +1/−0
• test/Test/Codec/CBOR/Cuddle/CDDL/TreeDiff.hs +93/−0
• test/Test/Codec/CBOR/Cuddle/CDDL/Validator.hs +17/−7
• test/Test/Codec/CBOR/Cuddle/CDDL/Validator/Golden.hs +2/−2
• test/Test/Codec/CBOR/Cuddle/Huddle.hs +14/−0

@@ -1,5 +1,15 @@ # Changelog for `cuddle` +## 1.8.0.0++* Change `validateCBOR` return type to `Either ValidateCBORError (Evidenced ValidationTrace)`+* Remove `ToExpr` instances from all types+* Rename `MonoSimple` to `MonoSimplePhase`+* Remove `GenSimple` and `ValidatorPhaseSimple`; use `MonoSimplePhase` instead+* Unify `showSimple` into a single polymorphic helper in `Codec.CBOR.Cuddle.CDDL.Resolve`+* Export `IsChoosable (toChoice)`+* Add `choiceFromList` to fold a `NonEmpty` list into a `Choice` using `(/)`+ ## 1.7.0.0  * Rename `WrappedTerm` to `RuleTerm`@@ -60,7 +70,7 @@  ## 1.2.0.0 -* Add `Pretty` instance for `PTerm` +* Add `Pretty` instance for `PTerm` * Replace `ValidationResult` with `Evidenced ValidationTrace` * Move `ValidatorStageSimple` and `showSimple` to `Codec.CBOR.Cuddle.CBOR.Validator.Trace` * Add `Codec.CBOR.Cuddle.CBOR.Validator.Trace`@@ -70,11 +80,11 @@ * Removed `Codec.CBOR.Cuddle.Huddle.HuddleM` * Add `format-cbor` subcommand * Changed `--cbor` option of `validate` to a proper argument-* Added `binary` and `hex` output formats. Providing an output file argument to +* Added `binary` and `hex` output formats. Providing an output file argument to   `gen` no longer affects the output format. * Add `format-cbor` subcommand * Changed `--cbor` option of `validate` to a proper argument-* Added `binary` and `hex` output formats. Providing an output file argument to +* Added `binary` and `hex` output formats. Providing an output file argument to   `gen` no longer affects the output format. * Add `seed` and `size` options to `generate` subcommand * Replace `generateCBORTerm` with `generateFromName`@@ -107,7 +117,7 @@ * Changed `T2Ref` to take a `Rule` instead of `Named Type0` * Add `GroupDef`, `HIGroup` constructor now expects a `GroupDef` instead of `Named Group` * Changed the following type synonyms to proper datatypes:-  - `GRuleDef` +  - `GRuleDef`   - `GRuleCall` * Removed `Codec.CBOR.Cuddle.Huddle.Optics` * Changed the `comment` to take a `Comment` argument instead of `Text`@@ -137,9 +147,9 @@ * Move `PTerm` to `Codec.CBOR.Cuddle.CDDL.CTree` * Remove `CTreeRoot'` * Changed the type in `CTreeRoot` to a map of resolved `CTree`s-* Changed the type of the first argument for `generateCBORTerm` and +* Changed the type of the first argument for `generateCBORTerm` and   `generateCBORTerm'` to `CTreeRoot`-* Removed all exports in `Codec.CBOR.Cuddle.CBOR.Validator` except for +* Removed all exports in `Codec.CBOR.Cuddle.CBOR.Validator` except for   `validateCBOR`, `validateCBOR'`, `CBORTermResult` and `CDDLResult`  ## 1.0.0.0

@@ -446,7 +446,10 @@ runValidateCBOR :: BS.ByteString -> Name -> CTreeRoot ValidatorPhase -> TraceOptions -> IO () runValidateCBOR bs rule cddl traceOpts =   case validateCBOR bs rule cddl of-    Evidenced validity trc -> do+    Left err -> do+      putStrLnErr $ "CBOR validation failed:\n" <> show err+      exitFailure+    Right (Evidenced validity trc) -> do       T.putStrLn . Ansi.renderStrict . layoutPretty defaultLayoutOptions $         prettyValidationTrace traceOpts trc       putStrLn mempty

@@ -1,6 +1,6 @@ cabal-version: 3.4 name: cuddle-version: 1.7.0.0+version: 1.8.0.0 synopsis: CDDL Generator and test utilities description:   Cuddle is a library for generating and manipulating [CDDL](https://datatracker.ietf.org/doc/html/rfc8610).@@ -88,7 +88,6 @@     regex-tdfa >=1.3.2,     scientific >=0.3.7,     text >=2.0.2,-    tree-diff >=0.3,    hs-source-dirs: src   default-language: GHC2021@@ -136,6 +135,7 @@     Test.Codec.CBOR.Cuddle.CDDL.Parser     Test.Codec.CBOR.Cuddle.CDDL.Pretty     Test.Codec.CBOR.Cuddle.CDDL.Pretty.Golden+    Test.Codec.CBOR.Cuddle.CDDL.TreeDiff     Test.Codec.CBOR.Cuddle.CDDL.Validator     Test.Codec.CBOR.Cuddle.CDDL.Validator.Golden     Test.Codec.CBOR.Cuddle.Huddle

@@ -18,7 +18,6 @@   generateFromName,   generateFromGRef,   GenPhase,-  GenSimple,   XXCTree (..), ) where @@ -35,7 +34,6 @@ import Codec.CBOR.Cuddle.CDDL.CTree (   CTree (..),   PTerm (..),-  foldCTree,   nintMin,   uintMax,  )@@ -51,8 +49,7 @@   liftAntiGen,   withAntiGen,  )-import Codec.CBOR.Cuddle.CDDL.Resolve (XXCTree (..))-import Codec.CBOR.Cuddle.IndexMappable (IndexMappable (..))+import Codec.CBOR.Cuddle.CDDL.Resolve (XXCTree (..), showSimple) import Codec.CBOR.Term (Term (..)) import Codec.CBOR.Term qualified as CBOR import Codec.CBOR.Write qualified as CBOR@@ -123,21 +120,6 @@ scale f m = sized $ \n -> resize (f n) m  ----------------------------------------------------------------------------------- MonoSimple-----------------------------------------------------------------------------------type data GenSimple--newtype instance XXCTree GenSimple = GenSimpleRef Name-  deriving (Show)--instance IndexMappable CTree GenPhase GenSimple where-  mapIndex = foldCTree mapExt mapIndex-    where-      mapExt (GenRef n) = CTreeE $ GenSimpleRef n-      mapExt (GenGenerator _ x) = mapIndex x---------------------------------------------------------------------------------- -- Generator infrastructure -------------------------------------------------------------------------------- @@ -298,9 +280,6 @@ singleTermList (SingleTerm x : xs) = (x :) <$> singleTermList xs singleTermList (PairTerm _ y : xs) = (y :) <$> singleTermList xs singleTermList _ = Nothing--showSimple :: CTree GenPhase -> String-showSimple = show . mapIndex @_ @_ @GenSimple  -- | Remove all negative generators from the `AntiGen`. dropNegativeGen :: AntiGen a -> AntiGen a

@@ -8,6 +8,7 @@   validateFromName,   validateFromGRef,   ValidatorPhase,+  ValidateCBORError (..), ) where  import Codec.CBOR.Cuddle.CBOR.Validator.Trace (@@ -18,11 +19,9 @@   MapValidationTrace (..),   SValidity (..),   ValidationTrace (..),-  XXCTree (..),   evidence,   isValid,   mapTrace,-  showSimple,  ) import Codec.CBOR.Cuddle.CDDL hiding (CDDL, Group, Rule) import Codec.CBOR.Cuddle.CDDL.CTree@@ -34,8 +33,10 @@   ValidateEnv (..),   Validator,   ValidatorPhase,+  XXCTree (..),   runValidator,  )+import Codec.CBOR.Cuddle.CDDL.Resolve (showSimple) import Codec.CBOR.Cuddle.IndexMappable (IndexMappable (..)) import Codec.CBOR.Read import Codec.CBOR.Term@@ -59,21 +60,28 @@ import GHC.Stack (HasCallStack) import Text.Regex.TDFA +data ValidateCBORError+  = DecodingFailed DeserialiseFailure+  | LeftoverBytes BSL.ByteString+  | RuleDoesNotExist Name+  deriving (Show, Eq)+ -------------------------------------------------------------------------------- -- Main entry point- validateCBOR ::   HasCallStack =>   BS.ByteString ->   Name ->   CTreeRoot ValidatorPhase ->-  Evidenced ValidationTrace-validateCBOR bs rule cddl@(CTreeRoot tree) =+  Either ValidateCBORError (Evidenced ValidationTrace)+validateCBOR bs ruleName cddl@(CTreeRoot tree) =   case deserialiseFromBytes decodeTerm (BSL.fromStrict bs) of-    Left e -> error $ show e+    Left e -> Left $ DecodingFailed e     Right (rest, term)-      | BSL.null rest -> validateTerm cddl term (tree Map.! rule)-      | otherwise -> error $ "Leftover bytes in CBOR: " <> show rest+      | BSL.null rest -> case tree Map.!? ruleName of+          Just rule -> Right $ validateTerm cddl term rule+          Nothing -> Left $ RuleDoesNotExist ruleName+      | otherwise -> Left $ LeftoverBytes rest  -- | Validate a CBOR 'Term' against a top-level rule from inside a custom -- validator.

@@ -10,8 +10,6 @@ {-# LANGUAGE UndecidableInstances #-}  module Codec.CBOR.Cuddle.CBOR.Validator.Trace (-  ValidatorPhaseSimple,-  XXCTree (..),   SValidity (..),   Validity (..),   ValidationTrace (..),@@ -23,7 +21,6 @@   TraceOptions (..),   Progress (..),   defaultTraceOptions,-  showSimple,   isValid,   prettyValidationTrace,   showValidationTrace,@@ -34,11 +31,9 @@ ) where  import Codec.CBOR.Cuddle.CDDL (Name (..))-import Codec.CBOR.Cuddle.CDDL.CTree (CTree (..), CTreeRoot (..), Node, XXCTree, foldCTree)+import Codec.CBOR.Cuddle.CDDL.CTree (CTree (..)) import Codec.CBOR.Cuddle.CDDL.CtlOp (CtlOp)-import Codec.CBOR.Cuddle.CDDL.Custom.Validator (ValidatorPhase)-import Codec.CBOR.Cuddle.CDDL.Resolve (XXCTree (..))-import Codec.CBOR.Cuddle.IndexMappable (IndexMappable (..))+import Codec.CBOR.Cuddle.CDDL.Resolve (MonoSimplePhase) import Codec.CBOR.Term (Term) import Data.Foldable (Foldable (..)) import Data.Function (on)@@ -63,36 +58,6 @@ import Prettyprinter.Render.Terminal qualified as Ansi  ----------------------------------------------------------------------------------- ValidatorPhase--type data ValidatorPhaseSimple--newtype instance XXCTree ValidatorPhaseSimple = VRuleRefSimple Name--instance Pretty (XXCTree ValidatorPhaseSimple) where-  pretty (VRuleRefSimple n) = pretty n--instance IndexMappable CTreeRoot ValidatorPhase ValidatorPhaseSimple where-  mapIndex (CTreeRoot m) = CTreeRoot $ mapIndex <$> m--instance IndexMappable CTree ValidatorPhase ValidatorPhaseSimple where-  mapIndex = foldCTree mapExt mapIndex-    where-      mapExt (VRuleRef n) = CTreeE $ VRuleRefSimple n-      mapExt (VValidator _ x) = mapIndex x--showSimple ::-  ( IndexMappable a ValidatorPhase ValidatorPhaseSimple-  , Show (a ValidatorPhaseSimple)-  ) =>-  a ValidatorPhase -> String-showSimple = show . mapIndex @_ @_ @ValidatorPhaseSimple--deriving instance Eq (Node ValidatorPhaseSimple)--deriving instance Show (Node ValidatorPhaseSimple)---------------------------------------------------------------------------------- -- Validation result  type data Validity@@ -116,7 +81,7 @@  data ControlInfo = ControlInfo   { ciOp :: CtlOp-  , ciRule :: CTree ValidatorPhaseSimple+  , ciRule :: CTree MonoSimplePhase   }   deriving (Show) @@ -124,13 +89,13 @@   pretty ControlInfo {..} = pretty ciOp <+> pretty ciRule  data ValidationTrace (v :: Validity) where-  UnapplicableRule :: CTree ValidatorPhaseSimple -> ValidationTrace IsInvalid-  TerminalRule :: CTree ValidatorPhaseSimple -> ValidationTrace IsValid+  UnapplicableRule :: CTree MonoSimplePhase -> ValidationTrace IsInvalid+  TerminalRule :: CTree MonoSimplePhase -> ValidationTrace IsValid   ControlTrace :: ControlInfo -> ValidationTrace IsValid -> ValidationTrace IsValid   ReferenceRule :: Name -> ValidationTrace v -> ValidationTrace v   CustomFailure :: Text -> ValidationTrace IsInvalid   CustomSuccess :: ValidationTrace IsValid-  UnsatisfiedControl :: CtlOp -> CTree ValidatorPhaseSimple -> ValidationTrace IsInvalid+  UnsatisfiedControl :: CtlOp -> CTree MonoSimplePhase -> ValidationTrace IsInvalid   ChoiceBranch :: Int -> ValidationTrace IsValid -> ValidationTrace IsValid   ListTrace :: ListValidationTrace v -> ValidationTrace v   MapTrace :: MapValidationTrace v -> ValidationTrace v@@ -143,18 +108,18 @@   ListValidationDone :: ListValidationTrace IsValid   ListValidationLeftoverTerms ::     NonEmpty Term ->-    Maybe (CTree ValidatorPhaseSimple, ValidationTrace IsInvalid) ->+    Maybe (CTree MonoSimplePhase, ValidationTrace IsInvalid) ->     ListValidationTrace IsInvalid   ListValidationUnappliedRule ::-    CTree ValidatorPhaseSimple ->+    CTree MonoSimplePhase ->     ListValidationTrace IsInvalid   ListValidationConsume ::-    CTree ValidatorPhaseSimple ->+    CTree MonoSimplePhase ->     ValidationTrace IsValid ->     ListValidationTrace v ->     ListValidationTrace v   ListValidationMissingRequired ::-    CTree ValidatorPhaseSimple ->+    CTree MonoSimplePhase ->     ValidationTrace IsInvalid ->     ListValidationTrace IsInvalid   ListValidationConsumeGroup ::@@ -173,16 +138,16 @@   MapValidationDone :: MapValidationTrace IsValid   MapValidationLeftoverKVs ::     (Term, Term) ->-    Maybe (CTree ValidatorPhaseSimple, MapValidationTrace IsInvalid) ->+    Maybe (CTree MonoSimplePhase, MapValidationTrace IsInvalid) ->     MapValidationTrace IsInvalid-  MapValidationUnappliedRules :: NonEmpty (CTree ValidatorPhaseSimple) -> MapValidationTrace IsInvalid+  MapValidationUnappliedRules :: NonEmpty (CTree MonoSimplePhase) -> MapValidationTrace IsInvalid   MapValidationInvalidValue ::-    CTree ValidatorPhaseSimple ->+    CTree MonoSimplePhase ->     ValidationTrace IsValid ->     ValidationTrace IsInvalid ->     MapValidationTrace IsInvalid   MapValidationConsume ::-    CTree ValidatorPhaseSimple ->+    CTree MonoSimplePhase ->     ValidationTrace IsValid ->     ValidationTrace IsValid ->     MapValidationTrace v ->

@@ -60,7 +60,6 @@ import Data.Maybe (mapMaybe) import Data.String (IsString (..)) import Data.Text qualified as T-import Data.TreeDiff (ToExpr) import Data.Word (Word64, Word8) import GHC.Base (Constraint, Type) import GHC.Generics (Generic)@@ -101,8 +100,6 @@  deriving instance ForAllExtensions i Show => Show (CDDL i) -deriving instance ForAllExtensions i ToExpr => ToExpr (CDDL i)- ruleTopLevel :: TopLevel i -> Maybe (Rule i) ruleTopLevel (TopLevelRule r) = Just r ruleTopLevel _ = Nothing@@ -132,8 +129,6 @@  deriving instance ForAllExtensions i Show => Show (TopLevel i) -deriving instance ForAllExtensions i ToExpr => ToExpr (TopLevel i)- -- | --  A name can consist of any of the characters from the set {"A" to --  "Z", "a" to "z", "0" to "9", "_", "-", "@", ".", "$"}, starting@@ -166,8 +161,6 @@ newtype GRef = GRef T.Text   deriving (Show) -deriving anyclass instance ToExpr Name- instance IsString Name where   fromString = Name . T.pack @@ -197,7 +190,6 @@ --   side the first entry in the choice being created.) data Assign = AssignEq | AssignExt   deriving (Eq, Generic, Show)-  deriving anyclass (ToExpr)  -- | --  Generics@@ -223,8 +215,6 @@  deriving instance Show (XTerm i) => Show (GenericParameters i) -deriving anyclass instance ToExpr (XTerm i) => ToExpr (GenericParameters i)- data GenericParameter i = GenericParameter   { gpName :: Name   , gpExt :: XTerm i@@ -235,8 +225,6 @@  deriving instance Show (XTerm i) => Show (GenericParameter i) -deriving anyclass instance ToExpr (XTerm i) => ToExpr (GenericParameter i)- instance CollectComments (XTerm i) => CollectComments (GenericParameter i)  instance HasComment (XTerm i) => HasComment (GenericParameter i) where@@ -250,8 +238,6 @@  deriving instance ForAllExtensions i Show => Show (GenericArg i) -deriving anyclass instance ForAllExtensions i ToExpr => ToExpr (GenericArg i)- instance ForAllExtensions i CollectComments => CollectComments (GenericArg i)  -- |@@ -290,8 +276,6 @@  deriving instance ForAllExtensions i Show => Show (Rule i) -deriving instance ForAllExtensions i ToExpr => ToExpr (Rule i)- instance HasComment (XRule i) => HasComment (Rule i) where   commentL = #ruleExt % commentL @@ -306,13 +290,11 @@ --   included for ".." and excluded for "...". data RangeBound = ClOpen | Closed   deriving (Eq, Generic, Show)-  deriving anyclass (ToExpr)  instance Hashable RangeBound  data TyOp = RangeOp RangeBound | CtrlOp CtlOp   deriving (Eq, Generic, Show)-  deriving anyclass (ToExpr)  data TypeOrGroup i = TOGType (Type0 i) | TOGGroup (GroupEntry i)   deriving (Generic)@@ -321,8 +303,6 @@  deriving instance ForAllExtensions i Show => Show (TypeOrGroup i) -deriving instance ForAllExtensions i ToExpr => ToExpr (TypeOrGroup i)- instance ForAllExtensions i CollectComments => CollectComments (TypeOrGroup i)  {-- |@@ -393,8 +373,6 @@  deriving instance ForAllExtensions i Show => Show (Type0 i) -deriving anyclass instance ForAllExtensions i ToExpr => ToExpr (Type0 i)- instance ForAllExtensions i CollectComments => CollectComments (Type0 i)  -- |@@ -410,8 +388,6 @@  deriving instance ForAllExtensions i Show => Show (Type1 i) -deriving instance ForAllExtensions i ToExpr => ToExpr (Type1 i)- instance HasComment (XTerm i) => HasComment (Type1 i) where   commentL = #t1Comment % commentL @@ -459,8 +435,6 @@  deriving instance ForAllExtensions i Show => Show (Type2 i) -deriving instance ForAllExtensions i ToExpr => ToExpr (Type2 i)- instance ForAllExtensions i CollectComments => CollectComments (Type2 i)  -- |@@ -483,7 +457,6 @@   | OIOneOrMore   | OIBounded (Maybe Word64) (Maybe Word64)   deriving (Eq, Generic, Show)-  deriving anyclass (ToExpr)  instance Hashable OccurrenceIndicator @@ -498,8 +471,6 @@  deriving instance ForAllExtensions i Show => Show (Group i) -deriving anyclass instance ForAllExtensions i ToExpr => ToExpr (Group i)- instance HasComment (XTerm i) => HasComment (Group i) where   commentL = #unGroup % commentL @@ -516,8 +487,6 @@  deriving instance ForAllExtensions i Show => Show (GrpChoice i) -deriving instance ForAllExtensions i ToExpr => ToExpr (GrpChoice i)- instance HasComment (XTerm i) => HasComment (GrpChoice i) where   commentL = #gcComment % commentL @@ -542,8 +511,6 @@  deriving instance ForAllExtensions i Show => Show (GroupEntry i) -deriving instance ForAllExtensions i ToExpr => ToExpr (GroupEntry i)- instance ForAllExtensions i CollectComments => CollectComments (GroupEntry i) where   collectComments (GroupEntry _ c x) = collectComments c <> collectComments x @@ -557,8 +524,6 @@  deriving instance ForAllExtensions i Show => Show (GroupEntryVariant i) -deriving instance ForAllExtensions i ToExpr => ToExpr (GroupEntryVariant i)- instance HasComment (XTerm i) => HasComment (GroupEntry i) where   commentL = #geExt % commentL @@ -585,11 +550,9 @@  deriving instance ForAllExtensions i Show => Show (MemberKey i) -deriving instance ForAllExtensions i ToExpr => ToExpr (MemberKey i)- data Value = Value ValueVariant Comment   deriving (Eq, Generic, Show, Default)-  deriving anyclass (ToExpr, Hashable, CollectComments)+  deriving anyclass (Hashable, CollectComments)  value :: ValueVariant -> Value value x = Value x mempty@@ -605,4 +568,4 @@   | VBytes B.ByteString   | VBool Bool   deriving (Eq, Generic, Show, Default)-  deriving anyclass (ToExpr, Hashable, CollectComments)+  deriving anyclass (Hashable, CollectComments)

@@ -4,7 +4,6 @@ module Codec.CBOR.Cuddle.CDDL.CtlOp where  import Data.Hashable (Hashable)-import Data.TreeDiff (ToExpr) import GHC.Generics (Generic)  -- | A _control_ allows relating a _target_ type with a _controller_ type@@ -35,6 +34,5 @@   | Ne   | Default   deriving (Eq, Generic, Show)-  deriving anyclass (ToExpr)  instance Hashable CtlOp

@@ -35,7 +35,8 @@   fullResolveCDDL,   NameResolutionFailure (..),   MonoReferenced,-  MonoSimple,+  MonoSimplePhase,+  showSimple,   XXCTree (..), ) where@@ -479,20 +480,55 @@ -- | We introduce additional bindings in the state type MonoState = Map.Map Name (CTree MonoReferenced) -type data MonoSimple+-- | A simplified phase reachable from any of the function-bearing post-mono+-- phases ('MonoReferenced', 'GenPhase', 'ValidatorPhase'). It strips the+-- generator/validator extensions so the tree can be `Show`n, `Eq`-compared,+-- and pretty-printed for debug output.+type data MonoSimplePhase -instance IndexMappable CTree MonoReferenced MonoSimple where+newtype instance XXCTree MonoSimplePhase = MSimpleRef Name+  deriving (Generic, Show, Eq)++instance Pretty (XXCTree MonoSimplePhase) where+  pretty (MSimpleRef n) = pretty n++instance IndexMappable CTree MonoReferenced MonoSimplePhase where   mapIndex = foldCTree mapExt mapIndex     where       mapExt (MRuleRef n) = CTreeE $ MSimpleRef n       mapExt (MGenerator _ x) = mapIndex x       mapExt (MValidator _ x) = mapIndex x -instance IndexMappable CTreeRoot MonoReferenced MonoSimple where+instance IndexMappable CTreeRoot MonoReferenced MonoSimplePhase where   mapIndex (CTreeRoot m) = CTreeRoot $ mapIndex <$> m -newtype instance XXCTree MonoSimple = MSimpleRef Name-  deriving (Generic, Show, Eq)+instance IndexMappable CTree GenPhase MonoSimplePhase where+  mapIndex = foldCTree mapExt mapIndex+    where+      mapExt (GenRef n) = CTreeE $ MSimpleRef n+      mapExt (GenGenerator _ x) = mapIndex x++instance IndexMappable CTreeRoot GenPhase MonoSimplePhase where+  mapIndex (CTreeRoot m) = CTreeRoot $ mapIndex <$> m++instance IndexMappable CTree ValidatorPhase MonoSimplePhase where+  mapIndex = foldCTree mapExt mapIndex+    where+      mapExt (VRuleRef n) = CTreeE $ MSimpleRef n+      mapExt (VValidator _ x) = mapIndex x++instance IndexMappable CTreeRoot ValidatorPhase MonoSimplePhase where+  mapIndex (CTreeRoot m) = CTreeRoot $ mapIndex <$> m++-- | Project any phase that maps to 'MonoSimplePhase' down to a `Show`able+-- representation. Used for debug output by `Gen`, `Validator`, etc.+showSimple ::+  forall a phase.+  ( IndexMappable a phase MonoSimplePhase+  , Show (a MonoSimplePhase)+  ) =>+  a phase -> String+showSimple = show . mapIndex @_ @_ @MonoSimplePhase  -- | Monad to run the monomorphisation process. We need some additional -- capabilities for this, so 'Either' doesn't fully cut it anymore.

@@ -28,7 +28,6 @@ import Data.List.NonEmpty (NonEmpty (..)) import Data.String (IsString (..)) import Data.Text qualified as T-import Data.TreeDiff (ToExpr) import Data.Void (Void, absurd) import Data.Word (Word16, Word32, Word64, Word8) import GHC.Generics (Generic (..), K1 (..), M1 (..), U1 (..), V1, (:*:) (..), (:+:) (..))@@ -37,7 +36,7 @@ newtype Comment = Comment [T.Text]   deriving (Eq, Ord, Generic, Show)   deriving newtype (Semigroup, Monoid)-  deriving anyclass (ToExpr, Hashable)+  deriving anyclass (Hashable)  unComment :: Comment -> [T.Text] unComment (Comment c) = c

@@ -57,6 +57,8 @@   opt,    -- * Choices+  IsChoosable (toChoice),+  choiceFromList,   (/),   seal,   sarr,@@ -937,6 +939,15 @@     go (ChoiceOf x' b') c = ChoiceOf x' (go b' c)  infixl 9 /++-- | Takes a `NonEmpty` list of Huddle choosable terms and folds over them with+-- '(/)' to create a 'Choice'.+--+-- @+--   choiceFromList $ NE.fromList $ [tag t (arr $ fromList [0 <+ a x]) | t <- [121 .. 127]]+-- @+choiceFromList :: IsChoosable a b => NE.NonEmpty a -> Choice b+choiceFromList terms = foldl1 (/) $ fmap toChoice terms  -- Choices within maps or arrays --

@@ -35,7 +35,6 @@ import Data.Text (Text) import Data.Text qualified as T import Data.Text.Encoding (encodeUtf8)-import Data.TreeDiff (ToExpr) import Data.Void (Void) import GHC.Generics (Generic) import GHC.Word (Word64, Word8)@@ -48,19 +47,19 @@ type data ParserStage  newtype instance XXTopLevel ParserStage = ParserXXTopLevel Comment-  deriving (Generic, Show, Eq, ToExpr)+  deriving (Generic, Show, Eq)  newtype instance XXType2 ParserStage = ParserXXType2 Void-  deriving (Generic, Show, Eq, ToExpr)+  deriving (Generic, Show, Eq)  newtype instance XTerm ParserStage = ParserXTerm {unParserXTerm :: Comment}-  deriving (Generic, Semigroup, Monoid, Show, Eq, ToExpr)+  deriving (Generic, Semigroup, Monoid, Show, Eq)  newtype instance XRule ParserStage = ParserXRule {unParserXRule :: Comment}-  deriving (Generic, Semigroup, Monoid, Show, Eq, ToExpr)+  deriving (Generic, Semigroup, Monoid, Show, Eq)  newtype instance XCddl ParserStage = ParserXCddl [Comment]-  deriving (Generic, Semigroup, Monoid, Show, Eq, ToExpr)+  deriving (Generic, Semigroup, Monoid, Show, Eq)  instance HasComment (XTerm ParserStage) where   commentL = #unParserXTerm

@@ -45,7 +45,6 @@ import Data.String (IsString, fromString) import Data.Text (Text) import Data.Text qualified as T-import Data.TreeDiff (ToExpr) import Data.Void (Void, absurd) import GHC.Generics (Generic) import Optics.Core ((^.))@@ -55,19 +54,19 @@ type data PrettyStage  newtype instance XXTopLevel PrettyStage = PrettyXXTopLevel Comment-  deriving (Generic, CollectComments, ToExpr, Show, Eq)+  deriving (Generic, CollectComments, Show, Eq)  newtype instance XXType2 PrettyStage = PrettyXXType2 Void-  deriving (Generic, CollectComments, ToExpr, Show, Eq)+  deriving (Generic, CollectComments, Show, Eq)  newtype instance XTerm PrettyStage = PrettyXTerm {unPrettyXTerm :: Comment}-  deriving (Generic, CollectComments, Semigroup, Monoid, IsString, ToExpr, Show, Eq)+  deriving (Generic, CollectComments, Semigroup, Monoid, IsString, Show, Eq)  newtype instance XCddl PrettyStage = PrettyXCddl [Comment]-  deriving (Generic, CollectComments, ToExpr, Show, Eq)+  deriving (Generic, CollectComments, Show, Eq)  newtype instance XRule PrettyStage = PrettyXRule {unPrettyXRule :: Comment}-  deriving (Generic, CollectComments, ToExpr, Show, Eq)+  deriving (Generic, CollectComments, Show, Eq)   deriving newtype (Default)  instance HasComment (XTerm PrettyStage) where

@@ -5,11 +5,10 @@ module Test.Codec.CBOR.Cuddle.CDDL.GeneratorSpec (spec) where  import Codec.CBOR.Cuddle.CBOR.Gen (GenPhase, generateFromName)-import Codec.CBOR.Cuddle.CBOR.Validator (validateCBOR) import Codec.CBOR.Cuddle.CDDL (Name) import Codec.CBOR.Cuddle.CDDL.CTree (CTreeRoot (..)) import Codec.CBOR.Cuddle.CDDL.Custom.Generator (GenConfig (..), runCBORGen)-import Codec.CBOR.Cuddle.CDDL.Resolve (MonoReferenced, MonoSimple, fullResolveCDDL)+import Codec.CBOR.Cuddle.CDDL.Resolve (MonoReferenced, MonoSimplePhase, fullResolveCDDL) import Codec.CBOR.Cuddle.Huddle (Huddle, toCDDL) import Codec.CBOR.Cuddle.IndexMappable (IndexMappable (..), mapCDDLDropExt) import Codec.CBOR.Pretty (prettyHexEnc)@@ -33,7 +32,7 @@   tagRangeExample,   taggedUintExample,  )-import Test.Codec.CBOR.Cuddle.CDDL.Validator (expectInvalid, genAndValidateRule)+import Test.Codec.CBOR.Cuddle.CDDL.Validator (expectInvalid, genAndValidateRule, validateCBOR_) import Test.Hspec (HasCallStack, Spec, describe, runIO, shouldSatisfy, xdescribe) import Test.Hspec.Core.Spec (SpecM) import Test.Hspec.QuickCheck (prop)@@ -66,7 +65,7 @@   res@ZapResult {zrValue} <- zapAntiGenResult 1 . runCBORGen cfg $ generateFromName name   let     bs = toStrictByteString $ encodeTerm zrValue-    validationRes = validateCBOR bs name $ mapIndex cddl+    validationRes = validateCBOR_ bs name $ mapIndex cddl     failMsg =       unlines         [ case deserialiseFromBytes decodeTerm (LBS.fromStrict bs) of@@ -80,7 +79,7 @@ zapInvalidatesHuddle :: String -> Huddle -> Spec zapInvalidatesHuddle n huddle = do   cddl <- tryResolveHuddle huddle-  prop n . counterexample (TL.unpack . pShow $ mapIndex @_ @_ @MonoSimple cddl) $+  prop n . counterexample (TL.unpack . pShow $ mapIndex @_ @_ @MonoSimplePhase cddl) $     expectZapInvalidates cddl "root"  -- | Test that generated values are valid for a Huddle schema@@ -184,4 +183,4 @@         . classify tagChanged "tag changed"         . classify innerValueZapped "inner value zapped"         $ expectInvalid-          (validateCBOR (toStrictByteString $ encodeTerm zrValue) "root" $ mapIndex taggedBytesCddl)+          (validateCBOR_ (toStrictByteString $ encodeTerm zrValue) "root" $ mapIndex taggedBytesCddl)

@@ -15,6 +15,7 @@ import Prettyprinter.Render.String (renderString) import Prettyprinter.Render.Text (renderStrict) import Test.Codec.CBOR.Cuddle.CDDL.Gen qualified as Gen ()+import Test.Codec.CBOR.Cuddle.CDDL.TreeDiff () import Test.Hspec import Test.Hspec.Megaparsec import Test.QuickCheck

@@ -37,6 +37,7 @@ import Prettyprinter (Pretty (..), defaultLayoutOptions, layoutPretty) import Prettyprinter.Render.String (renderString) import Test.Codec.CBOR.Cuddle.CDDL.Gen ()+import Test.Codec.CBOR.Cuddle.CDDL.TreeDiff () import Test.HUnit (assertEqual) import Test.Hspec (Expectation, Spec, describe, it, runIO, shouldBe, xit) import Test.Hspec.QuickCheck (xprop)

@@ -0,0 +1,93 @@+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -Wno-orphans #-}++module Test.Codec.CBOR.Cuddle.CDDL.TreeDiff () where++import Codec.CBOR.Cuddle.CDDL (+  Assign,+  CDDL,+  ForAllExtensions,+  GenericArg,+  GenericParameter,+  GenericParameters,+  Group,+  GroupEntry,+  GroupEntryVariant,+  GrpChoice,+  MemberKey,+  Name,+  OccurrenceIndicator,+  RangeBound,+  Rule,+  TopLevel,+  TyOp,+  Type0,+  Type1,+  Type2,+  TypeOrGroup,+  Value,+  ValueVariant,+  XCddl,+ )+import Codec.CBOR.Cuddle.CDDL.CtlOp (CtlOp)+import Codec.CBOR.Cuddle.Comments (Comment)+import Codec.CBOR.Cuddle.Pretty (PrettyStage, XRule, XTerm, XXTopLevel, XXType2)+import Data.TreeDiff (ToExpr)++instance ToExpr Name++instance ForAllExtensions p ToExpr => ToExpr (GenericParameter p)++instance ForAllExtensions p ToExpr => ToExpr (GenericParameters p)++instance ForAllExtensions p ToExpr => ToExpr (GenericArg p)++instance ToExpr Comment++instance ToExpr ValueVariant++instance ToExpr Value++instance ForAllExtensions p ToExpr => ToExpr (MemberKey p)++instance ForAllExtensions p ToExpr => ToExpr (GroupEntryVariant p)++instance ToExpr OccurrenceIndicator++instance ToExpr CtlOp++instance ToExpr RangeBound++instance ToExpr TyOp++instance ToExpr Assign++instance ForAllExtensions p ToExpr => ToExpr (GroupEntry p)++instance ForAllExtensions p ToExpr => ToExpr (GrpChoice p)++instance ForAllExtensions p ToExpr => ToExpr (Group p)++instance ForAllExtensions p ToExpr => ToExpr (Type2 p)++instance ForAllExtensions p ToExpr => ToExpr (Type1 p)++instance ForAllExtensions p ToExpr => ToExpr (Type0 p)++instance ForAllExtensions p ToExpr => ToExpr (TypeOrGroup p)++instance ForAllExtensions p ToExpr => ToExpr (Rule p)++instance ForAllExtensions p ToExpr => ToExpr (TopLevel p)++instance ForAllExtensions p ToExpr => ToExpr (CDDL p)++instance ToExpr (XCddl PrettyStage)++instance ToExpr (XTerm PrettyStage)++instance ToExpr (XRule PrettyStage)++instance ToExpr (XXTopLevel PrettyStage)++instance ToExpr (XXType2 PrettyStage)

@@ -8,10 +8,12 @@   expectInvalid,   genAndValidateCddl,   genAndValidateRule,+  validateCBOR_, ) where  import Codec.CBOR.Cuddle.CBOR.Gen (generateFromName) import Codec.CBOR.Cuddle.CBOR.Validator (+  ValidatorPhase,   validateCBOR,  ) import Codec.CBOR.Cuddle.CBOR.Validator.Trace (@@ -96,6 +98,14 @@  ) import Text.Megaparsec (runParser) +validateCBOR_ ::+  HasCallStack =>+  BS.ByteString ->+  Name ->+  CTreeRoot ValidatorPhase ->+  Evidenced ValidationTrace+validateCBOR_ bs n cddl = either (\e -> error $ "validateCBOR failed:\n" <> show e) id $ validateCBOR bs n cddl+ -- | Test that a specific rule in a resolved CDDL generates valid values genAndValidateRule :: String -> Name -> CTreeRoot MonoReferenced -> Spec genAndValidateRule description name resolvedCddl =@@ -109,7 +119,7 @@     cborTerm <- runAntiGen . runCBORGen genCfg $ generateFromName name     let       generatedCbor = toStrictByteString $ encodeTerm cborTerm-      res = validateCBOR generatedCbor name (mapIndex resolvedCddl)+      res = validateCBOR_ generatedCbor name (mapIndex resolvedCddl)       extraInfo =         unlines           [ "CBOR term:"@@ -267,7 +277,7 @@       Right root -> root       Left err -> error $ show err     bs = toStrictByteString $ encodeTerm term-  validateCBOR bs name (mapIndex resolvedCddl)+  validateCBOR_ bs name (mapIndex resolvedCddl)  expectValid :: Evidenced ValidationTrace -> Expectation expectValid (Evidenced SValid _) = pure ()@@ -340,19 +350,19 @@            in either (error . show) id . fullResolveCDDL . appendPostlude $ mapCDDLDropExt cddl       it "Validates a bignum >= 2^64 against biguint" $         expectValid $-          validateCBOR bignumCBOR "a" (mapIndex $ resolveCDDL "a = biguint")+          validateCBOR_ bignumCBOR "a" (mapIndex $ resolveCDDL "a = biguint")       it "Validates a bignum >= 2^64 against bigint" $         expectValid $-          validateCBOR bignumCBOR "a" (mapIndex $ resolveCDDL "a = bigint")+          validateCBOR_ bignumCBOR "a" (mapIndex $ resolveCDDL "a = bigint")       it "Validates a bignum >= 2^64 against integer" $         expectValid $-          validateCBOR bignumCBOR "a" (mapIndex $ resolveCDDL "a = integer")+          validateCBOR_ bignumCBOR "a" (mapIndex $ resolveCDDL "a = integer")       it "Rejects a bignum >= 2^64 against int" $         expectInvalid $-          validateCBOR bignumCBOR "a" (mapIndex $ resolveCDDL "a = int")+          validateCBOR_ bignumCBOR "a" (mapIndex $ resolveCDDL "a = int")       it "Rejects a bignum >= 2^64 against uint" $         expectInvalid $-          validateCBOR bignumCBOR "a" (mapIndex $ resolveCDDL "a = uint")+          validateCBOR_ bignumCBOR "a" (mapIndex $ resolveCDDL "a = uint")    describe "Custom validator" $ do     describe "Positive" $ do

@@ -3,7 +3,6 @@  module Test.Codec.CBOR.Cuddle.CDDL.Validator.Golden (spec) where -import Codec.CBOR.Cuddle.CBOR.Validator (validateCBOR) import Codec.CBOR.Cuddle.CBOR.Validator.Trace (   defaultTraceOptions,   foldEvidenced,@@ -38,6 +37,7 @@   mapNoMatchingKeyExample,   refTermExample,  )+import Test.Codec.CBOR.Cuddle.CDDL.Validator (validateCBOR_) import Test.Hspec (Spec, describe, it) import Test.Hspec.Golden (Golden (..)) @@ -115,7 +115,7 @@       Ansi.renderStrict         . layoutPretty defaultLayoutOptions         . foldEvidenced (prettyValidationTrace defaultTraceOptions)-        . validateCBOR bs n+        . validateCBOR_ bs n         $ mapIndex treeRoot  spec :: Spec

@@ -12,6 +12,7 @@ import Codec.CBOR.Cuddle.Huddle import Codec.CBOR.Cuddle.IndexMappable (IndexMappable (..)) import Codec.CBOR.Cuddle.Parser+import Data.List.NonEmpty (NonEmpty ((:|))) import Data.Text qualified as T import Data.Void (Void) import GHC.Generics (Generic)@@ -77,6 +78,7 @@   nestedSpec   genericSpec   constraintSpec+  choiceSpec   Pretty.spec  basicAssign :: Spec@@ -200,6 +202,18 @@       let b = "b" =:= (16 :: Integer)        in toSortedCDDL (collectFrom [HIRule $ "b" =:= (16 :: Integer), HIRule $ "c" =:= int 0 ... b])             `shouldMatchParseCDDL` "b = 16\n c = 0 .. b"++choiceSpec :: Spec+choiceSpec =+  describe "Choice" $ do+    describe "choiceFromList" $ do+      it "produces expected CDDL for 3-element list" $+        toSortedCDDL ["foo" =:= choiceFromList (int 1 :| [int 2, int 3])]+          `shouldMatchParseCDDL` "foo = 1 / 2 / 3"++      it "singleton is equivalent to direct assignment" $+        toSortedCDDL ["foo" =:= choiceFromList (int 1 :| [])]+          `shouldMatchParseCDDL` "foo = 1"  -------------------------------------------------------------------------------- -- Helper functions