cuddle 1.0.0.0 → 1.1.0.0

raw patch · 38 files changed

+4416/−2148 lines, 38 filesdep +generic-randomdep +pretty-simpledep ~cborgdep ~containersdep ~randomPVP ok

version bump matches the API change (PVP)

Dependencies added: generic-random, pretty-simple

Dependency ranges changed: cborg, containers, random

API changes (from Hackage documentation)

Files

• CHANGELOG.md +42/−0
• bin/Main.hs +43/−19
• cuddle.cabal +18/−11
• example/cddl-files/basic_assign.cddl +47/−0
• example/cddl-files/byron.cddl +209/−0
• example/cddl-files/conway.cddl +683/−0
• example/cddl-files/costmdls_min.cddl +3/−0
• example/cddl-files/issue80-min.cddl +8/−0
• example/cddl-files/pretty.cddl +13/−0
• example/cddl-files/shelley.cddl +288/−0
• example/cddl-files/validator.cddl +13/−0
• example/cddl-files/validator/negative/args-to-postlude.cddl +1/−0
• example/cddl-files/validator/negative/too-few-args.cddl +3/−0
• example/cddl-files/validator/negative/too-many-args.cddl +3/−0
• example/cddl-files/validator/negative/unknown-name.cddl +1/−0
• src/Codec/CBOR/Cuddle/CBOR/Gen.hs +99/−93
• src/Codec/CBOR/Cuddle/CBOR/Validator.hs +874/−1004
• src/Codec/CBOR/Cuddle/CDDL.hs +248/−129
• src/Codec/CBOR/Cuddle/CDDL/CBORGenerator.hs +23/−0
• src/Codec/CBOR/Cuddle/CDDL/CTree.hs +129/−44
• src/Codec/CBOR/Cuddle/CDDL/Postlude.hs +69/−51
• src/Codec/CBOR/Cuddle/CDDL/Prelude.hs +0/−61
• src/Codec/CBOR/Cuddle/CDDL/Resolve.hs +269/−256
• src/Codec/CBOR/Cuddle/Comments.hs +5/−0
• src/Codec/CBOR/Cuddle/Huddle.hs +270/−153
• src/Codec/CBOR/Cuddle/Huddle/HuddleM.hs +16/−16
• src/Codec/CBOR/Cuddle/Huddle/Optics.hs +0/−26
• src/Codec/CBOR/Cuddle/IndexMappable.hs +291/−0
• src/Codec/CBOR/Cuddle/Parser.hs +92/−30
• src/Codec/CBOR/Cuddle/Pretty.hs +72/−27
• test/Main.hs +5/−1
• test/Test/Codec/CBOR/Cuddle/CDDL/Examples.hs +50/−14
• test/Test/Codec/CBOR/Cuddle/CDDL/Gen.hs +52/−24
• test/Test/Codec/CBOR/Cuddle/CDDL/GeneratorSpec.hs +66/−0
• test/Test/Codec/CBOR/Cuddle/CDDL/Parser.hs +123/−100
• test/Test/Codec/CBOR/Cuddle/CDDL/Pretty.hs +140/−76
• test/Test/Codec/CBOR/Cuddle/CDDL/Validator.hs +76/−0
• test/Test/Codec/CBOR/Cuddle/Huddle.hs +72/−13

@@ -1,5 +1,47 @@ # Changelog for `cuddle` +## 1.1.0.0++* Change the type of field of `T2Group` to `GroupDef`+* Remove `Named` from exports+* 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` +  - `GRuleCall`+* Removed `Codec.CBOR.Cuddle.Huddle.Optics`+* Changed the `comment` to take a `Comment` argument instead of `Text`+* Changed the following functions to take a `Name` instead of `Text`:+  - `(=:=)`+  - `(=:~)`+  - `(=::=)`+  - `unsafeIncludeFromHuddle`+* Changed the type of `name` field in `Named` to `Name`+* Remove the description field from `Named`+* Renamed the `name` field to `unName` in `Name`+* Add `HasName`+* Add `bool` to `Huddle` module+* Removed most `Show` instances from `Huddle` as they were unlawful+* Added `ctrTerm` and `ctrResult` field accessors to `CBORTermResult`+* Add `ValidatorStage`+* Remove `validateCBOR'`, copied its implementation to `validateCBOR`+* Add extra information field to `UnapplicableRule`+* Implement `IndexMappable` instance for+  - `HuddleStage` to `CTreePhase`+  - `HuddleStage` to `PrettyStage`+* Change the order of fields in `GroupEntry`; the extension field is now the last field+* Add `IndexMappable` to help with traversing `CDDL` trees+* Add an index type parameter to all `CDDL` terms+* Remove `Codec.CBOR.Cuddle.CDDL.Prelude`+* Replace `cddlPrelude` with `cddlPostlude`, `prependPrelude` with `appendPostlude`+* 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 +  `generateCBORTerm'` to `CTreeRoot`+* Removed all exports in `Codec.CBOR.Cuddle.CBOR.Validator` except for +  `validateCBOR`, `validateCBOR'`, `CBORTermResult` and `CDDLResult`+ ## 1.0.0.0  * First official release to Hackage

@@ -4,24 +4,33 @@  import Codec.CBOR.Cuddle.CBOR.Gen (generateCBORTerm) import Codec.CBOR.Cuddle.CBOR.Validator-import Codec.CBOR.Cuddle.CDDL (Name (..), sortCDDL)-import Codec.CBOR.Cuddle.CDDL.Prelude (prependPrelude)+import Codec.CBOR.Cuddle.CDDL (Name (..), fromRules, sortCDDL)+import Codec.CBOR.Cuddle.CDDL.CTree (CTreeRoot)+import Codec.CBOR.Cuddle.CDDL.Postlude (appendPostlude) import Codec.CBOR.Cuddle.CDDL.Resolve (   fullResolveCDDL,  )+import Codec.CBOR.Cuddle.IndexMappable (IndexMappable (..), mapCDDLDropExt) import Codec.CBOR.Cuddle.Parser (pCDDL)-import Codec.CBOR.Cuddle.Pretty ()+import Codec.CBOR.Cuddle.Pretty (PrettyStage) import Codec.CBOR.FlatTerm (toFlatTerm) import Codec.CBOR.Pretty (prettyHexEnc) import Codec.CBOR.Term (encodeTerm) import Codec.CBOR.Write (toStrictByteString)+import Data.ByteString qualified as BS import Data.ByteString.Base16 qualified as Base16 import Data.ByteString.Char8 qualified as BSC import Data.Text qualified as T import Data.Text.IO qualified as T import Options.Applicative-import Prettyprinter (Pretty (pretty))-import Prettyprinter.Util (putDocW)+import Prettyprinter (+  LayoutOptions (..),+  PageWidth (..),+  Pretty (pretty),+  defaultLayoutOptions,+  layoutPretty,+ )+import Prettyprinter.Render.Text qualified as PT import System.Exit (exitFailure, exitSuccess) import System.IO (hPutStrLn, stderr) import System.Random (getStdGen)@@ -185,30 +194,35 @@         Format fOpts ->           let             defs-              | sort fOpts = sortCDDL res+              | sort fOpts = fromRules $ sortCDDL res               | otherwise = res+            layoutOptions = defaultLayoutOptions {layoutPageWidth = AvailablePerLine 80 1}+            formattedText =+              PT.renderStrict . layoutPretty layoutOptions . pretty $+                mapIndex @_ @_ @PrettyStage defs+            strippedText = T.unlines . fmap (T.dropWhileEnd (== ' ')) $ T.lines formattedText            in-            putDocW 80 $ pretty defs+            T.putStr strippedText         Validate vOpts ->           let-            res'+            cddl               | vNoPrelude vOpts = res-              | otherwise = prependPrelude res+              | otherwise = appendPostlude res            in-            case fullResolveCDDL res' of+            case fullResolveCDDL $ mapCDDLDropExt cddl of               Left err -> putStrLnErr (show err) >> exitFailure               Right _ -> exitSuccess-        (GenerateCBOR gOpts) ->+        GenerateCBOR gOpts ->           let-            res'+            cddl               | gNoPrelude gOpts = res-              | otherwise = prependPrelude res+              | otherwise = appendPostlude res            in-            case fullResolveCDDL 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)@@ -218,15 +232,15 @@                       AsPrettyCBOR -> putStrLn . prettyHexEnc $ encodeTerm term         ValidateCBOR vcOpts ->           let-            res'+            cddl               | vcNoPrelude vcOpts = res-              | otherwise = prependPrelude res+              | otherwise = res            in-            case fullResolveCDDL 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+                runValidateCBOR cbor (Name $ vcItemName vcOpts) (mapIndex mt)  putStrLnErr :: String -> IO () putStrLnErr = hPutStrLn stderr@@ -236,3 +250,13 @@   String ->   IO (Either (ParseErrorBundle T.Text e) a) parseFromFile p file = runParser p file <$> T.readFile file++runValidateCBOR :: BS.ByteString -> Name -> CTreeRoot ValidatorStage -> IO ()+runValidateCBOR bs rule cddl =+  case validateCBOR bs rule cddl of+    ok@(CBORTermResult _ (Valid _)) -> do+      putStrLn $ "Valid " ++ show ok+      exitSuccess+    err -> do+      hPutStrLn stderr $ "Invalid " ++ show err+      exitFailure

@@ -1,6 +1,6 @@ cabal-version: 3.4 name: cuddle-version: 1.0.0.0+version: 1.1.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).@@ -21,25 +21,22 @@ category: Codec build-type: Simple extra-doc-files: CHANGELOG.md-tested-with: ghc =={9.6, 9.8, 9.10, 9.12}+tested-with: ghc ==9.6 || ==9.8 || ==9.10 || ==9.12+data-files:+  example/cddl-files/*.cddl+  example/cddl-files/validator/negative/*.cddl  source-repository head   type: git   location: https://github.com/input-output-hk/cuddle -source-repository this-  type: git-  location: https://github.com/input-output-hk/cuddle-  tag: cuddle-0.5.0.0- flag example   description: Enable the example executable   manual: True   default: False  common warnings-  ghc-options:-    -Wall+  ghc-options: -Wall  library   import: warnings@@ -47,15 +44,15 @@     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-    Codec.CBOR.Cuddle.CDDL.Prelude     Codec.CBOR.Cuddle.CDDL.Resolve     Codec.CBOR.Cuddle.Comments     Codec.CBOR.Cuddle.Huddle     Codec.CBOR.Cuddle.Huddle.HuddleM-    Codec.CBOR.Cuddle.Huddle.Optics+    Codec.CBOR.Cuddle.IndexMappable     Codec.CBOR.Cuddle.Parser     Codec.CBOR.Cuddle.Parser.Lexer     Codec.CBOR.Cuddle.Pretty@@ -134,11 +131,16 @@ test-suite cuddle-test   import: warnings   default-language: GHC2021+  autogen-modules:+    Paths_cuddle   other-modules:+    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.CDDL.Validator     Test.Codec.CBOR.Cuddle.Huddle    type: exitcode-stdio-1.0@@ -149,12 +151,17 @@     QuickCheck >=2.14,     base,     bytestring,+    cborg,+    containers,     cuddle,     data-default-class,+    generic-random,     hspec >=2.11,     hspec-megaparsec >=2.2,     megaparsec,+    pretty-simple,     prettyprinter,+    random,     string-qq >=0.0.6,     text,     tree-diff,

@@ -0,0 +1,47 @@+coin = uint+epoch = uint++header =+  [ header_body+  , body_signature : $kes_signature+  , test : coin / null+  , withComment : null ; This is a comment+  , true+  ]++header_body = [+  issuer : text+]++$kes_signature = bytes .size 32+unit_interval<denominator> = [0 .. denominator, denominator]++unit_int = unit_interval<4294967295>++mysize = 16++sz1 = bytes .size 1+sz2 = bytes .size 2+sz32 = bytes .size 32+sz16 = bytes .size mysize++usz4 = uint .size 4+usz8 = uint .size 8++group = (usz4, usz8 / mysize, header_body, { * uint => coin })++set<a> = [ * a]+set2<a> = set<a>++coin_bag = set2<coin>++big_group = (+  "hello",+  32,+  8* 4,+  & group,+  uint,+  unit_interval<3>,+  5 ...10,+  h'11aaff3351bc'+)

@@ -0,0 +1,209 @@+; Cardano Byron blockchain CBOR schema++block = [0, ebblock]+      / [1, mainblock]++mainblock = [ "header" : blockhead+            , "body" : blockbody+            , "extra" : [attributes]+            ]++ebblock = [ "header" : ebbhead+          , "body" : [+ stakeholderid]+          , extra : [attributes]+          ]++u8 = uint .lt 256+u16 = uint .lt 65536+u32 = uint+u64 = uint++; Basic Cardano Types++blake2b-256 = bytes .size 32++txid = blake2b-256+blockid = blake2b-256+updid = blake2b-256+hash = blake2b-256++blake2b-224 = bytes .size 28++addressid = blake2b-224+stakeholderid = blake2b-224++epochid = u64+slotid = [ epoch: epochid, slot : u64 ]++pubkey = bytes+signature = bytes++; Attributes - at the moment we do not bother deserialising these, since they+; don't contain anything++attributes = {* any => any}++; Addresses++addrdistr = [1] / [0, stakeholderid]++addrtype = &("PubKey" : 0, "Script" : 1, "Redeem" : 2) / (u64 .gt 2)+addrattr = { ? 0 : addrdistr+           , ? 1 : bytes}+address = [ #6.24(bytes .cbor ([addressid, addrattr, addrtype])), u64 ]++; Transactions++txin = [0, #6.24(bytes .cbor ([txid, u32]))] / [u8 .ne 0, encoded-cbor]+txout = [address, u64]++tx = [[+ txin], [+ txout], attributes]++txproof = [u32, hash, hash]++twit = [0, #6.24(bytes .cbor ([pubkey, signature]))]+     / [1, #6.24(bytes .cbor ([[u16, bytes], [u16, bytes]]))]+     / [2, #6.24(bytes .cbor ([pubkey, signature]))]+     / [u8 .gt 2, encoded-cbor]++; Shared Seed Computation++vsspubkey = bytes ; This is encoded using the 'Binary' instance+                  ; for Scrape.PublicKey+vsssec = bytes ; This is encoded using the 'Binary' instance+               ; for Scrape.Secret.+vssenc = [bytes] ; This is encoded using the 'Binary' instance+                 ; for Scrape.EncryptedSi.+                 ; TODO work out why this seems to be in a length 1 array+vssdec = bytes ; This is encoded using the 'Binary' instance+               ; for Scrape.DecryptedShare+vssproof = [bytes, bytes, bytes, [* bytes]] ; This is encoded using the+                                            ; 'Binary' instance for Scrape.Proof++ssccomm = [pubkey, [{vsspubkey => vssenc},vssproof], signature]+ssccomms = #6.258([* ssccomm])++sscopens = {stakeholderid => vsssec}++sscshares = {addressid => [addressid, [* vssdec]]}++ssccert = [vsspubkey, pubkey, epochid, signature]+ssccerts = #6.258([* ssccert])++ssc = [0, ssccomms, ssccerts]+    / [1, sscopens, ssccerts]+    / [2, sscshares, ssccerts]+    / [3, ssccerts]++sscproof = [0, hash, hash]+         / [1, hash, hash]+         / [2, hash, hash]+         / [3, hash]++; Delegation++dlg = [ epoch : epochid+      , issuer : pubkey+      , delegate : pubkey+      , certificate : signature+      ]++dlgsig = [dlg, signature]++lwdlg = [ epochRange : [epochid, epochid]+        , issuer : pubkey+        , delegate : pubkey+        , certificate : signature+        ]++lwdlgsig = [lwdlg, signature]++; Updates++bver = [u16, u16, u8]++txfeepol = [0, #6.24(bytes .cbor ([bigint, bigint]))]+         / [u8 .gt 0, encoded-cbor]++bvermod = [ scriptVersion : [? u16]+          , slotDuration : [? bigint]+          , maxBlockSize : [? bigint]+          , maxHeaderSize  : [? bigint]+          , maxTxSize : [? bigint]+          , maxProposalSize : [? bigint]+          , mpcThd : [? u64]+          , heavyDelThd : [? u64]+          , updateVoteThd : [? u64]+          , updateProposalThd : [? u64]+          , updateImplicit : [? u64]+          , softForkRule : [? [u64, u64, u64]]+          , txFeePolicy : [? txfeepol]+          , unlockStakeEpoch : [? epochid]+          ]++updata = [ hash, hash, hash, hash ]++upprop = [ "blockVersion" : bver+         , "blockVersionMod" : bvermod+         , "softwareVersion" : [ text, u32 ]+         , "data" : #6.258([text, updata])+         , "attributes" : attributes+         , "from" : pubkey+         , "signature" : signature+         ]++upvote = [ "voter" : pubkey+         , "proposalId" : updid+         , "vote" : bool+         , "signature" : signature+         ]++up = [ "proposal" :  [? upprop]+     , votes : [* upvote]+     ]++; Blocks++difficulty = [u64]++blocksig = [0, signature]+         / [1, lwdlgsig]+         / [2, dlgsig]++blockcons = [slotid, pubkey, difficulty, blocksig]++blockheadex = [ "blockVersion" : bver+              , "softwareVersion" : [ text, u32 ]+              , "attributes" : attributes+              , "extraProof" : hash+              ]++blockproof = [ "txProof" : txproof+             , "sscProof" : sscproof+             , "dlgProof" : hash+             , "updProof" : hash+             ]++blockhead = [ "protocolMagic" : u32+            , "prevBlock" : blockid+            , "bodyProof" : blockproof+            , "consensusData" : blockcons+            , "extraData" : blockheadex+            ]++blockbody = [ "txPayload" : [* [tx, [* twit]]]+            , "sscPayload" : ssc+            , "dlgPayload" : [* dlg]+            , "updPayload" : up+            ]++; Epoch Boundary Blocks++ebbcons = [ epochid, difficulty ]++ebbhead = [ "protocolMagic" : u32+          , "prevBlock" : blockid+          , "bodyProof" : hash+          , "consensusData" : ebbcons+          , "extraData" : [attributes]+          ]

@@ -0,0 +1,683 @@+; crypto.cddl+$hash28 /= bytes .size 28+$hash32 /= bytes .size 32++$vkey /= bytes .size 32++$vrf_vkey /= bytes .size 32+$vrf_cert /= [bytes, bytes .size 80]++$kes_vkey /= bytes .size 32+$kes_signature /= bytes .size 448+signkeyKES = bytes .size 64++$signature /= bytes .size 64++; extra.cddl+; Conway era introduces an optional 258 tag for sets, which will become mandatory in the+; second era after Conway. We recommend all the tooling to account for this future breaking+; change sooner rather than later, in order to provide a smooth transition for their users.++; This is an unordered set. Duplicate elements are not allowed and the order of elements is implementation specific.+set<a> = #6.258([* a]) / [* a]++; Just like `set`, but must contain at least one element.+nonempty_set<a> = #6.258([+ a]) / [+ a]++; This is a non-empty ordered set. Duplicate elements are not allowed and the order of elements will be preserved.+nonempty_oset<a> = #6.258([+ a]) / [+ a]++positive_int = 1 .. 18446744073709551615++unit_interval = #6.30([1, 2])+  ; unit_interval = #6.30([uint, uint])+  ;+  ; Comment above depicts the actual definition for `unit_interval`.+  ;+  ; Unit interval is a number in the range between 0 and 1, which+  ; means there are two extra constraints:+  ; * numerator <= denominator+  ; * denominator > 0+  ;+  ; Relation between numerator and denominator cannot be expressed in CDDL, which+  ; poses a problem for testing. We need to be able to generate random valid data+  ; for testing implementation of our encoders/decoders. Which means we cannot use+  ; the actual definition here and we hard code the value to 1/2+++nonnegative_interval = #6.30([uint, positive_int])+++address =+  h'001000000000000000000000000000000000000000000000000000000011000000000000000000000000000000000000000000000000000000' /+  h'102000000000000000000000000000000000000000000000000000000022000000000000000000000000000000000000000000000000000000' /+  h'203000000000000000000000000000000000000000000000000000000033000000000000000000000000000000000000000000000000000000' /+  h'304000000000000000000000000000000000000000000000000000000044000000000000000000000000000000000000000000000000000000' /+  h'405000000000000000000000000000000000000000000000000000000087680203' /+  h'506000000000000000000000000000000000000000000000000000000087680203' /+  h'6070000000000000000000000000000000000000000000000000000000' /+  h'7080000000000000000000000000000000000000000000000000000000'++reward_account =+  h'E090000000000000000000000000000000000000000000000000000000' /+  h'F0A0000000000000000000000000000000000000000000000000000000'++bounded_bytes = bytes .size (0..64)+  ; the real bounded_bytes does not have this limit. it instead has a different+  ; limit which cannot be expressed in CDDL.+  ; The limit is as follows:+  ;  - bytes with a definite-length encoding are limited to size 0..64+  ;  - for bytes with an indefinite-length CBOR encoding, each chunk is+  ;    limited to size 0..64+  ;  ( reminder: in CBOR, the indefinite-length encoding of bytestrings+  ;    consists of a token #2.31 followed by a sequence of definite-length+  ;    encoded bytestrings and a stop code )++; a type for distinct values.+; The type parameter must support .size, for example: bytes or uint+distinct<a> = a .size 8 / a .size 16 / a .size 20 / a .size 24 / a .size 30 / a .size 32++; conway.cddl+block =+  [ header+  , transaction_bodies         : [* transaction_body]+  , transaction_witness_sets   : [* transaction_witness_set]+  , auxiliary_data_set         : {* transaction_index => auxiliary_data }+  , invalid_transactions       : [* transaction_index ]+  ]; Valid blocks must also satisfy the following two constraints:+   ; 1) the length of transaction_bodies and transaction_witness_sets+   ;    must be the same+   ; 2) every transaction_index must be strictly smaller than the+   ;    length of transaction_bodies++transaction =+  [ transaction_body+  , transaction_witness_set+  , bool+  , auxiliary_data / null+  ]++transaction_index = uint .size 2++header =+  [ header_body+  , body_signature : $kes_signature+  ]++header_body =+  [ block_number     : uint+  , slot             : uint+  , prev_hash        : $hash32 / null+  , issuer_vkey      : $vkey+  , vrf_vkey         : $vrf_vkey+  , vrf_result       : $vrf_cert ; replaces nonce_vrf and leader_vrf+  , block_body_size  : uint+  , block_body_hash  : $hash32 ; merkle triple root+  , operational_cert+  , [ protocol_version ]+  ]++operational_cert =+  [ hot_vkey        : $kes_vkey+  , sequence_number : uint+  , kes_period      : uint+  , sigma           : $signature+  ]++next_major_protocol_version = 10++major_protocol_version = 1..next_major_protocol_version++protocol_version = (major_protocol_version, uint)++transaction_body =+  { 0 : set<transaction_input>             ; inputs+  , 1 : [* transaction_output]+  , 2 : coin                               ; fee+  , ? 3 : uint                             ; time to live+  , ? 4 : certificates+  , ? 5 : withdrawals+  , ? 7 : auxiliary_data_hash+  , ? 8 : uint                             ; validity interval start+  , ? 9 : mint+  , ? 11 : script_data_hash+  , ? 13 : nonempty_set<transaction_input> ; collateral inputs+  , ? 14 : required_signers+  , ? 15 : network_id+  , ? 16 : transaction_output              ; collateral return+  , ? 17 : coin                            ; total collateral+  , ? 18 : nonempty_set<transaction_input> ; reference inputs+  , ? 19 : voting_procedures               ; New; Voting procedures+  , ? 20 : proposal_procedures             ; New; Proposal procedures+  , ? 21 : coin                            ; New; current treasury value+  , ? 22 : positive_coin                   ; New; donation+  }++voting_procedures = { + voter => { + gov_action_id => voting_procedure } }++voting_procedure =+  [ vote+  , anchor / null+  ]++proposal_procedure =+  [ deposit : coin+  , reward_account+  , gov_action+  , anchor+  ]++proposal_procedures = nonempty_set<proposal_procedure>++certificates = nonempty_set<certificate>++gov_action =+  [ parameter_change_action+  // hard_fork_initiation_action+  // treasury_withdrawals_action+  // no_confidence+  // update_committee+  // new_constitution+  // info_action+  ]++policy_hash = scripthash++parameter_change_action = (0, gov_action_id / null, protocol_param_update, policy_hash / null)++hard_fork_initiation_action = (1, gov_action_id / null, [protocol_version])++treasury_withdrawals_action = (2, { reward_account => coin }, policy_hash / null)++no_confidence = (3, gov_action_id / null)++update_committee = (4, gov_action_id / null, set<committee_cold_credential>, { committee_cold_credential => epoch }, unit_interval)++new_constitution = (5, gov_action_id / null, constitution)++constitution =+  [ anchor+  , scripthash / null+  ]++info_action = 6++; Constitutional Committee Hot KeyHash: 0+; Constitutional Committee Hot ScriptHash: 1+; DRep KeyHash: 2+; DRep ScriptHash: 3+; StakingPool KeyHash: 4+voter =+  [ 0, addr_keyhash+  // 1, scripthash+  // 2, addr_keyhash+  // 3, scripthash+  // 4, addr_keyhash+  ]++anchor =+  [ anchor_url       : url+  , anchor_data_hash : $hash32+  ]++; no - 0+; yes - 1+; abstain - 2+vote = 0 .. 2++gov_action_id =+  [ transaction_id   : $hash32+  , gov_action_index : uint+  ]++required_signers = nonempty_set<addr_keyhash>++transaction_input = [ transaction_id : $hash32+                    , index : uint+                    ]++transaction_output = legacy_transaction_output / post_alonzo_transaction_output++legacy_transaction_output =+  [ address+  , amount : value+  , ? datum_hash : $hash32+  ]++post_alonzo_transaction_output =+  { 0 : address+  , 1 : value+  , ? 2 : datum_option ; datum option+  , ? 3 : script_ref   ; script reference+  }++script_data_hash = $hash32+; This is a hash of data which may affect evaluation of a script.+; This data consists of:+;   - The redeemers from the transaction_witness_set (the value of field 5).+;   - The datums from the transaction_witness_set (the value of field 4).+;   - The value in the costmdls map corresponding to the script's language+;     (in field 18 of protocol_param_update.)+; (In the future it may contain additional protocol parameters.)+;+; Since this data does not exist in contiguous form inside a transaction, it needs+; to be independently constructed by each recipient.+;+; The bytestring which is hashed is the concatenation of three things:+;   redeemers || datums || language views+; The redeemers are exactly the data present in the transaction witness set.+; Similarly for the datums, if present. If no datums are provided, the middle+; field is omitted (i.e. it is the empty/null bytestring).+;+; language views CDDL:+; { * language => script_integrity_data }+;+; This must be encoded canonically, using the same scheme as in+; RFC7049 section 3.9:+;  - Maps, strings, and bytestrings must use a definite-length encoding+;  - Integers must be as small as possible.+;  - The expressions for map length, string length, and bytestring length+;    must be as short as possible.+;  - The keys in the map must be sorted as follows:+;     -  If two keys have different lengths, the shorter one sorts earlier.+;     -  If two keys have the same length, the one with the lower value+;        in (byte-wise) lexical order sorts earlier.+;+; For PlutusV1 (language id 0), the language view is the following:+;   - the value of costmdls map at key 0 (in other words, the script_integrity_data)+;     is encoded as an indefinite length list and the result is encoded as a bytestring.+;     (our apologies)+;     For example, the script_integrity_data corresponding to the all zero costmodel for V1+;     would be encoded as (in hex):+;     58a89f00000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000ff+;   - the language ID tag is also encoded twice. first as a uint then as+;     a bytestring. (our apologies)+;     Concretely, this means that the language version for V1 is encoded as+;     4100 in hex.+; For PlutusV2 (language id 1), the language view is the following:+;   - the value of costmdls map at key 1 is encoded as an definite length list.+;     For example, the script_integrity_data corresponding to the all zero costmodel for V2+;     would be encoded as (in hex):+;     98af0000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000+;   - the language ID tag is encoded as expected.+;     Concretely, this means that the language version for V2 is encoded as+;     01 in hex.+; For PlutusV3 (language id 2), the language view is the following:+;   - the value of costmdls map at key 2 is encoded as a definite length list.+;+; Note that each Plutus language represented inside a transaction must have+; a cost model in the costmdls protocol parameter in order to execute,+; regardless of what the script integrity data is.+;+; Finally, note that in the case that a transaction includes datums but does not+; include the redeemers field, the script data format becomes (in hex):+; [ 80 | datums | A0 ]+; corresponding to a CBOR empty list and an empty map.+; Note that a transaction might include the redeemers field and  it to the+; empty map, in which case the user supplied encoding of the empty map is used.++; address = bytes+; reward_account = bytes++; address format:+; [ 8 bit header | payload ];+;+; shelley payment addresses:+; bit 7: 0+; bit 6: base/other+; bit 5: pointer/enterprise [for base: stake cred is keyhash/scripthash]+; bit 4: payment cred is keyhash/scripthash+; bits 3-0: network id+;+; reward addresses:+; bits 7-5: 111+; bit 4: credential is keyhash/scripthash+; bits 3-0: network id+;+; byron addresses:+; bits 7-4: 1000++; 0000: base address: keyhash28,keyhash28+; 0001: base address: scripthash28,keyhash28+; 0010: base address: keyhash28,scripthash28+; 0011: base address: scripthash28,scripthash28+; 0100: pointer address: keyhash28, 3 variable length uint+; 0101: pointer address: scripthash28, 3 variable length uint+; 0110: enterprise address: keyhash28+; 0111: enterprise address: scripthash28+; 1000: byron address+; 1110: reward account: keyhash28+; 1111: reward account: scripthash28+; 1001 - 1101: future formats++certificate =+  [ stake_registration+  // stake_deregistration+  // stake_delegation+  // pool_registration+  // pool_retirement+  // reg_cert+  // unreg_cert+  // vote_deleg_cert+  // stake_vote_deleg_cert+  // stake_reg_deleg_cert+  // vote_reg_deleg_cert+  // stake_vote_reg_deleg_cert+  // auth_committee_hot_cert+  // resign_committee_cold_cert+  // reg_drep_cert+  // unreg_drep_cert+  // update_drep_cert+  ]++stake_registration = (0, stake_credential) ; to be deprecated in era after Conway+stake_deregistration = (1, stake_credential) ; to be deprecated in era after Conway+stake_delegation = (2, stake_credential, pool_keyhash)++; POOL+pool_registration = (3, pool_params)+pool_retirement = (4, pool_keyhash, epoch)++; numbers 5 and 6 used to be the Genesis and MIR certificates respectively,+; which were deprecated in Conway++; DELEG+reg_cert = (7, stake_credential, coin)+unreg_cert = (8, stake_credential, coin)+vote_deleg_cert = (9, stake_credential, drep)+stake_vote_deleg_cert = (10, stake_credential, pool_keyhash, drep)+stake_reg_deleg_cert = (11, stake_credential, pool_keyhash, coin)+vote_reg_deleg_cert = (12, stake_credential, drep, coin)+stake_vote_reg_deleg_cert = (13, stake_credential, pool_keyhash, drep, coin)++; GOVCERT+auth_committee_hot_cert = (14, committee_cold_credential, committee_hot_credential)+resign_committee_cold_cert = (15, committee_cold_credential, anchor / null)+reg_drep_cert = (16, drep_credential, coin, anchor / null)+unreg_drep_cert = (17, drep_credential, coin)+update_drep_cert = (18, drep_credential, anchor / null)+++delta_coin = int++credential =+  [  0, addr_keyhash+  // 1, scripthash+  ]++drep =+  [ 0, addr_keyhash+  // 1, scripthash+  // 2  ; always abstain+  // 3  ; always no confidence+  ]++stake_credential = credential+drep_credential = credential+committee_cold_credential = credential+committee_hot_credential = credential++pool_params = ( operator:       pool_keyhash+              , vrf_keyhash:    vrf_keyhash+              , pledge:         coin+              , cost:           coin+              , margin:         unit_interval+              , reward_account: reward_account+              , pool_owners:    set<addr_keyhash>+              , relays:         [* relay]+              , pool_metadata:  pool_metadata / null+              )++port = uint .le 65535+ipv4 = bytes .size 4+ipv6 = bytes .size 16+dns_name = tstr .size (0..128)++single_host_addr = ( 0+                   , port / null+                   , ipv4 / null+                   , ipv6 / null+                   )+single_host_name = ( 1+                   , port / null+                   , dns_name ; An A or AAAA DNS record+                   )+multi_host_name = ( 2+                   , dns_name ; A SRV DNS record+                   )+relay =+  [  single_host_addr+  // single_host_name+  // multi_host_name+  ]++pool_metadata = [url, pool_metadata_hash]+url = tstr .size (0..128)++withdrawals = { + reward_account => coin }++protocol_param_update =+  { ? 0:  coin                   ; minfee A+  , ? 1:  coin                   ; minfee B+  , ? 2:  uint                   ; max block body size+  , ? 3:  uint                   ; max transaction size+  , ? 4:  uint                   ; max block header size+  , ? 5:  coin                   ; key deposit+  , ? 6:  coin                   ; pool deposit+  , ? 7:  epoch                  ; maximum epoch+  , ? 8:  uint                   ; n_opt: desired number of stake pools+  , ? 9:  nonnegative_interval   ; pool pledge influence+  , ? 10: unit_interval          ; expansion rate+  , ? 11: unit_interval          ; treasury growth rate+  , ? 16: coin                   ; min pool cost+  , ? 17: coin                   ; ada per utxo byte+  , ? 18: costmdls               ; cost models for script languages+  , ? 19: ex_unit_prices         ; execution costs+  , ? 20: ex_units               ; max tx ex units+  , ? 21: ex_units               ; max block ex units+  , ? 22: uint                   ; max value size+  , ? 23: uint                   ; collateral percentage+  , ? 24: uint                   ; max collateral inputs+  , ? 25: pool_voting_thresholds ; pool voting thresholds+  , ? 26: drep_voting_thresholds ; DRep voting thresholds+  , ? 27: uint                   ; min committee size+  , ? 28: epoch                  ; committee term limit+  , ? 29: epoch                  ; governance action validity period+  , ? 30: coin                   ; governance action deposit+  , ? 31: coin                   ; DRep deposit+  , ? 32: epoch                  ; DRep inactivity period+  }++pool_voting_thresholds =+  [ unit_interval ; motion no confidence+  , unit_interval ; committee normal+  , unit_interval ; committee no confidence+  , unit_interval ; hard fork initiation+  , unit_interval ; security relevant parameter voting threshold+  ]++drep_voting_thresholds =+  [ unit_interval ; motion no confidence+  , unit_interval ; committee normal+  , unit_interval ; committee no confidence+  , unit_interval ; update constitution+  , unit_interval ; hard fork initiation+  , unit_interval ; PP network group+  , unit_interval ; PP economic group+  , unit_interval ; PP technical group+  , unit_interval ; PP governance group+  , unit_interval ; treasury withdrawal+  ]++transaction_witness_set =+  { ? 0: nonempty_set<vkeywitness>+  , ? 1: nonempty_set<native_script>+  , ? 2: nonempty_set<bootstrap_witness>+  , ? 3: nonempty_set<plutus_v1_script>+  , ? 4: nonempty_set<plutus_data>+  , ? 5: redeemers+  , ? 6: nonempty_set<plutus_v2_script>+  , ? 7: nonempty_set<plutus_v3_script>+  }++; The real type of  plutus_v1_script, plutus_v2_script and plutus_v3_script is bytes.+; However, because we enforce uniqueness when many scripts are supplied,+; we need to hack around for tests in order to avoid generating duplicates,+; since the cddl tool we use for roundtrip testing doesn't generate distinct collections.+plutus_v1_script = distinct<bytes>+plutus_v2_script = distinct<bytes>+plutus_v3_script = distinct<bytes>++plutus_data =+    constr<plutus_data>+  / { * plutus_data => plutus_data }+  / [ * plutus_data ]+  / big_int+  / bounded_bytes++big_int = int / big_uint / big_nint+big_uint = #6.2(bounded_bytes)+big_nint = #6.3(bounded_bytes)++constr<a> =+    #6.121([* a])+  / #6.122([* a])+  / #6.123([* a])+  / #6.124([* a])+  / #6.125([* a])+  / #6.126([* a])+  / #6.127([* a]) ; similarly for tag range: 6.1280 .. 6.1400 inclusive+  / #6.102([uint, [* a]])++redeemers =+  [ + [ tag: redeemer_tag, index: uint, data: plutus_data, ex_units: ex_units ] ]+; TODO: Add alternative implementation that reflects the reality more accuratly:+;  / { + [ tag: redeemer_tag, index: uint ] => [ data: plutus_data, ex_units: ex_units ] }++redeemer_tag =+    0 ; Spending+  / 1 ; Minting+  / 2 ; Certifying+  / 3 ; Rewarding+  / 4 ; Voting+  / 5 ; Proposing++ex_units = [mem: uint, steps: uint]++ex_unit_prices =+  [ mem_price: nonnegative_interval, step_price: nonnegative_interval ]++language = 0 ; Plutus v1+         / 1 ; Plutus v2+         / 2 ; Plutus v3++potential_languages = 0 .. 255++; The format for costmdls is flexible enough to allow adding Plutus built-ins and language+; versions in the future.+;+costmdls =+  { ? 0 : [ 166* int ] ; Plutus v1, only 166 integers are used, but more are accepted (and ignored)+  , ? 1 : [ 175* int ] ; Plutus v2, only 175 integers are used, but more are accepted (and ignored)+  , ? 2 : [ 223* int ] ; Plutus v3, only 223 integers are used, but more are accepted (and ignored)+  , ? 3 : [ int ] ; Any 8-bit unsigned number can be used as a key.+  }++transaction_metadatum =+    { * transaction_metadatum => transaction_metadatum }+  / [ * transaction_metadatum ]+  / int+  / bytes .size (0..64)+  / text .size (0..64)++transaction_metadatum_label = uint+metadata = { * transaction_metadatum_label => transaction_metadatum }++auxiliary_data =+  metadata ; Shelley+  / [ transaction_metadata: metadata ; Shelley-ma+    , auxiliary_scripts: [ * native_script ]+    ]+  / #6.259({ ? 0 => metadata         ; Alonzo and beyond+      , ? 1 => [ * native_script ]+      , ? 2 => [ * plutus_v1_script ]+      , ? 3 => [ * plutus_v2_script ]+      , ? 4 => [ * plutus_v3_script ]+      })++vkeywitness = [ $vkey, $signature ]++bootstrap_witness =+  [ public_key : $vkey+  , signature  : $signature+  , chain_code : bytes .size 32+  , attributes : bytes+  ]++native_script =+  [ script_pubkey+  // script_all+  // script_any+  // script_n_of_k+  // invalid_before+     ; Timelock validity intervals are half-open intervals [a, b).+     ; This field specifies the left (included) endpoint a.+  // invalid_hereafter+     ; Timelock validity intervals are half-open intervals [a, b).+     ; This field specifies the right (excluded) endpoint b.+  ]++script_pubkey = (0, addr_keyhash)+script_all = (1, [ * native_script ])+script_any = (2, [ * native_script ])+script_n_of_k = (3, n: uint, [ * native_script ])+invalid_before = (4, uint)+invalid_hereafter = (5, uint)++coin = uint++multiasset<a> = { + policy_id => { + asset_name => a } }+policy_id = scripthash+asset_name = bytes .size (0..32)++negInt64 = -9223372036854775808 .. -1+posInt64 = 1 .. 9223372036854775807+nonZeroInt64 = negInt64 / posInt64 ; this is the same as the current int64 definition but without zero++positive_coin = 1 .. 18446744073709551615++value = coin / [coin, multiasset<positive_coin>]++mint = multiasset<nonZeroInt64>++int64 = -9223372036854775808 .. 9223372036854775807++network_id = 0 / 1++epoch = uint++addr_keyhash           = $hash28+pool_keyhash           = $hash28++vrf_keyhash           = $hash32+auxiliary_data_hash   = $hash32+pool_metadata_hash    = $hash32++; To compute a script hash, note that you must prepend+; a tag to the bytes of the script before hashing.+; The tag is determined by the language.+; The tags in the Conway era are:+;   "\x00" for multisig scripts+;   "\x01" for Plutus V1 scripts+;   "\x02" for Plutus V2 scripts+;   "\x03" for Plutus V3 scripts+scripthash            = $hash28++datum_hash = $hash32+data = #6.24(bytes .cbor plutus_data)++datum_option = [ 0, $hash32 // 1, data ]++script_ref = #6.24(bytes .cbor script)++script = [ 0, native_script // 1, plutus_v1_script // 2, plutus_v2_script // 3, plutus_v3_script ]

@@ -0,0 +1,3 @@+costmdls =+  { 0 : [ 11* int ] ; Plutus v1, only 166 integers are used, but more are accepted (and ignored)+  }

@@ -0,0 +1,8 @@+main = test<int, int>+set<x> = [x]+test<x, x1> = [+	1,+	x,+	set<x>+]+

@@ -0,0 +1,13 @@+set<a > = [* a]++a = [ 2*30 2 : uint+  , ? 33 : bytes+  , 4444 : set<uint>+  , * 55 => uint+  ]++b = [1,uint,(3,4)]++c = { 1: a +, 2: b ; hello+}

@@ -0,0 +1,288 @@+; Shelley Types++block =+  [ header+  , transaction_bodies         : [* transaction_body]+  , transaction_witness_sets   : [* transaction_witness_set]+  , transaction_metadata_set   :+      { * transaction_index => transaction_metadata }+  ]; Valid blocks must also satisfy the following two constraints:+   ; 1) the length of transaction_bodies and transaction_witness_sets+   ;    must be the same+   ; 2) every transaction_index must be strictly smaller than the+   ;    length of transaction_bodies++transaction =+  [ transaction_body+  , transaction_witness_set+  , transaction_metadata / null+  ]++transaction_index = uint .size 2++header =+  [ header_body+  , body_signature : $kes_signature+  ]++header_body =+  [ block_number     : uint+  , slot             : uint+  , prev_hash        : $hash32 / null+  , issuer_vkey      : $vkey+  , vrf_vkey         : $vrf_vkey+  , nonce_vrf        : $vrf_cert+  , leader_vrf       : $vrf_cert+  , block_body_size  : uint+  , block_body_hash  : $hash32 ; merkle triple root+  , operational_cert+  , protocol_version+  ]++operational_cert =+  ( hot_vkey        : $kes_vkey+  , sequence_number : uint+  , kes_period      : uint+  , sigma           : $signature+  )++next_major_protocol_version = 3++major_protocol_version = 1..next_major_protocol_version++protocol_version = (major_protocol_version, uint)++transaction_body =+  { 0 : set<transaction_input>+  , 1 : [* transaction_output]+  , 2 : coin ; fee+  , 3 : uint ; ttl+  , ? 4 : [* certificate]+  , ? 5 : withdrawals+  , ? 6 : update+  , ? 7 : metadata_hash+  }++transaction_input = [ transaction_id : $hash32+                    , index : uint+                    ]++transaction_output = [address, amount : coin]++; address = bytes+; reward_account = bytes++; address format:+; [ 8 bit header | payload ];+;+; shelley payment addresses:+; bit 7: 0+; bit 6: base/other+; bit 5: pointer/enterprise [for base: stake cred is keyhash/scripthash]+; bit 4: payment cred is keyhash/scripthash+; bits 3-0: network id+;+; reward addresses:+; bits 7-5: 111+; bit 4: credential is keyhash/scripthash+; bits 3-0: network id+;+; byron addresses:+; bits 7-4: 1000++; 0000: base address: keyhash28,keyhash28+; 0001: base address: scripthash28,keyhash28+; 0010: base address: keyhash28,scripthash28+; 0011: base address: scripthash28,scripthash28+; 0100: pointer address: keyhash28, 3 variable length uint+; 0101: pointer address: scripthash28, 3 variable length uint+; 0110: enterprise address: keyhash28+; 0111: enterprise address: scripthash28+; 1000: byron address+; 1110: reward account: keyhash28+; 1111: reward account: scripthash28+; 1001 - 1101: future formats++certificate =+  [ stake_registration+  // stake_deregistration+  // stake_delegation+  // pool_registration+  // pool_retirement+  // genesis_key_delegation+  // move_instantaneous_rewards_cert+  ]++stake_registration = (0, stake_credential)+stake_deregistration = (1, stake_credential)+stake_delegation = (2, stake_credential, pool_keyhash)+pool_registration = (3, pool_params)+pool_retirement = (4, pool_keyhash, epoch)+genesis_key_delegation = (5, genesishash, genesis_delegate_hash, vrf_keyhash)+move_instantaneous_rewards_cert = (6, move_instantaneous_reward)++move_instantaneous_reward = [ 0 / 1, { * stake_credential => coin } ]+; The first field determines where the funds are drawn from.+; 0 denotes the reserves, 1 denotes the treasury.++stake_credential =+  [  0, addr_keyhash+  // 1, scripthash+  ]++pool_params = ( operator:       pool_keyhash+              , vrf_keyhash:    vrf_keyhash+              , pledge:         coin+              , cost:           coin+              , margin:         unit_interval+              , reward_account: reward_account+              , pool_owners:    set<addr_keyhash>+              , relays:         [* relay]+              , pool_metadata:  pool_metadata / null+              )++port = uint .le 65535+ipv4 = bytes .size 4+ipv6 = bytes .size 16+dns_name = tstr .size (0..64)++single_host_addr = ( 0+                   , port / null+                   , ipv4 / null+                   , ipv6 / null+                   )+single_host_name = ( 1+                   , port / null+                   , dns_name ; An A or AAAA DNS record+                   )+multi_host_name = ( 2+                   , dns_name ; A SRV DNS record+                   )+relay =+  [  single_host_addr+  // single_host_name+  // multi_host_name+  ]++pool_metadata = [url, metadata_hash]+url = tstr .size (0..64)++withdrawals = { * reward_account => coin }++update = [ proposed_protocol_parameter_updates+         , epoch+         ]++proposed_protocol_parameter_updates =+  { * genesishash => protocol_param_update }++protocol_param_update =+  { ? 0:  uint               ; minfee A+  , ? 1:  uint               ; minfee B+  , ? 2:  uint               ; max block body size+  , ? 3:  uint               ; max transaction size+  , ? 4:  uint               ; max block header size+  , ? 5:  coin               ; key deposit+  , ? 6:  coin               ; pool deposit+  , ? 7: epoch               ; maximum epoch+  , ? 8: uint                ; n_opt: desired number of stake pools+  , ? 9: rational            ; pool pledge influence+  , ? 10: unit_interval      ; expansion rate+  , ? 11: unit_interval      ; treasury growth rate+  , ? 12: unit_interval      ; d. decentralization constant+  , ? 13: $nonce             ; extra entropy+  , ? 14: [protocol_version] ; protocol version+  , ? 15: coin               ; min utxo value+  }++transaction_witness_set =+  { ?0 => [* vkeywitness ]+  , ?1 => [* multisig_script ]+  , ?2 => [* bootstrap_witness ]+  ; In the future, new kinds of witnesses can be added like this:+  ; , ?3 => [* monetary_policy_script ]+  ; , ?4 => [* plutus_script ]+  }++transaction_metadatum =+    { * transaction_metadatum => transaction_metadatum }+  / [ * transaction_metadatum ]+  / int+  / bytes .size (0..64)+  / text .size (0..64)++transaction_metadatum_label = uint++transaction_metadata =+  { * transaction_metadatum_label => transaction_metadatum }++vkeywitness = [ $vkey, $signature ]++bootstrap_witness =+  [ public_key : $vkey+  , signature  : $signature+  , chain_code : bytes .size 32+  , attributes : bytes+  ]++multisig_script =+  [ multisig_pubkey+  // multisig_all+  // multisig_any+  // multisig_n_of_k+  ]++multisig_pubkey = (0, addr_keyhash)+multisig_all = (1, [ * multisig_script ])+multisig_any = (2, [ * multisig_script ])+multisig_n_of_k = (3, n: uint, [ * multisig_script ])++coin = uint+epoch = uint++addr_keyhash          = $hash28+genesis_delegate_hash = $hash28+pool_keyhash          = $hash28+genesishash           = $hash28++vrf_keyhash           = $hash32+metadata_hash         = $hash32++; To compute a script hash, note that you must prepend+; a tag to the bytes of the script before hashing.+; The tag is determined by the language.+; In the Shelley era there is only one such tag,+; namely "\x00" for multisig scripts.+scripthash            = $hash28++$nonce /= [ 0 // 1, bytes .size 32 ]++$hash28 /= bytes .size 28+$hash32 /= bytes .size 32++$vkey /= bytes .size 32++$vrf_vkey /= bytes .size 32+$vrf_cert /= [bytes, bytes .size 80]++$kes_vkey /= bytes .size 32+$kes_signature /= bytes .size 448+signkeyKES = bytes .size 64++$signature /= bytes .size 64++finite_set<a> = [* a]++;unit_interval = #6.30([uint, uint])+unit_interval = #6.30([1, 2])+  ; real unit_interval is: #6.30([uint, uint])+  ; but this produces numbers outside the unit interval+  ; and can also produce a zero in the denominator++rational = #6.30([uint, uint])++set<a> = [* a]++address = bytes++reward_account = bytes

@@ -0,0 +1,13 @@+negative = nint++anyfloat = f16 / f32 / f64++f16 = float16+f32 = float32+f64 = float64++bs = bstr / bytes+txt = tstr / text++my_bigint = #6.2(bstr)+my_any = any

@@ -0,0 +1,1 @@+x = uint<3>

@@ -0,0 +1,3 @@+foo<a, b> = [a, b]++x = foo<uint>

@@ -0,0 +1,3 @@+foo<a> = [a]++x = foo<uint, uint>

@@ -0,0 +1,1 @@+x = a

@@ -1,20 +1,26 @@-{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE CPP #-}+#if MIN_VERSION_random(1,3,0)+{-# OPTIONS_GHC -Wno-deprecations #-} -- Due to usage of `split`+#endif+{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DerivingVia #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeData #-}+{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} -#if MIN_VERSION_random(1,3,0)-{-# OPTIONS_GHC -Wno-deprecations #-} -- Due to usage of `split`-#endif -- | Generate example CBOR given a CDDL specification module Codec.CBOR.Cuddle.CBOR.Gen (generateCBORTerm, generateCBORTerm') where +#if MIN_VERSION_random(1,3,0)+import System.Random.Stateful (+  SplitGen (..)+  )+#endif import Capability.Reader import Capability.Sink (HasSink) import Capability.Source (HasSource, MonadState (..))@@ -25,11 +31,12 @@   Value (..),   ValueVariant (..),  )-import Codec.CBOR.Cuddle.CDDL.CTree (CTree, CTreeRoot' (..))+import Codec.CBOR.Cuddle.CDDL.CBORGenerator (CBORGenerator (..), WrappedTerm (..))+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.Postlude (PTerm (..))-import Codec.CBOR.Cuddle.CDDL.Resolve (MonoRef (..))+import Codec.CBOR.Cuddle.CDDL.Resolve (MonoReferenced, XXCTree (..))+import Codec.CBOR.Cuddle.IndexMappable (IndexMappable (..)) import Codec.CBOR.Term (Term (..)) import Codec.CBOR.Term qualified as CBOR import Codec.CBOR.Write qualified as CBOR@@ -39,16 +46,15 @@ import Control.Monad.State.Strict qualified as MTL import Data.Bifunctor (second) import Data.ByteString (ByteString)-import Data.ByteString.Base16 qualified as Base16 import Data.Functor ((<&>))-import Data.Functor.Identity (Identity (runIdentity)) import Data.List.NonEmpty qualified as NE import Data.Map.Strict qualified as Map import Data.Maybe (fromMaybe) import Data.Text (Text) import Data.Text qualified as T-import Data.Word (Word32, Word64)+import Data.Word (Word32) import GHC.Generics (Generic)+import GHC.Stack (HasCallStack) import System.Random.Stateful (   Random,   RandomGen (..),@@ -57,19 +63,25 @@   randomM,   uniformByteStringM,  )-#if MIN_VERSION_random(1,3,0)-import System.Random.Stateful (-  SplitGen (..)-  )-#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 --------------------------------------------------------------------------------  -- | Generator context, parametrised over the type of the random seed newtype GenEnv = GenEnv-  { cddl :: CTreeRoot' Identity MonoRef+  { cddl :: CTreeRoot MonoReferenced   }   deriving (Generic) @@ -121,8 +133,8 @@           ()           (MonadState (StateT (GenState g) (Reader GenEnv)))   deriving-    ( HasSource "cddl" (CTreeRoot' Identity MonoRef)-    , HasReader "cddl" (CTreeRoot' Identity MonoRef)+    ( HasSource "cddl" (CTreeRoot MonoReferenced)+    , HasReader "cddl" (CTreeRoot MonoReferenced)     )     via Field           "cddl"@@ -211,23 +223,14 @@ -- 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]@@ -236,9 +239,6 @@ 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)]@@ -246,18 +246,18 @@ 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 -------------------------------------------------------------------------------- -genForCTree :: RandomGen g => CTree MonoRef -> M g WrappedTerm+genForCTree :: (HasCallStack, RandomGen g) => CTree MonoReferenced -> M g WrappedTerm genForCTree (CTree.Literal v) = S <$> genValue v genForCTree (CTree.Postlude pt) = S <$> genPostlude pt genForCTree (CTree.Map nodes) = do-  items <- pairTermList . flattenWrappedList <$> traverse genForNode nodes+  items <- pairTermList . flattenWrappedList <$> traverse genForCTree nodes   case items of     Just ts ->       let@@ -270,61 +270,66 @@         pure . S $ TMap tsNodup     Nothing -> error "Single terms in map context" genForCTree (CTree.Array nodes) = do-  items <- singleTermList . flattenWrappedList <$> traverse genForNode nodes+  items <- singleTermList . flattenWrappedList <$> traverse genForCTree nodes   case items of     Just ts -> pure . S $ TList ts     Nothing -> error "Something weird happened which shouldn't be possible" genForCTree (CTree.Choice (NE.toList -> nodes)) = do   ix <- genUniformRM (0, length nodes - 1)-  genForNode $ nodes !! ix-genForCTree (CTree.Group nodes) = G <$> traverse genForNode nodes+  genForCTree $ nodes !! ix+genForCTree (CTree.Group nodes) = G <$> traverse genForCTree nodes genForCTree (CTree.KV key value _cut) = do-  kg <- genForNode key-  vg <- genForNode value+  kg <- genForCTree key+  vg <- genForCTree value   case (kg, vg) of     (S k, S v) -> pure $ P k v     _ ->       error $         "Non single-term generated outside of group context: "-          <> show key+          <> showDropGen key           <> " => "-          <> show value+          <> showDropGen value genForCTree (CTree.Occur item occurs) =-  applyOccurenceIndicator occurs (genForNode item)+  applyOccurenceIndicator occurs (genForCTree item) genForCTree (CTree.Range from to _bounds) = do   -- TODO Handle bounds correctly-  term1 <- genForNode from-  term2 <- genForNode to+  term1 <- genForCTree from+  term2 <- genForCTree to   case (term1, term2) of-    (S (TInt a), S (TInt b)) -> genUniformRM (a, b) <&> S . TInt-    (S (TInt a), S (TInteger b)) -> genUniformRM (fromIntegral a, b) <&> S . TInteger-    (S (TInteger a), S (TInteger b)) -> genUniformRM (a, b) <&> S . TInteger-    (S (THalf a), S (THalf b)) -> genUniformRM (a, b) <&> S . THalf-    (S (TFloat a), S (TFloat b)) -> genUniformRM (a, b) <&> S . TFloat-    (S (TDouble a), S (TDouble b)) -> genUniformRM (a, b) <&> S . TDouble-    x -> error $ "Cannot apply range operator to non-numeric types: " <> show x+    (S (TInt a), S (TInt b))+      | a <= b -> genUniformRM (a, b) <&> S . TInt+    (S (TInt a), S (TInteger b))+      | fromIntegral a <= b -> genUniformRM (fromIntegral a, b) <&> S . TInteger+    (S (TInteger a), S (TInteger b))+      | a <= b -> genUniformRM (a, b) <&> S . TInteger+    (S (THalf a), S (THalf b))+      | a <= b -> genUniformRM (a, b) <&> S . THalf+    (S (TFloat a), S (TFloat b))+      | a <= b -> genUniformRM (a, b) <&> S . TFloat+    (S (TDouble a), S (TDouble b))+      | a <= b -> genUniformRM (a, b) <&> S . TDouble+    (a, b) -> error $ "invalid range (a = " <> show a <> ", b = " <> show b <> ")" genForCTree (CTree.Control op target controller) = do-  tt <- resolveIfRef target-  ct <- resolveIfRef controller-  case (op, ct) of-    (CtlOp.Le, CTree.Literal (Value (VUInt n) _)) -> case tt of+  resolvedController <- case controller of+    CTreeE (MRuleRef n) -> resolveRef n+    x -> pure x+  case (op, resolvedController) of+    (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.Lt, CTree.Literal (Value (VUInt n) _)) -> case tt of+    (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.Size, CTree.Literal (Value (VUInt n) _)) -> case tt of+    (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)       CTree.Postlude PTUInt -> S . TInteger <$> genUniformRM (0, 2 ^ n - 1)       _ -> error "Cannot apply size operator to target "     (CtlOp.Size, CTree.Range {CTree.from, CTree.to}) -> do-      f <- resolveIfRef from-      t <- resolveIfRef to-      case (f, t) of-        (CTree.Literal (Value (VUInt f1) _), CTree.Literal (Value (VUInt t1) _)) -> case tt of+      case (from, to) of+        (CTree.Literal (Value (VUInt f1) _), CTree.Literal (Value (VUInt t1) _)) -> case target of           CTree.Postlude PTText ->             genUniformRM (fromIntegral f1, fromIntegral t1)               >>= (fmap (S . TString) . genText)@@ -334,49 +339,49 @@           CTree.Postlude PTUInt ->             S . TInteger               <$> genUniformRM (fromIntegral f1, fromIntegral t1)-          _ -> error $ "Cannot apply size operator to target: " <> show tt+          _ -> 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 ct+      enc <- genForCTree controller       case enc of         S x -> pure . S . TBytes . CBOR.toStrictByteString $ CBOR.encodeTerm x         _ -> error "Controller does not correspond to a single term"-    _ -> genForNode target-genForCTree (CTree.Enum node) = do-  tree <- resolveIfRef node+    _ -> genForCTree target+genForCTree (CTree.Enum tree) = do   case tree of-    CTree.Group nodes -> do-      ix <- genUniformRM (0, length nodes)-      genForNode $ nodes !! ix+    CTree.Group trees -> do+      ix <- genUniformRM (0, length trees - 1)+      genForCTree $ trees !! ix     _ -> error "Attempt to form an enum from something other than a group"-genForCTree (CTree.Unwrap node) = genForCTree =<< resolveIfRef node+genForCTree (CTree.Unwrap node) = genForCTree node genForCTree (CTree.Tag tag node) = do-  enc <- genForNode node+  enc <- genForCTree node   case enc of     S x -> pure $ S $ TTagged tag x     _ -> error "Tag controller does not correspond to a single term"+genForCTree (CTree.CTreeE (MRuleRef n)) = genForNode n+genForCTree (CTree.CTreeE (MGenerator (CBORGenerator gen) _)) = gen StateGenM -genForNode :: RandomGen g => CTree.Node MonoRef -> M g WrappedTerm-genForNode = genForCTree <=< resolveIfRef+genForNode :: (HasCallStack, RandomGen g) => Name -> M g WrappedTerm+genForNode = genForCTree <=< resolveRef --- | Take something which might be a reference and resolve it to the relevant--- Tree, following multiple links if necessary.-resolveIfRef :: RandomGen g => CTree.Node MonoRef -> M g (CTree MonoRef)-resolveIfRef (MIt a) = pure a-resolveIfRef (MRuleRef n) = do+-- | Take a reference and resolve it to the relevant Tree, following multiple+-- links if necessary.+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)   case Map.lookup n cddl of     Nothing -> error $ "Unbound reference: " <> show n-    Just val -> resolveIfRef $ runIdentity val+    Just val -> pure val  -- | Generate a CBOR Term corresponding to a top-level name. --@@ -386,13 +391,13 @@ -- 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 -> M g Term+genForName :: (HasCallStack, RandomGen g) => Name -> M g Term genForName n = do   (CTreeRoot cddl) <- ask @"cddl"   case Map.lookup n cddl of     Nothing -> error $ "Unbound reference: " <> show n     Just val ->-      genForNode (runIdentity val) >>= \case+      genForCTree val >>= \case         S x -> pure x         _ ->           error $@@ -417,8 +422,10 @@   genDepthBiasedRM (1 :: Int, 10) >>= \i ->     G <$> replicateM i oldGen applyOccurenceIndicator (OIBounded mlb mub) oldGen =-  genDepthBiasedRM (fromMaybe 0 mlb :: Word64, fromMaybe 10 mub)+  genDepthBiasedRM (lo, fromMaybe (max 10 lo) mub)     >>= \i -> G <$> replicateM (fromIntegral i) oldGen+  where+    lo = fromMaybe 0 mlb  genValue :: RandomGen g => Value -> M g Term genValue (Value x _) = genValueVariant x@@ -431,22 +438,21 @@ genValueVariant (VFloat32 i) = pure . TFloat $ i genValueVariant (VFloat64 i) = pure . TDouble $ i genValueVariant (VText t) = pure $ TString t-genValueVariant (VBytes b) = case Base16.decode b of-  Right bHex -> pure $ TBytes bHex-  Left err -> error $ "Unable to parse hex encoded bytestring: " <> err+genValueVariant (VBytes b) = pure $ TBytes b genValueVariant (VBool b) = pure $ TBool b  -------------------------------------------------------------------------------- -- Generator functions -------------------------------------------------------------------------------- -generateCBORTerm :: RandomGen g => CTreeRoot' Identity MonoRef -> Name -> g -> Term+generateCBORTerm :: (HasCallStack, 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' Identity MonoRef -> Name -> g -> (Term, g)+generateCBORTerm' ::+  (HasCallStack, RandomGen g) => CTreeRoot MonoReferenced -> Name -> g -> (Term, g) generateCBORTerm' cddl n stdGen =   let genEnv = GenEnv {cddl}       genState = GenState {randomSeed = stdGen, depth = 1}

@@ -1,1009 +1,879 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ViewPatterns #-}-{-# OPTIONS_GHC -Wno-incomplete-patterns #-}--module Codec.CBOR.Cuddle.CBOR.Validator where--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.Postlude-import Codec.CBOR.Cuddle.CDDL.Resolve-import Codec.CBOR.Read-import Codec.CBOR.Term-import Control.Exception-import Control.Monad ((>=>))-import Control.Monad.Reader-import Data.Bifunctor-import Data.Bits hiding (And)-import Data.ByteString qualified as BS-import Data.ByteString.Lazy qualified as BSL-import Data.Function ((&))-import Data.Functor ((<&>))-import Data.Functor.Identity-import Data.IntSet qualified as IS-import Data.List.NonEmpty qualified as NE-import Data.Map.Strict qualified as Map-import Data.Maybe-import Data.Text qualified as T-import Data.Text.Lazy qualified as TL-import Data.Word-import GHC.Float-import System.Exit-import System.IO-import Text.Regex.TDFA--type CDDL = CTreeRoot' Identity MonoRef-type Rule = Node MonoRef-type ResolvedRule = CTree MonoRef--data CBORTermResult = CBORTermResult Term CDDLResult-  deriving (Show)--data CDDLResult-  = -- | The rule was valid-    Valid Rule-  | -- | All alternatives failed-    ChoiceFail-      -- | Rule we are trying-      Rule-      -- | The alternatives that arise from said rule-      (NE.NonEmpty Rule)-      -- | For each alternative, the result-      (NE.NonEmpty (Rule, CDDLResult))-  | -- | All expansions failed-    ---    -- An expansion is: Given a CBOR @TList@ of @N@ elements, we will expand the-    -- rules in a list spec to match the number of items in the list.-    ListExpansionFail-      -- | Rule we are trying-      Rule-      -- | List of expansions of rules-      [[Rule]]-      -- | For each expansion, for each of the rules in the expansion, the result-      [[(Rule, CBORTermResult)]]-  | -- | All expansions failed-    ---    -- An expansion is: Given a CBOR @TMap@ of @N@ elements, we will expand the-    -- rules in a map spec to match the number of items in the map.-    MapExpansionFail-      -- | Rule we are trying-      Rule-      -- | List of expansions-      [[Rule]]-      -- | A list of matched items @(key, value, rule)@ and the unmatched item-      [([AMatchedItem], ANonMatchedItem)]-  | -- | The rule was valid but the control failed-    InvalidControl-      -- | Control we are trying-      Rule-      -- | If it is a .cbor, the result of the underlying validation-      (Maybe CBORTermResult)-  | InvalidRule Rule-  | -- | A tagged was invalid-    InvalidTagged-      -- | Rule we are trying-      Rule-      -- | Either the tag is wrong, or the contents are wrong-      (Either Word64 CBORTermResult)-  | -- | The rule we are trying is not applicable to the CBOR term-    UnapplicableRule-      -- | Rule we are trying-      Rule-  deriving (Show)--data ANonMatchedItem = ANonMatchedItem-  { anmiKey :: Term-  , anmiValue :: Term-  , anmiResults :: [Either (Rule, CDDLResult) (Rule, CDDLResult, CDDLResult)]-  -- ^ For all the tried rules, either the key failed or the key succeeded and-  -- the value failed-  }-  deriving (Show)--data AMatchedItem = AMatchedItem-  { amiKey :: Term-  , amiValue :: Term-  , amiRule :: Rule-  }-  deriving (Show)------------------------------------------------------------------------------------- Main entry point--validateCBOR :: BS.ByteString -> Name -> CDDL -> IO ()-validateCBOR bs rule cddl =-  ( case validateCBOR' bs rule cddl of-      ok@(CBORTermResult _ (Valid _)) -> do-        putStrLn $ "Valid " ++ show ok-        exitSuccess-      err -> do-        hPutStrLn stderr $ "Invalid " ++ show err-        exitFailure-  )-    `catch` ( \(e :: PatternMatchFail) ->-                putStrLn $-                  "You uncovered a path we thought was impossible! Please submit your CDDL and CBOR to `https://github.com/input-output-hk/cuddle/issues` for us to investigate\n"-                    <> displayException e-            )--validateCBOR' ::-  BS.ByteString -> Name -> CDDL -> CBORTermResult-validateCBOR' bs rule cddl@(CTreeRoot tree) =-  case deserialiseFromBytes decodeTerm (BSL.fromStrict bs) of-    Left e -> error $ show e-    Right (rest, term) ->-      if BSL.null rest-        then runReader (validateTerm term (runIdentity $ tree Map.! rule)) cddl-        else runReader (validateTerm (TBytes bs) (runIdentity $ tree Map.! rule)) cddl------------------------------------------------------------------------------------- Terms---- | Core function that validates a CBOR term to a particular rule of the CDDL--- spec-validateTerm ::-  MonadReader CDDL m =>-  Term -> Rule -> m CBORTermResult-validateTerm term rule =-  let f = case term of-        TInt i -> validateInteger (fromIntegral i)-        TInteger i -> validateInteger i-        TBytes b -> validateBytes b-        TBytesI b -> validateBytes (BSL.toStrict b)-        TString s -> validateText s-        TStringI s -> validateText (TL.toStrict s)-        TList ts -> validateList ts-        TListI ts -> validateList ts-        TMap ts -> validateMap ts-        TMapI ts -> validateMap ts-        TTagged w t -> validateTagged w t-        TBool b -> validateBool b-        TNull -> validateNull-        TSimple s -> validateSimple s-        THalf h -> validateHalf h-        TFloat h -> validateFloat h-        TDouble d -> validateDouble d-   in CBORTermResult term <$> f rule------------------------------------------------------------------------------------- Ints and integers---- | Validation of an Int or Integer. CBOR categorizes every integral in `TInt`--- or `TInteger` but it can be the case that we are decoding something that is--- expected to be a `Word64` even if we get a `TInt`.------ > ghci> encodeWord64 15--- > [TkInt 15]--- > ghci> encodeWord64 maxBound--- > [TkInteger 18446744073709551615]------ For this reason, we cannot assume that bounds or literals are going to be--- Ints, so we convert everything to Integer.-validateInteger ::-  MonadReader CDDL m =>-  Integer -> Rule -> m CDDLResult-validateInteger i rule =-  ($ rule) <$> do-    getRule rule >>= \case-      -- echo "C24101" | xxd -r -p - example.cbor-      -- echo "foo = int" > a.cddl-      -- cddl a.cddl validate example.cbor-      ---      -- but-      ---      -- echo "C249010000000000000000"| xxd -r -p - example.cbor-      -- echo "foo = int" > a.cddl-      -- cddl a.cddl validate example.cbor-      ---      -- and they are both bigints?--      -- a = any-      Postlude PTAny -> pure Valid-      -- a = int-      Postlude PTInt -> pure Valid-      -- a = uint-      Postlude PTUInt -> pure $ check (i >= 0)-      -- a = nint-      Postlude PTNInt -> pure $ check (i <= 0)-      -- a = x-      Literal (Value (VUInt i') _) -> pure $ check $ i == fromIntegral i'-      -- a = -x-      Literal (Value (VNInt i') _) -> pure $ check $ -i == fromIntegral i'-      -- a = <big number>-      Literal (Value (VBignum i') _) -> pure $ check $ i == i'-      -- a = foo .ctrl bar-      Control op tgt ctrl -> ctrlDispatch (validateInteger i) op tgt ctrl (controlInteger i)-      -- a = foo / bar-      Choice opts -> validateChoice (validateInteger i) opts-      -- a = x..y-      Range low high bound ->-        ((,) <$> getRule low <*> getRule high)-          <&> check . \case-            (Literal (Value (VUInt (fromIntegral -> n)) _), Literal (Value (VUInt (fromIntegral -> m)) _)) -> n <= i && range bound i m-            (Literal (Value (VNInt (fromIntegral -> n)) _), Literal (Value (VUInt (fromIntegral -> m)) _)) -> -n <= i && range bound i m-            (Literal (Value (VNInt (fromIntegral -> n)) _), Literal (Value (VNInt (fromIntegral -> m)) _)) -> -n <= i && range bound i (-m)-            (Literal (Value VUInt {} _), Literal (Value VNInt {} _)) -> False-            (Literal (Value (VBignum n) _), Literal (Value (VUInt (fromIntegral -> m)) _)) -> n <= i && range bound i m-            (Literal (Value (VBignum n) _), Literal (Value (VNInt (fromIntegral -> m)) _)) -> n <= i && range bound i (-m)-            (Literal (Value (VUInt (fromIntegral -> n)) _), Literal (Value (VBignum m) _)) -> n <= i && range bound i m-            (Literal (Value (VNInt (fromIntegral -> n)) _), Literal (Value (VBignum m) _)) -> (-n) <= i && range bound i m-      -- a = &(x, y, z)-      Enum g ->-        getRule g >>= \case-          Group g' -> validateInteger i (MIt (Choice (NE.fromList g'))) <&> replaceRule-      -- a = x: y-      -- Note KV cannot appear on its own, but we will use this when validating-      -- lists.-      KV _ v _ -> validateInteger i v <&> replaceRule-      Tag 2 (MIt (Postlude PTBytes)) -> pure Valid-      Tag 3 (MIt (Postlude PTBytes)) -> pure Valid-      _ -> pure UnapplicableRule---- | Controls for an Integer-controlInteger ::-  forall m. MonadReader CDDL m => Integer -> CtlOp -> Rule -> m (Either (Maybe CBORTermResult) ())-controlInteger i Size ctrl =-  getRule ctrl <&> \case-    Literal (Value (VUInt sz) _) ->-      boolCtrl $ 0 <= i && i < 256 ^ sz-controlInteger i Bits ctrl = do-  indices <--    getRule ctrl >>= \case-      Literal (Value (VUInt i') _) -> pure [i']-      Choice nodes -> getIndicesOfChoice nodes-      Range ff tt incl -> getIndicesOfRange ff tt incl-      Enum g -> getIndicesOfEnum g-  pure $ boolCtrl $ go (IS.fromList (map fromIntegral indices)) i 0-  where-    go _ 0 _ = True-    go indices n idx =-      let bitSet = testBit n 0-          allowed = not bitSet || IS.member idx indices-       in (allowed && go indices (shiftR n 1) (idx + 1))-controlInteger i Lt ctrl =-  getRule ctrl-    <&> boolCtrl . \case-      Literal (Value (VUInt i') _) -> i < fromIntegral i'-      Literal (Value (VNInt i') _) -> i < -fromIntegral i'-      Literal (Value (VBignum i') _) -> i < i'-controlInteger i Gt ctrl =-  getRule ctrl-    <&> boolCtrl . \case-      Literal (Value (VUInt i') _) -> i > fromIntegral i'-      Literal (Value (VNInt i') _) -> i > -fromIntegral i'-      Literal (Value (VBignum i') _) -> i > i'-controlInteger i Le ctrl =-  getRule ctrl-    <&> boolCtrl . \case-      Literal (Value (VUInt i') _) -> i <= fromIntegral i'-      Literal (Value (VNInt i') _) -> i <= -fromIntegral i'-      Literal (Value (VBignum i') _) -> i <= i'-controlInteger i Ge ctrl =-  getRule ctrl-    <&> boolCtrl . \case-      Literal (Value (VUInt i') _) -> i >= fromIntegral i'-      Literal (Value (VNInt i') _) -> i >= -fromIntegral i'-      Literal (Value (VBignum i') _) -> i >= i'-controlInteger i Eq ctrl =-  getRule ctrl-    <&> boolCtrl . \case-      Literal (Value (VUInt i') _) -> i == fromIntegral i'-      Literal (Value (VNInt i') _) -> i == -fromIntegral i'-      Literal (Value (VBignum i') _) -> i == i'-controlInteger i Ne ctrl =-  getRule ctrl-    <&> boolCtrl . \case-      Literal (Value (VUInt i') _) -> i /= fromIntegral i'-      Literal (Value (VNInt i') _) -> i /= -fromIntegral i'-      Literal (Value (VBignum i') _) -> i /= i'------------------------------------------------------------------------------------- Floating point (Float16, Float32, Float64)------ As opposed to Integral types, there seems to be no ambiguity when encoding--- and decoding floating-point numbers.---- | Validating a `Float16`-validateHalf ::-  MonadReader CDDL m =>-  Float -> Rule -> m CDDLResult-validateHalf f rule =-  ($ rule) <$> do-    getRule rule >>= \case-      -- a = any-      Postlude PTAny -> pure Valid-      -- a = float16-      Postlude PTHalf -> pure Valid-      -- a = 0.5-      Literal (Value (VFloat16 f') _) -> pure $ check $ f == f'-      -- a = foo / bar-      Choice opts -> validateChoice (validateHalf f) opts-      -- a = foo .ctrl bar-      Control op tgt ctrl -> ctrlDispatch (validateHalf f) op tgt ctrl (controlHalf f)-      -- a = x..y-      Range low high bound ->-        ((,) <$> getRule low <*> getRule high)-          <&> check . \case-            (Literal (Value (VFloat16 n) _), Literal (Value (VFloat16 m) _)) -> n <= f && range bound f m-      _ -> pure UnapplicableRule---- | Controls for `Float16`-controlHalf :: MonadReader CDDL m => Float -> CtlOp -> Rule -> m (Either (Maybe CBORTermResult) ())-controlHalf f Eq ctrl =-  getRule ctrl-    <&> boolCtrl . \case-      Literal (Value (VFloat16 f') _) -> f == f'-controlHalf f Ne ctrl =-  getRule ctrl-    <&> boolCtrl . \case-      Literal (Value (VFloat16 f') _) -> f /= f'---- | Validating a `Float32`-validateFloat ::-  MonadReader CDDL m =>-  Float -> Rule -> m CDDLResult-validateFloat f rule =-  ($ rule) <$> do-    getRule rule >>= \case-      -- a = any-      Postlude PTAny -> pure Valid-      -- a = float32-      Postlude PTFloat -> pure Valid-      -- a = 0.000000005-      -- TODO: it is unclear if smaller floats should also validate-      Literal (Value (VFloat32 f') _) -> pure $ check $ f == f'-      -- a = foo / bar-      Choice opts -> validateChoice (validateFloat f) opts-      -- a = foo .ctrl bar-      Control op tgt ctrl -> ctrlDispatch (validateFloat f) op tgt ctrl (controlFloat f)-      -- a = x..y-      -- TODO it is unclear if this should mix floating point types too-      Range low high bound ->-        ((,) <$> getRule low <*> getRule high)-          <&> check . \case-            (Literal (Value (VFloat16 n) _), Literal (Value (VFloat16 m) _)) -> n <= f && range bound f m-            (Literal (Value (VFloat32 n) _), Literal (Value (VFloat32 m) _)) -> n <= f && range bound f m-      _ -> pure UnapplicableRule---- | Controls for `Float32`-controlFloat :: MonadReader CDDL m => Float -> CtlOp -> Rule -> m (Either (Maybe CBORTermResult) ())-controlFloat f Eq ctrl =-  getRule ctrl-    <&> boolCtrl . \case-      Literal (Value (VFloat16 f') _) -> f == f'-      Literal (Value (VFloat32 f') _) -> f == f'-controlFloat f Ne ctrl =-  getRule ctrl-    <&> boolCtrl . \case-      Literal (Value (VFloat16 f') _) -> f /= f'-      Literal (Value (VFloat32 f') _) -> f /= f'---- | Validating a `Float64`-validateDouble ::-  MonadReader CDDL m =>-  Double -> Rule -> m CDDLResult-validateDouble f rule =-  ($ rule) <$> do-    getRule rule >>= \case-      -- a = any-      Postlude PTAny -> pure Valid-      -- a = float64-      Postlude PTDouble -> pure Valid-      -- a = 0.0000000000000000000000000000000000000000000005-      -- TODO: it is unclear if smaller floats should also validate-      Literal (Value (VFloat64 f') _) -> pure $ check $ f == f'-      -- a = foo / bar-      Choice opts -> validateChoice (validateDouble f) opts-      -- a = foo .ctrl bar-      Control op tgt ctrl -> ctrlDispatch (validateDouble f) op tgt ctrl (controlDouble f)-      -- a = x..y-      -- TODO it is unclear if this should mix floating point types too-      Range low high bound ->-        ((,) <$> getRule low <*> getRule high)-          <&> check . \case-            (Literal (Value (VFloat16 (float2Double -> n)) _), Literal (Value (VFloat16 (float2Double -> m)) _)) -> n <= f && range bound f m-            (Literal (Value (VFloat32 (float2Double -> n)) _), Literal (Value (VFloat32 (float2Double -> m)) _)) -> n <= f && range bound f m-            (Literal (Value (VFloat64 n) _), Literal (Value (VFloat64 m) _)) -> n <= f && range bound f m-      _ -> pure UnapplicableRule---- | Controls for `Float64`-controlDouble ::-  MonadReader CDDL m => Double -> CtlOp -> Rule -> m (Either (Maybe CBORTermResult) ())-controlDouble f Eq ctrl =-  getRule ctrl-    <&> boolCtrl . \case-      Literal (Value (VFloat16 f') _) -> f == float2Double f'-      Literal (Value (VFloat32 f') _) -> f == float2Double f'-      Literal (Value (VFloat64 f') _) -> f == f'-controlDouble f Ne ctrl =-  getRule ctrl-    <&> boolCtrl . \case-      Literal (Value (VFloat16 f') _) -> f /= float2Double f'-      Literal (Value (VFloat32 f') _) -> f /= float2Double f'-      Literal (Value (VFloat64 f') _) -> f /= f'------------------------------------------------------------------------------------- Bool---- | Validating a boolean-validateBool ::-  MonadReader CDDL m =>-  Bool -> Rule -> m CDDLResult-validateBool b rule =-  ($ rule) <$> do-    getRule rule >>= \case-      -- a = any-      Postlude PTAny -> pure Valid-      -- a = bool-      Postlude PTBool -> pure Valid-      -- a = true-      Literal (Value (VBool b') _) -> pure $ check $ b == b'-      -- a = foo .ctrl bar-      Control op tgt ctrl -> ctrlDispatch (validateBool b) op tgt ctrl (controlBool b)-      -- a = foo / bar-      Choice opts -> validateChoice (validateBool b) opts-      _ -> pure UnapplicableRule---- | Controls for `Bool`-controlBool :: MonadReader CDDL m => Bool -> CtlOp -> Rule -> m (Either (Maybe CBORTermResult) ())-controlBool b Eq ctrl =-  getRule ctrl-    <&> boolCtrl . \case-      Literal (Value (VBool b') _) -> b == b'-controlBool b Ne ctrl =-  getRule ctrl-    <&> boolCtrl . \case-      Literal (Value (VBool b') _) -> b /= b'------------------------------------------------------------------------------------- Simple---- | Validating a `TSimple`. It is unclear if this is used for anything else than undefined.-validateSimple ::-  MonadReader CDDL m =>-  Word8 -> Rule -> m CDDLResult-validateSimple 23 rule =-  ($ rule) <$> do-    getRule rule >>= \case-      -- a = any-      Postlude PTAny -> pure Valid-      -- a = undefined-      Postlude PTUndefined -> pure Valid-      -- a = foo / bar-      Choice opts -> validateChoice (validateSimple 23) opts-      _ -> pure UnapplicableRule-validateSimple n _ = error $ "Found simple different to 23! please report this somewhere! Found: " <> show n------------------------------------------------------------------------------------- Null/nil---- | Validating nil-validateNull ::-  MonadReader CDDL m => Rule -> m CDDLResult-validateNull rule =-  ($ rule) <$> do-    getRule rule >>= \case-      -- a = any-      Postlude PTAny -> pure Valid-      -- a = nil-      Postlude PTNil -> pure Valid-      Choice opts -> validateChoice validateNull opts-      _ -> pure UnapplicableRule------------------------------------------------------------------------------------- Bytes---- | Validating a byte sequence-validateBytes ::-  MonadReader CDDL m =>-  BS.ByteString -> Rule -> m CDDLResult-validateBytes bs rule =-  ($ rule) <$> do-    getRule rule >>= \case-      -- a = any-      Postlude PTAny -> pure Valid-      -- a = bytes-      Postlude PTBytes -> pure Valid-      -- a = h'123456'-      Literal (Value (VBytes bs') _) -> pure $ check $ bs == bs'-      -- a = foo .ctrl bar-      Control op tgt ctrl -> ctrlDispatch (validateBytes bs) op tgt ctrl (controlBytes bs)-      -- a = foo / bar-      Choice opts -> validateChoice (validateBytes bs) opts-      _ -> pure UnapplicableRule---- | Controls for byte strings-controlBytes ::-  forall m.-  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-    Range low high bound ->-      let i = BS.length bs-       in ((,) <$> getRule low <*> getRule high)-            <&> boolCtrl . \case-              (Literal (Value (VUInt (fromIntegral -> n)) _), Literal (Value (VUInt (fromIntegral -> m)) _)) -> n <= i && range bound i m-              (Literal (Value (VNInt (fromIntegral -> n)) _), Literal (Value (VUInt (fromIntegral -> m)) _)) -> -n <= i && range bound i m-              (Literal (Value (VNInt (fromIntegral -> n)) _), Literal (Value (VNInt (fromIntegral -> m)) _)) -> -n <= i && range bound i (-m)-              (Literal (Value VUInt {} _), Literal (Value VNInt {} _)) -> False-controlBytes bs Bits ctrl = do-  indices <--    getRule ctrl >>= \case-      Literal (Value (VUInt i') _) -> pure [i']-      Choice nodes -> getIndicesOfChoice nodes-      Range ff tt incl -> getIndicesOfRange ff tt incl-      Enum g -> getIndicesOfEnum g-  pure $ boolCtrl $ bitsControlCheck (map fromIntegral indices)-  where-    bitsControlCheck :: [Int] -> Bool-    bitsControlCheck allowedBits =-      let allowedSet = IS.fromList allowedBits-          totalBits = BS.length bs * 8-          isAllowedBit n =-            let byteIndex = n `shiftR` 3-                bitIndex = n .&. 7-             in case BS.indexMaybe bs byteIndex of-                  Just byte -> not (testBit byte bitIndex) || IS.member n allowedSet-                  Nothing -> True-       in all isAllowedBit [0 .. totalBits - 1]-controlBytes bs Cbor ctrl =-  case deserialiseFromBytes decodeTerm (BSL.fromStrict bs) of-    Right (BSL.null -> True, term) ->-      validateTerm term ctrl >>= \case-        CBORTermResult _ (Valid _) -> pure $ Right ()-        err -> pure $ Left $ Just err-controlBytes bs Cborseq ctrl =-  case deserialiseFromBytes decodeTerm (BSL.fromStrict (BS.snoc (BS.cons 0x9f bs) 0xff)) of-    Right (BSL.null -> True, TListI terms) ->-      validateTerm (TList terms) (MIt (Array [MIt (Occur ctrl OIZeroOrMore)])) >>= \case-        CBORTermResult _ (Valid _) -> pure $ Right ()-        CBORTermResult _ err -> error $ show err------------------------------------------------------------------------------------- Text---- | Validating text strings-validateText ::-  MonadReader CDDL m =>-  T.Text -> Rule -> m CDDLResult-validateText txt rule =-  ($ rule) <$> do-    getRule rule >>= \case-      -- a = any-      Postlude PTAny -> pure Valid-      -- a = text-      Postlude PTText -> pure Valid-      -- a = "foo"-      Literal (Value (VText txt') _) -> pure $ check $ txt == txt'-      -- a = foo .ctrl bar-      Control op tgt ctrl -> ctrlDispatch (validateText txt) op tgt ctrl (controlText txt)-      -- a = foo / bar-      Choice opts -> validateChoice (validateText txt) opts-      _ -> pure UnapplicableRule---- | Controls for text strings-controlText :: MonadReader CDDL m => T.Text -> CtlOp -> Rule -> m (Either (Maybe CBORTermResult) ())-controlText bs Size ctrl =-  getRule ctrl >>= \case-    Literal (Value (VUInt (fromIntegral -> sz)) _) -> pure $ boolCtrl $ T.length bs == sz-    Range ff tt bound ->-      ((,) <$> getRule ff <*> getRule tt)-        <&> boolCtrl . \case-          (Literal (Value (VUInt (fromIntegral -> n)) _), Literal (Value (VUInt (fromIntegral -> m)) _)) -> n <= T.length bs && range bound (T.length bs) m-          (Literal (Value (VNInt (fromIntegral -> n)) _), Literal (Value (VUInt (fromIntegral -> m)) _)) -> -n <= T.length bs && range bound (T.length bs) m-          (Literal (Value (VNInt (fromIntegral -> n)) _), Literal (Value (VNInt (fromIntegral -> m)) _)) -> -n <= T.length bs && range bound (T.length bs) (-m)-controlText s Regexp ctrl =-  getRule ctrl-    <&> boolCtrl . \case-      Literal (Value (VText rxp) _) -> case s =~ rxp :: (T.Text, T.Text, T.Text) of-        ("", s', "") -> s == s'------------------------------------------------------------------------------------- Tagged values---- | Validating a `TTagged`-validateTagged ::-  MonadReader CDDL m =>-  Word64 -> Term -> Rule -> m CDDLResult-validateTagged tag term rule =-  ($ rule) <$> do-    getRule rule >>= \case-      Postlude PTAny -> pure Valid-      Tag tag' rule' ->-        -- If the tag does not match, this is a direct fail-        if tag == tag'-          then-            ask >>= \cddl ->-              case runReader (validateTerm term rule') cddl of-                CBORTermResult _ (Valid _) -> pure Valid-                err -> pure $ \r -> InvalidTagged r (Right err)-          else pure $ \r -> InvalidTagged r (Left tag)-      Choice opts -> validateChoice (validateTagged tag term) opts-      _ -> pure UnapplicableRule------------------------------------------------------------------------------------- Collection helpers---- | Groups might contain enums, or unwraps inside. This resolves all those to--- the top level of the group.-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]-        Group g -> flattenGroup cddl g-    | rule <- nodes-    ]---- | Expand rules to reach exactly the wanted length, which must be the number--- of items in the container. For example, if we want to validate 3 elements,--- and we have the following CDDL:------ > a = [* int, * bool]------ this will be expanded to `[int, int, int], [int, int, bool], [int, bool,--- bool], [bool, bool, bool]`.------ Essentially the rules we will parse is the choice among the expansions of the--- original rules.-expandRules :: Int -> [Rule] -> Reader CDDL [[Rule]]-expandRules remainingLen []-  | remainingLen /= 0 = pure []-expandRules _ [] = pure [[]]-expandRules remainingLen _-  | remainingLen < 0 = pure []-  | remainingLen == 0 = pure [[]]-expandRules remainingLen (x : xs) = do-  y <- expandRule remainingLen x-  concat-    <$> mapM-      ( \y' -> do-          suffixes <- expandRules (remainingLen - length y') xs-          pure [y' ++ ys' | ys' <- suffixes]-      )-      y--expandRule :: Int -> Rule -> Reader CDDL [[Rule]]-expandRule maxLen _-  | maxLen < 0 = pure []-expandRule maxLen rule =-  getRule rule >>= \case-    Occur o OIOptional -> pure $ [] : [[o] | maxLen > 0]-    Occur o OIZeroOrMore -> ([] :) <$> expandRule maxLen (MIt (Occur o OIOneOrMore))-    Occur o OIOneOrMore ->-      if maxLen > 0-        then ([o] :) . map (o :) <$> expandRule (maxLen - 1) (MIt (Occur o OIOneOrMore))-        else pure []-    Occur o (OIBounded low high) -> case (low, high) of-      (Nothing, Nothing) -> expandRule maxLen (MIt (Occur o OIZeroOrMore))-      (Just (fromIntegral -> low'), Nothing) ->-        if maxLen >= low'-          then map (replicate low' o ++) <$> expandRule (maxLen - low') (MIt (Occur o OIZeroOrMore))-          else pure []-      (Nothing, Just (fromIntegral -> high')) ->-        pure [replicate n o | n <- [0 .. min maxLen high']]-      (Just (fromIntegral -> low'), Just (fromIntegral -> high')) ->-        if maxLen >= low'-          then pure [replicate n o | n <- [low' .. min maxLen high']]-          else pure []-    _ -> pure [[rule | maxLen > 0]]---- | Which rules are optional?-isOptional :: MonadReader CDDL m => Rule -> m Bool-isOptional rule =-  getRule rule-    <&> \case-      Occur _ OIOptional -> True-      Occur _ OIZeroOrMore -> True-      Occur _ (OIBounded Nothing _) -> True-      Occur _ (OIBounded (Just 0) _) -> True-      _ -> False---- ----------------------------------------------------------------------------------- -- Lists--validateListWithExpandedRules ::-  forall m.-  MonadReader CDDL m =>-  [Term] -> [Rule] -> m [(Rule, CBORTermResult)]-validateListWithExpandedRules terms rules =-  go (zip terms rules)-  where-    go ::-      [(Term, Rule)] -> m [(Rule, CBORTermResult)]-    go [] = pure []-    go ((t, r) : ts) =-      getRule r >>= \case-        -- Should the rule be a KV, then we validate the rule for the value-        KV _ v _ ->-          -- We need to do this juggling because validateTerm has a different-          -- error type-          ask >>= \cddl ->-            case runReader (validateTerm t v) cddl of-              ok@(CBORTermResult _ (Valid _)) -> ((r, ok) :) <$> go ts-              err -> pure [(r, err)]-        _ ->-          ask >>= \cddl ->-            case runReader (validateTerm t r) cddl of-              ok@(CBORTermResult _ (Valid _)) -> ((r, ok) :) <$> go ts-              err -> pure [(r, err)]--validateExpandedList ::-  forall m.-  MonadReader CDDL m =>-  [Term] ->-  [[Rule]] ->-  m (Rule -> CDDLResult)-validateExpandedList terms rules = go rules-  where-    go :: [[Rule]] -> m (Rule -> CDDLResult)-    go [] = pure $ \r -> ListExpansionFail r rules []-    go (choice : choices) = do-      res <- validateListWithExpandedRules terms choice-      case res of-        [] -> pure Valid-        _ -> case last res of-          (_, CBORTermResult _ (Valid _)) -> pure Valid-          _ ->-            go choices-              >>= ( \case-                      Valid _ -> pure Valid-                      ListExpansionFail _ _ errors -> pure $ \r -> ListExpansionFail r rules (res : errors)-                  )-                . ($ dummyRule)--validateList ::-  MonadReader CDDL m => [Term] -> Rule -> m CDDLResult-validateList terms rule =-  ($ rule) <$> do-    getRule rule >>= \case-      Postlude PTAny -> pure Valid-      Array rules ->-        case terms of-          [] -> ifM (and <$> mapM isOptional rules) (pure Valid) (pure InvalidRule)-          _ ->-            ask >>= \cddl ->-              let sequencesOfRules =-                    runReader (expandRules (length terms) $ flattenGroup cddl rules) cddl-               in validateExpandedList terms sequencesOfRules-      Choice opts -> validateChoice (validateList terms) opts-      _ -> pure UnapplicableRule------------------------------------------------------------------------------------- Maps--validateMapWithExpandedRules ::-  forall m.-  MonadReader CDDL m =>-  [(Term, Term)] -> [Rule] -> m ([AMatchedItem], Maybe ANonMatchedItem)-validateMapWithExpandedRules =-  go-  where-    go ::-      [(Term, Term)] ->-      [Rule] ->-      m ([AMatchedItem], Maybe ANonMatchedItem)-    go [] [] = pure ([], Nothing)-    go ((tk, tv) : ts) rs = do-      go' tk tv rs >>= \case-        Left tt -> pure ([], Just tt)-        Right (res, rs') ->-          first (res :) <$> go ts rs'--    -- For each pair of terms, try to find some rule that can be applied here,-    -- and returns the others if there is a succesful match.-    go' :: Term -> Term -> [Rule] -> m (Either ANonMatchedItem (AMatchedItem, [Rule]))-    go' tk tv [] = pure $ Left $ ANonMatchedItem tk tv []-    go' tk tv (r : rs) =-      getRule r >>= \case-        KV k v _ ->-          ask >>= \cddl ->-            case runReader (validateTerm tk k) cddl of-              CBORTermResult _ r1@(Valid _) -> case runReader (validateTerm tv v) cddl of-                CBORTermResult _ (Valid _) -> pure (Right (AMatchedItem tk tv r, rs))-                CBORTermResult _ r2 ->-                  bimap (\anmi -> anmi {anmiResults = Right (r, r1, r2) : anmiResults anmi}) (second (r :))-                    <$> go' tk tv rs-              CBORTermResult _ r1 ->-                bimap (\anmi -> anmi {anmiResults = Left (r, r1) : anmiResults anmi}) (second (r :))-                  <$> go' tk tv rs--validateExpandedMap ::-  forall m.-  MonadReader CDDL m =>-  [(Term, Term)] ->-  [[Rule]] ->-  m (Rule -> CDDLResult)-validateExpandedMap terms rules = go rules-  where-    go :: [[Rule]] -> m (Rule -> CDDLResult)-    go [] = pure $ \r -> MapExpansionFail r rules []-    go (choice : choices) = do-      res <- validateMapWithExpandedRules terms choice-      case res of-        (_, Nothing) -> pure Valid-        (matches, Just notMatched) ->-          go choices-            >>= ( \case-                    Valid _ -> pure Valid-                    MapExpansionFail _ _ errors ->-                      pure $ \r -> MapExpansionFail r rules ((matches, notMatched) : errors)-                )-              . ($ dummyRule)--validateMap ::-  MonadReader CDDL m =>-  [(Term, Term)] -> Rule -> m CDDLResult-validateMap terms rule =-  ($ rule) <$> do-    getRule rule >>= \case-      Postlude PTAny -> pure Valid-      Map rules ->-        case terms of-          [] -> ifM (and <$> mapM isOptional rules) (pure Valid) (pure InvalidRule)-          _ ->-            ask >>= \cddl ->-              let sequencesOfRules =-                    runReader (expandRules (length terms) $ flattenGroup cddl rules) cddl-               in validateExpandedMap terms sequencesOfRules-      Choice opts -> validateChoice (validateMap terms) opts-      _ -> pure UnapplicableRule------------------------------------------------------------------------------------- Choices--validateChoice ::-  forall m. Monad m => (Rule -> m CDDLResult) -> NE.NonEmpty Rule -> m (Rule -> CDDLResult)-validateChoice v rules = go rules-  where-    go :: NE.NonEmpty Rule -> m (Rule -> CDDLResult)-    go (choice NE.:| xs) = do-      v choice >>= \case-        Valid _ -> pure Valid-        err -> case NE.nonEmpty xs of-          Nothing -> pure $ \r -> ChoiceFail r rules ((choice, err) NE.:| [])-          Just choices ->-            go choices-              >>= ( \case-                      Valid _ -> pure Valid-                      ChoiceFail _ _ errors -> pure $ \r -> ChoiceFail r rules ((choice, err) NE.<| errors)-                  )-                . ($ dummyRule)--dummyRule :: Rule-dummyRule = MRuleRef (Name "dummy" mempty)------------------------------------------------------------------------------------- Control helpers---- | Validate both rules-ctrlAnd ::-  Monad m =>-  (Rule -> m CDDLResult) -> Rule -> Rule -> m (Rule -> CDDLResult)-ctrlAnd v tgt ctrl =-  v tgt >>= \case-    Valid _ ->-      v ctrl <&> \case-        Valid _ -> Valid-        _ -> flip InvalidControl Nothing-    _ -> pure InvalidRule---- | Dispatch to the appropriate control-ctrlDispatch ::-  Monad m =>-  (Rule -> m CDDLResult) ->-  CtlOp ->-  Rule ->-  Rule ->-  (CtlOp -> Rule -> m (Either (Maybe CBORTermResult) ())) ->-  m (Rule -> CDDLResult)-ctrlDispatch v And tgt ctrl _ = ctrlAnd v tgt ctrl-ctrlDispatch v Within tgt ctrl _ = ctrlAnd v tgt ctrl-ctrlDispatch v op tgt ctrl vctrl =-  v tgt >>= \case-    Valid _ ->-      vctrl op ctrl <&> \case-        Left err -> flip InvalidControl err-        Right () -> Valid-    _ -> pure InvalidRule---- | A boolean control-boolCtrl :: Bool -> Either (Maybe CBORTermResult) ()-boolCtrl c = if c then Right () else Left Nothing------------------------------------------------------------------------------------- Bits control--getIndicesOfChoice :: MonadReader CDDL m => NE.NonEmpty Rule -> m [Word64]-getIndicesOfChoice nodes =-  mconcat-    . NE.toList-    <$> mapM-      ( getRule-          >=> ( \case-                  Literal (Value (VUInt v) _) -> pure [fromIntegral v]-                  KV _ v _ ->-                    getRule v-                      >>= \case-                        Literal (Value (VUInt v') _) -> pure [fromIntegral v']-                        somethingElse ->-                          error $-                            "Malformed value in KV in choice in .bits: "-                              <> show somethingElse-                  Range ff tt incl -> getIndicesOfRange ff tt incl-                  Enum g -> getIndicesOfEnum g-                  somethingElse ->-                    error $-                      "Malformed alternative in choice in .bits: "-                        <> show somethingElse-              )-      )-      nodes--getIndicesOfRange :: MonadReader CDDL m => Rule -> Rule -> RangeBound -> m [Word64]-getIndicesOfRange ff tt incl =-  ((,) <$> getRule ff <*> getRule tt) >>= \case-    (Literal (Value (VUInt ff') _), Literal (Value (VUInt tt') _)) ->-      pure $-        [ff' .. tt'] & case incl of-          ClOpen -> init-          Closed -> id-    somethingElse -> error $ "Malformed range in .bits: " <> show somethingElse--getIndicesOfEnum :: MonadReader CDDL m => Rule -> m [Word64]-getIndicesOfEnum g =-  getRule g >>= \case-    Group g' -> getIndicesOfChoice (fromJust $ NE.nonEmpty g')-    somethingElse -> error $ "Malformed enum in .bits: " <> show somethingElse------------------------------------------------------------------------------------- Resolving rules from the CDDL spec--resolveIfRef :: CDDL -> Rule -> ResolvedRule-resolveIfRef _ (MIt aa) = aa-resolveIfRef ct@(CTreeRoot cddl) (MRuleRef n) = do-  case Map.lookup n cddl of-    Nothing -> error $ "Unbound reference: " <> show n-    Just val -> resolveIfRef ct $ runIdentity val--getRule :: MonadReader CDDL m => Rule -> m ResolvedRule-getRule rule = asks (`resolveIfRef` rule)------------------------------------------------------------------------------------- Utils--replaceRule :: CDDLResult -> Rule -> CDDLResult-replaceRule (ChoiceFail _ a b) r = ChoiceFail r a b-replaceRule (ListExpansionFail _ a b) r = ListExpansionFail r a b-replaceRule (MapExpansionFail _ a b) r = MapExpansionFail r a b-replaceRule (InvalidTagged _ a) r = InvalidTagged r a-replaceRule InvalidRule {} r = InvalidRule r-replaceRule (InvalidControl _ a) r = InvalidControl r a-replaceRule UnapplicableRule {} r = UnapplicableRule r-replaceRule Valid {} r = Valid r--ifM :: Monad m => m Bool -> m a -> m a -> m a-ifM b t f = do b' <- b; if b' then t else f+{-# LANGUAGE TypeData #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ViewPatterns #-}++module Codec.CBOR.Cuddle.CBOR.Validator (+  validateCBOR,+  CDDLResult (..),+  CBORTermResult (..),+  ValidatorStage,+) where++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 (MonoReferenced, XXCTree (..))+import Codec.CBOR.Cuddle.IndexMappable (IndexMappable (..))+import Codec.CBOR.Read+import Codec.CBOR.Term+import Data.Bits hiding (And)+import Data.ByteString qualified as BS+import Data.ByteString.Lazy qualified as BSL+import Data.IntSet qualified as IS+import Data.List.NonEmpty qualified as NE+import Data.Map.Strict qualified as Map+import Data.Maybe+import Data.Text qualified as T+import Data.Text.Lazy qualified as TL+import Data.Word+import Debug.Trace (trace, traceShow)+import GHC.Float+import GHC.Stack (HasCallStack)+import Text.Regex.TDFA++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+  { ctrTerm :: Term+  , ctrResult :: CDDLResult+  }+  deriving (Show)++data CDDLResult+  = -- | The rule was valid+    Valid Rule+  | -- | All alternatives failed+    ChoiceFail+      -- | Rule we are trying+      Rule+      -- | The alternatives that arise from said rule+      (NE.NonEmpty Rule)+      -- | For each alternative, the result+      (NE.NonEmpty (Rule, CDDLResult))+  | -- | All expansions failed+    --+    -- An expansion is: Given a CBOR @TList@ of @N@ elements, we will expand the+    -- rules in a list spec to match the number of items in the list.+    ListExpansionFail+      -- | Rule we are trying+      Rule+      -- | List of expansions of rules+      [[Rule]]+      -- | For each expansion, for each of the rules in the expansion, the result+      [[(Rule, CBORTermResult)]]+  | -- | All expansions failed+    --+    -- An expansion is: Given a CBOR @TMap@ of @N@ elements, we will expand the+    -- rules in a map spec to match the number of items in the map.+    MapExpansionFail+      -- | Rule we are trying+      Rule+      -- | List of expansions+      [[Rule]]+      -- | A list of matched items @(key, value, rule)@ and the unmatched item+      [([AMatchedItem], ANonMatchedItem)]+  | -- | The rule was valid but the control failed+    InvalidControl+      -- | Control we are trying+      Rule+      -- | If it is a .cbor, the result of the underlying validation+      (Maybe CBORTermResult)+  | InvalidRule Rule+  | -- | A tagged was invalid+    InvalidTagged+      -- | Rule we are trying+      Rule+      -- | Either the tag is wrong, or the contents are wrong+      (Either Word64 CBORTermResult)+  | -- | The rule we are trying is not applicable to the CBOR term+    UnapplicableRule+      -- | Extra information+      String+      -- | Rule we are trying+      Rule+  deriving (Show)++data ANonMatchedItem = ANonMatchedItem+  { anmiKey :: Term+  , anmiValue :: Term+  , anmiResults :: [Either (Rule, CDDLResult) (Rule, CDDLResult, CDDLResult)]+  -- ^ For all the tried rules, either the key failed or the key succeeded and+  -- the value failed+  }+  deriving (Show)++data AMatchedItem = AMatchedItem+  { amiKey :: Term+  , amiValue :: Term+  , amiRule :: Rule+  }+  deriving (Show)++--------------------------------------------------------------------------------+-- Main entry point++validateCBOR :: BS.ByteString -> Name -> CDDL -> CBORTermResult+validateCBOR bs rule cddl@(CTreeRoot tree) =+  case deserialiseFromBytes decodeTerm (BSL.fromStrict bs) of+    Left e -> error $ show e+    Right (rest, term)+      | BSL.null rest -> validateTerm cddl term (tree Map.! rule)+      | otherwise -> error $ "Leftover bytes in CBOR" <> show rest++--------------------------------------------------------------------------------+-- Terms++-- | Core function that validates a CBOR term to a particular rule of the CDDL+-- spec+validateTerm :: CDDL -> Term -> Rule -> CBORTermResult+validateTerm cddl term rule =+  CBORTermResult term $ case term of+    TInt i -> validateInteger cddl (fromIntegral i) rRule+    TInteger i -> validateInteger cddl i rRule+    TBytes b -> validateBytes cddl b rRule+    TBytesI b -> validateBytes cddl (BSL.toStrict b) rRule+    TString s -> validateText cddl s rRule+    TStringI s -> validateText cddl (TL.toStrict s) rRule+    TList ts -> validateList cddl ts rRule+    TListI ts -> validateList cddl ts rRule+    TMap ts -> validateMap cddl ts rRule+    TMapI ts -> validateMap cddl ts rRule+    TTagged w t -> validateTagged cddl w t rRule+    TBool b -> validateBool cddl b rRule+    TNull -> validateNull cddl rRule+    TSimple s -> validateSimple cddl s rRule+    THalf h -> validateHalf cddl h rRule+    TFloat h -> validateFloat cddl h rRule+    TDouble d -> validateDouble cddl d rRule+  where+    rRule = resolveIfRef cddl rule++--------------------------------------------------------------------------------+-- Ints and integers++-- | Validation of an Int or Integer. CBOR categorizes every integral in `TInt`+-- or `TInteger` but it can be the case that we are decoding something that is+-- expected to be a `Word64` even if we get a `TInt`.+--+-- > ghci> encodeWord64 15+-- > [TkInt 15]+-- > ghci> encodeWord64 maxBound+-- > [TkInteger 18446744073709551615]+--+-- For this reason, we cannot assume that bounds or literals are going to be+-- Ints, so we convert everything to Integer.+validateInteger :: HasCallStack => CDDL -> Integer -> Rule -> CDDLResult+validateInteger cddl i rule =+  case resolveIfRef cddl rule of+    -- echo "C24101" | xxd -r -p - example.cbor+    -- echo "foo = int" > a.cddl+    -- cddl a.cddl validate example.cbor+    --+    -- but+    --+    -- echo "C249010000000000000000"| xxd -r -p - example.cbor+    -- echo "foo = int" > a.cddl+    -- cddl a.cddl validate example.cbor+    --+    -- and they are both bigints?++    -- a = any+    Postlude PTAny -> Valid rule+    -- a = int+    Postlude PTInt -> Valid rule+    -- a = uint+    Postlude PTUInt -> check (i >= 0) rule+    -- a = nint+    Postlude PTNInt -> check (i <= 0) rule+    -- a = x+    Literal (Value (VUInt i') _) -> check (i == fromIntegral i') rule+    -- a = -x+    Literal (Value (VNInt i') _) -> check (-i == fromIntegral i') rule+    -- a = <big number>+    Literal (Value (VBignum i') _) -> check (i == i') rule+    -- a = foo .ctrl bar+    Control op tgt ctrl -> ctrlDispatch (validateInteger cddl i) op tgt ctrl (controlInteger cddl i) rule+    -- a = foo / bar+    Choice opts -> validateChoice (validateInteger cddl i) opts rule+    -- a = x..y+    Range low high bound ->+      check+        ( case (resolveIfRef cddl low, resolveIfRef cddl high) of+            (Literal (Value (VUInt (fromIntegral -> n)) _), Literal (Value (VUInt (fromIntegral -> m)) _)) -> n <= i && range bound i m+            (Literal (Value (VNInt (fromIntegral -> n)) _), Literal (Value (VUInt (fromIntegral -> m)) _)) -> -n <= i && range bound i m+            (Literal (Value (VNInt (fromIntegral -> n)) _), Literal (Value (VNInt (fromIntegral -> m)) _)) -> -n <= i && range bound i (-m)+            (Literal (Value VUInt {} _), Literal (Value VNInt {} _)) -> False+            (Literal (Value (VBignum n) _), Literal (Value (VUInt (fromIntegral -> m)) _)) -> n <= i && range bound i m+            (Literal (Value (VBignum n) _), Literal (Value (VNInt (fromIntegral -> m)) _)) -> n <= i && range bound i (-m)+            (Literal (Value (VUInt (fromIntegral -> n)) _), Literal (Value (VBignum m) _)) -> n <= i && range bound i m+            (Literal (Value (VNInt (fromIntegral -> n)) _), Literal (Value (VBignum m) _)) -> (-n) <= i && range bound i m+            x -> error $ "Unable to validate range: " <> show x+        )+        rule+    -- a = &(x, y, z)+    Enum g ->+      case resolveIfRef cddl g of+        Group g' -> replaceRule (validateInteger cddl i (Choice (NE.fromList g'))) rule+        _ -> error "Not yet implemented"+    -- a = x: y+    -- Note KV cannot appear on its own, but we will use this when validating+    -- lists.+    KV _ v _ -> replaceRule (validateInteger cddl i v) rule+    Tag 2 x -> validateBigInt x+    Tag 3 x -> validateBigInt x+    _ -> UnapplicableRule "validateInteger" rule+  where+    validateBigInt x = case resolveIfRef cddl x of+      Postlude PTBytes -> Valid rule+      Control op tgt@(Postlude PTBytes) ctrl ->+        ctrlDispatch (validateBytes cddl bs) op tgt ctrl (controlBytes cddl bs) rule+        where+          -- TODO figure out a way to turn Integer into bytes or figure out why+          -- tagged bigints are decoded as integers in the first place+          bs = mempty+      e -> error $ "Not yet implemented" <> show e++-- | Controls for an Integer+controlInteger ::+  HasCallStack => CDDL -> Integer -> CtlOp -> Rule -> Either (Maybe CBORTermResult) ()+controlInteger cddl i Size ctrl =+  case resolveIfRef cddl ctrl of+    Literal (Value (VUInt sz) _) ->+      boolCtrl $ 0 <= i && i < 256 ^ sz+    _ -> error "Not yet implemented"+controlInteger cddl i Bits ctrl = do+  let+    indices = case resolveIfRef cddl ctrl of+      Literal (Value (VUInt i') _) -> [i']+      Choice nodes -> getIndicesOfChoice cddl nodes+      Range ff tt incl -> getIndicesOfRange cddl ff tt incl+      Enum g -> getIndicesOfEnum cddl g+      _ -> error "Not yet implemented"+  boolCtrl $ go (IS.fromList (map fromIntegral indices)) i 0+  where+    go _ 0 _ = True+    go indices n idx =+      let bitSet = testBit n 0+          allowed = not bitSet || IS.member idx indices+       in (allowed && go indices (shiftR n 1) (idx + 1))+controlInteger cddl i Lt ctrl =+  boolCtrl $ case resolveIfRef cddl ctrl of+    Literal (Value (VUInt i') _) -> i < fromIntegral i'+    Literal (Value (VNInt i') _) -> i < -fromIntegral i'+    Literal (Value (VBignum i') _) -> i < i'+    _ -> error "Not yet implemented"+controlInteger cddl i Gt ctrl =+  boolCtrl $ case resolveIfRef cddl ctrl of+    Literal (Value (VUInt i') _) -> i > fromIntegral i'+    Literal (Value (VNInt i') _) -> i > -fromIntegral i'+    Literal (Value (VBignum i') _) -> i > i'+    _ -> error "Not yet implemented"+controlInteger cddl i Le ctrl =+  boolCtrl $ case resolveIfRef cddl ctrl of+    Literal (Value (VUInt i') _) -> i <= fromIntegral i'+    Literal (Value (VNInt i') _) -> i <= -fromIntegral i'+    Literal (Value (VBignum i') _) -> i <= i'+    _ -> error "Not yet implemented"+controlInteger cddl i Ge ctrl =+  boolCtrl $ case resolveIfRef cddl ctrl of+    Literal (Value (VUInt i') _) -> i >= fromIntegral i'+    Literal (Value (VNInt i') _) -> i >= -fromIntegral i'+    Literal (Value (VBignum i') _) -> i >= i'+    _ -> error "Not yet implemented"+controlInteger cddl i Eq ctrl =+  boolCtrl $ case resolveIfRef cddl ctrl of+    Literal (Value (VUInt i') _) -> i == fromIntegral i'+    Literal (Value (VNInt i') _) -> i == -fromIntegral i'+    Literal (Value (VBignum i') _) -> i == i'+    _ -> error "Not yet implemented"+controlInteger cddl i Ne ctrl =+  boolCtrl $ case resolveIfRef cddl ctrl of+    Literal (Value (VUInt i') _) -> i /= fromIntegral i'+    Literal (Value (VNInt i') _) -> i /= -fromIntegral i'+    Literal (Value (VBignum i') _) -> i /= i'+    _ -> error "Not yet implemented"+controlInteger _ _ _ _ = error "Not yet implemented"++--------------------------------------------------------------------------------+-- Floating point (Float16, Float32, Float64)+--+-- As opposed to Integral types, there seems to be no ambiguity when encoding+-- and decoding floating-point numbers.++-- | Validating a `Float16`+validateHalf :: HasCallStack => CDDL -> Float -> Rule -> CDDLResult+validateHalf cddl f rule =+  case resolveIfRef cddl rule of+    -- a = any+    Postlude PTAny -> Valid rule+    -- a = float16+    Postlude PTHalf -> Valid rule+    -- a = 0.5+    Literal (Value (VFloat16 f') _) -> check (f == f') rule+    -- a = foo / bar+    Choice opts -> validateChoice (validateHalf cddl f) opts rule+    -- a = foo .ctrl bar+    Control op tgt ctrl -> ctrlDispatch (validateHalf cddl f) op tgt ctrl (controlHalf cddl f) rule+    -- a = x..y+    Range low high bound ->+      check+        ( case (resolveIfRef cddl low, resolveIfRef cddl high) of+            (Literal (Value (VFloat16 n) _), Literal (Value (VFloat16 m) _)) -> n <= f && range bound f m+            _ -> error "Not yet implemented"+        )+        rule+    _ -> UnapplicableRule "validateHalf" rule++-- | Controls for `Float16`+controlHalf :: HasCallStack => CDDL -> Float -> CtlOp -> Rule -> Either (Maybe CBORTermResult) ()+controlHalf cddl f Eq ctrl =+  boolCtrl $ case resolveIfRef cddl ctrl of+    Literal (Value (VFloat16 f') _) -> f == f'+    _ -> error "Not yet implemented"+controlHalf cddl f Ne ctrl =+  boolCtrl $ case resolveIfRef cddl ctrl of+    Literal (Value (VFloat16 f') _) -> f /= f'+    _ -> error "Not yet implemented"+controlHalf _ _ _ _ = error "Not yet implemented"++-- | Validating a `Float32`+validateFloat :: HasCallStack => CDDL -> Float -> Rule -> CDDLResult+validateFloat cddl f rule =+  ($ rule) $ do+    case resolveIfRef cddl rule of+      -- a = any+      Postlude PTAny -> Valid+      -- a = float32+      Postlude PTFloat -> Valid+      -- a = 0.000000005+      -- TODO: it is unclear if smaller floats should also validate+      Literal (Value (VFloat32 f') _) -> check $ f == f'+      -- a = foo / bar+      Choice opts -> validateChoice (validateFloat cddl f) opts+      -- a = foo .ctrl bar+      Control op tgt ctrl -> ctrlDispatch (validateFloat cddl f) op tgt ctrl (controlFloat cddl f)+      -- a = x..y+      -- TODO it is unclear if this should mix floating point types too+      Range low high bound ->+        check $ case (resolveIfRef cddl low, resolveIfRef cddl high) of+          (Literal (Value (VFloat16 n) _), Literal (Value (VFloat16 m) _)) -> n <= f && range bound f m+          (Literal (Value (VFloat32 n) _), Literal (Value (VFloat32 m) _)) -> n <= f && range bound f m+          _ -> error "Not yet implemented"+      _ -> UnapplicableRule "validateFloat"++-- | Controls for `Float32`+controlFloat :: HasCallStack => CDDL -> Float -> CtlOp -> Rule -> Either (Maybe CBORTermResult) ()+controlFloat cddl f Eq ctrl =+  boolCtrl $ case resolveIfRef cddl ctrl of+    Literal (Value (VFloat16 f') _) -> f == f'+    Literal (Value (VFloat32 f') _) -> f == f'+    _ -> error "Not yet implemented"+controlFloat cddl f Ne ctrl =+  boolCtrl $ case resolveIfRef cddl ctrl of+    Literal (Value (VFloat16 f') _) -> f /= f'+    Literal (Value (VFloat32 f') _) -> f /= f'+    _ -> error "Not yet implemented"+controlFloat _ _ _ _ = error "Not yet implemented"++-- | Validating a `Float64`+validateDouble :: HasCallStack => CDDL -> Double -> Rule -> CDDLResult+validateDouble cddl f rule =+  ($ rule) $ do+    case resolveIfRef cddl rule of+      -- a = any+      Postlude PTAny -> Valid+      -- a = float64+      Postlude PTDouble -> Valid+      -- a = 0.0000000000000000000000000000000000000000000005+      -- TODO: it is unclear if smaller floats should also validate+      Literal (Value (VFloat64 f') _) -> check $ f == f'+      -- a = foo / bar+      Choice opts -> validateChoice (validateDouble cddl f) opts+      -- a = foo .ctrl bar+      Control op tgt ctrl -> ctrlDispatch (validateDouble cddl f) op tgt ctrl (controlDouble cddl f)+      -- a = x..y+      -- TODO it is unclear if this should mix floating point types too+      Range low high bound ->+        check $ case (resolveIfRef cddl low, resolveIfRef cddl high) of+          (Literal (Value (VFloat16 (float2Double -> n)) _), Literal (Value (VFloat16 (float2Double -> m)) _)) -> n <= f && range bound f m+          (Literal (Value (VFloat32 (float2Double -> n)) _), Literal (Value (VFloat32 (float2Double -> m)) _)) -> n <= f && range bound f m+          (Literal (Value (VFloat64 n) _), Literal (Value (VFloat64 m) _)) -> n <= f && range bound f m+          _ -> error "Not yet implemented"+      _ -> UnapplicableRule "validateDouble"++-- | Controls for `Float64`+controlDouble :: HasCallStack => CDDL -> Double -> CtlOp -> Rule -> Either (Maybe CBORTermResult) ()+controlDouble cddl f Eq ctrl =+  boolCtrl $ case resolveIfRef cddl ctrl of+    Literal (Value (VFloat16 f') _) -> f == float2Double f'+    Literal (Value (VFloat32 f') _) -> f == float2Double f'+    Literal (Value (VFloat64 f') _) -> f == f'+    _ -> error "Not yet implemented"+controlDouble cddl f Ne ctrl =+  boolCtrl $ case resolveIfRef cddl ctrl of+    Literal (Value (VFloat16 f') _) -> f /= float2Double f'+    Literal (Value (VFloat32 f') _) -> f /= float2Double f'+    Literal (Value (VFloat64 f') _) -> f /= f'+    _ -> error "Not yet implemented"+controlDouble _ _ _ _ = error "Not yet implmented"++--------------------------------------------------------------------------------+-- Bool++-- | Validating a boolean+validateBool :: CDDL -> Bool -> Rule -> CDDLResult+validateBool cddl b rule =+  ($ rule) $ do+    case resolveIfRef cddl rule of+      -- a = any+      Postlude PTAny -> Valid+      -- a = bool+      Postlude PTBool -> Valid+      -- a = true+      Literal (Value (VBool b') _) -> check $ b == b'+      -- a = foo .ctrl bar+      Control op tgt ctrl -> ctrlDispatch (validateBool cddl b) op tgt ctrl (controlBool cddl b)+      -- a = foo / bar+      Choice opts -> validateChoice (validateBool cddl b) opts+      _ -> UnapplicableRule "validateBool"++-- | Controls for `Bool`+controlBool :: HasCallStack => CDDL -> Bool -> CtlOp -> Rule -> Either (Maybe CBORTermResult) ()+controlBool cddl b Eq ctrl =+  boolCtrl $ case resolveIfRef cddl ctrl of+    Literal (Value (VBool b') _) -> b == b'+    _ -> error "Not yet implemented"+controlBool cddl b Ne ctrl =+  boolCtrl $ case resolveIfRef cddl ctrl of+    Literal (Value (VBool b') _) -> b /= b'+    _ -> error "Not yet implemented"+controlBool _ _ _ _ = error "Not yet implemented"++--------------------------------------------------------------------------------+-- Simple++-- | Validating a `TSimple`. It is unclear if this is used for anything else than undefined.+validateSimple :: CDDL -> Word8 -> Rule -> CDDLResult+validateSimple cddl 23 rule =+  do+    case resolveIfRef cddl rule of+      -- a = any+      Postlude PTAny -> Valid rule+      -- a = undefined+      Postlude PTUndefined -> Valid rule+      -- a = foo / bar+      Choice opts -> validateChoice (validateSimple cddl 23) opts rule+      _ -> UnapplicableRule "validateSimple" rule+validateSimple _ n _ = error $ "Found simple different to 23! please report this somewhere! Found: " <> show n++--------------------------------------------------------------------------------+-- Null/nil++-- | Validating nil+validateNull :: CDDL -> Rule -> CDDLResult+validateNull cddl rule =+  case resolveIfRef cddl rule of+    -- a = any+    Postlude PTAny -> Valid rule+    -- a = nil+    Postlude PTNil -> Valid rule+    Choice opts -> validateChoice (validateNull cddl) opts rule+    _ -> UnapplicableRule "validateNull" rule++--------------------------------------------------------------------------------+-- Bytes++-- | Validating a byte sequence+validateBytes :: CDDL -> BS.ByteString -> Rule -> CDDLResult+validateBytes cddl bs rule =+  case resolveIfRef cddl rule of+    -- a = any+    Postlude PTAny -> Valid rule+    -- a = bytes+    Postlude PTBytes -> Valid rule+    -- a = h'123456'+    Literal (Value (VBytes bs') _) -> check (bs == bs') rule+    -- a = foo .ctrl bar+    Control op tgt ctrl -> ctrlDispatch (validateBytes cddl bs) op tgt ctrl (controlBytes cddl bs) rule+    -- a = foo / bar+    Choice opts -> validateChoice (validateBytes cddl bs) opts rule+    _ -> UnapplicableRule "validateBytes" rule++-- | Controls for byte strings+controlBytes ::+  HasCallStack =>+  CDDL ->+  BS.ByteString ->+  CtlOp ->+  Rule ->+  Either (Maybe CBORTermResult) ()+controlBytes cddl bs Size ctrl =+  case resolveIfRef cddl ctrl of+    Literal (Value (VUInt (fromIntegral -> sz)) _) -> boolCtrl $ BS.length bs == sz+    Range low high bound ->+      let i = BS.length bs+       in boolCtrl $ case (resolveIfRef cddl low, resolveIfRef cddl high) of+            (Literal (Value (VUInt (fromIntegral -> n)) _), Literal (Value (VUInt (fromIntegral -> m)) _)) -> n <= i && range bound i m+            (Literal (Value (VNInt (fromIntegral -> n)) _), Literal (Value (VUInt (fromIntegral -> m)) _)) -> -n <= i && range bound i m+            (Literal (Value (VNInt (fromIntegral -> n)) _), Literal (Value (VNInt (fromIntegral -> m)) _)) -> -n <= i && range bound i (-m)+            (Literal (Value VUInt {} _), Literal (Value VNInt {} _)) -> False+            _ -> error "Not yet implemented"+    _ -> error "Not yet implemented"+controlBytes cddl bs Bits ctrl = do+  let+    indices =+      case resolveIfRef cddl ctrl of+        Literal (Value (VUInt i') _) -> [i']+        Choice nodes -> getIndicesOfChoice cddl nodes+        Range ff tt incl -> getIndicesOfRange cddl ff tt incl+        Enum g -> getIndicesOfEnum cddl g+        _ -> error "Not yet implemented"+  boolCtrl $ bitsControlCheck (map fromIntegral indices)+  where+    bitsControlCheck :: [Int] -> Bool+    bitsControlCheck allowedBits =+      let allowedSet = IS.fromList allowedBits+          totalBits = BS.length bs * 8+          isAllowedBit n =+            let byteIndex = n `shiftR` 3+                bitIndex = n .&. 7+             in case BS.indexMaybe bs byteIndex of+                  Just byte -> not (testBit byte bitIndex) || IS.member n allowedSet+                  Nothing -> True+       in all isAllowedBit [0 .. totalBits - 1]+controlBytes cddl bs Cbor ctrl =+  case deserialiseFromBytes decodeTerm (BSL.fromStrict bs) of+    Right (BSL.null -> True, term) ->+      case validateTerm cddl term ctrl of+        CBORTermResult _ (Valid _) -> Right ()+        err -> Left $ Just err+    _ -> error "Not yet implemented"+controlBytes cddl bs Cborseq ctrl =+  case deserialiseFromBytes decodeTerm (BSL.fromStrict (BS.snoc (BS.cons 0x9f bs) 0xff)) of+    Right (BSL.null -> True, TListI terms) ->+      case validateTerm cddl (TList terms) (Array [Occur ctrl OIZeroOrMore]) of+        CBORTermResult _ (Valid _) -> Right ()+        CBORTermResult _ err -> error $ show err+    _ -> error "Not yet implemented"+controlBytes _ _ _ _ = error "Not yet implmented"++--------------------------------------------------------------------------------+-- Text++-- | Validating text strings+validateText :: CDDL -> T.Text -> Rule -> CDDLResult+validateText cddl txt rule =+  case resolveIfRef cddl rule of+    -- a = any+    Postlude PTAny -> Valid rule+    -- a = text+    Postlude PTText -> Valid rule+    -- a = "foo"+    Literal (Value (VText txt') _) -> check (txt == txt') rule+    -- a = foo .ctrl bar+    Control op tgt ctrl -> ctrlDispatch (validateText cddl txt) op tgt ctrl (controlText cddl txt) rule+    -- a = foo / bar+    Choice opts -> validateChoice (validateText cddl txt) opts rule+    _ -> UnapplicableRule "validateText" rule++-- | Controls for text strings+controlText :: HasCallStack => CDDL -> T.Text -> CtlOp -> Rule -> Either (Maybe CBORTermResult) ()+controlText cddl bs Size ctrl =+  case resolveIfRef cddl ctrl of+    Literal (Value (VUInt (fromIntegral -> sz)) _) -> boolCtrl $ T.length bs == sz+    Range ff tt bound ->+      boolCtrl $ case (resolveIfRef cddl ff, resolveIfRef cddl tt) of+        (Literal (Value (VUInt (fromIntegral -> n)) _), Literal (Value (VUInt (fromIntegral -> m)) _)) -> n <= T.length bs && range bound (T.length bs) m+        (Literal (Value (VNInt (fromIntegral -> n)) _), Literal (Value (VUInt (fromIntegral -> m)) _)) -> -n <= T.length bs && range bound (T.length bs) m+        (Literal (Value (VNInt (fromIntegral -> n)) _), Literal (Value (VNInt (fromIntegral -> m)) _)) -> -n <= T.length bs && range bound (T.length bs) (-m)+        _ -> error "Not yet implemented"+    _ -> error "Not yet implemented"+controlText cddl s Regexp ctrl =+  boolCtrl $ case resolveIfRef cddl ctrl of+    Literal (Value (VText rxp) _) -> case s =~ rxp :: (T.Text, T.Text, T.Text) of+      ("", s', "") -> s == s'+      _ -> error "Not yet implemented"+    _ -> error "Not yet implemented"+controlText _ _ _ _ = error "Not yet implemented"++--------------------------------------------------------------------------------+-- Tagged values++-- | Validating a `TTagged`+validateTagged :: CDDL -> Word64 -> Term -> Rule -> CDDLResult+validateTagged cddl tag term rule =+  case resolveIfRef cddl rule of+    Postlude PTAny -> Valid rule+    Tag tag' rule' ->+      -- If the tag does not match, this is a direct fail+      if tag == tag'+        then case validateTerm cddl term rule' of+          CBORTermResult _ (Valid _) -> Valid rule+          err -> InvalidTagged rule (Right err)+        else InvalidTagged rule (Left tag)+    Choice opts -> validateChoice (validateTagged cddl tag term) opts rule+    _ -> UnapplicableRule "validateTagged" rule++-- --------------------------------------------------------------------------------+-- -- Lists++isWithinBoundsInclusive :: Ord a => a -> Maybe a -> Maybe a -> Bool+isWithinBoundsInclusive x lb ub = maybe True (x >=) lb && maybe True (x <=) ub++isOptional :: CTree i -> Bool+isOptional (Occur _ oi) = case oi of+  OIOptional -> True+  OIZeroOrMore -> True+  OIBounded lb ub -> isWithinBoundsInclusive 0 lb ub+  _ -> False+isOptional _ = False++decrementBounds :: Maybe Word64 -> Maybe Word64 -> OccurrenceIndicator+decrementBounds lb ub = OIBounded (clampedPred <$> lb) (clampedPred <$> ub)+  where+    clampedPred 0 = 0+    clampedPred x = pred x++validateList :: CDDL -> [Term] -> Rule -> CDDLResult+validateList cddl terms rule =+  case resolveIfRef cddl rule of+    Postlude PTAny -> Valid rule+    Array rules -> validate terms rules+    Choice opts -> validateChoice (validateList cddl terms) opts rule+    r -> UnapplicableRule "validateList" r+  where+    validate :: [Term] -> [CTree ValidatorStage] -> CDDLResult+    validate [] [] = Valid rule+    validate _ [] = ListExpansionFail rule [] []+    validate [] (r : rs)+      | isOptional r = validate [] rs+      | otherwise = UnapplicableRule "validateList" r+    validate (t : ts) (r : rs) = case r of+      Occur ct oi -> case oi of+        OIOptional+          | (Valid {}, leftover) <- validateTermInList (t : ts) ct+          , res@Valid {} <- validate leftover rs ->+              res+          | otherwise -> validate (t : ts) rs+        OIZeroOrMore+          | (Valid {}, leftover) <- validateTermInList (t : ts) ct+          , res@Valid {} <- validate leftover (r : rs) ->+              res+          | otherwise -> validate (t : ts) rs+        OIOneOrMore -> case validateTermInList (t : ts) ct of+          (Valid {}, leftover) -> validate leftover (Occur ct OIZeroOrMore : rs)+          (err, _) -> err+        OIBounded _ (Just ub) | ub < 0 -> trace ("out of bounds: " <> show ub) $ ListExpansionFail rule [] []+        OIBounded lb ub+          | (Valid {}, leftover) <- validateTermInList (t : ts) ct ->+              validate leftover (Occur ct (decrementBounds lb ub) : rs)+          | isWithinBoundsInclusive 0 lb ub ->+              validate (t : ts) rs+          | otherwise -> trace "foo" $ UnapplicableRule "validateList" r+      _ -> case validateTermInList (t : ts) (resolveIfRef cddl r) of+        (Valid {}, leftover) -> validate leftover rs+        (err, _) -> err++    validateTermInList ts (KV _ v _) = validateTermInList ts v+    validateTermInList ts (Group grp) = case grp of+      (resolveIfRef cddl -> g) : gs+        | (Valid {}, leftover) <- validateTermInList ts g -> validateTermInList leftover (Group gs)+        | otherwise -> (UnapplicableRule "validateTermInList group" g, ts)+      [] -> (Valid rule, ts)+    validateTermInList (t : ts) r =+      let CBORTermResult _ res = validateTerm cddl t r+       in (res, ts)+    validateTermInList [] g = (validate [] [g], [])++--------------------------------------------------------------------------------+-- Maps++validateMap :: CDDL -> [(Term, Term)] -> Rule -> CDDLResult+validateMap cddl terms rule =+  case resolveIfRef cddl rule of+    Postlude PTAny -> Valid rule+    Map rules -> validate [] terms rules+    Choice opts -> validateChoice (validateMap cddl terms) opts rule+    r -> UnapplicableRule "validateMap" r+  where+    validate :: [Rule] -> [(Term, Term)] -> [Rule] -> CDDLResult+    validate [] [] [] = Valid rule+    validate exhausted _ [] = trace (unlines $ show <$> exhausted) $ MapExpansionFail rule [] []+    validate [] [] (r : rs)+      | isOptional r = validate [] [] rs+      | otherwise = UnapplicableRule "validateMap" r+    validate exhausted ((k, v) : ts) (r : rs) = case r of+      Occur ct oi -> case oi of+        OIOptional+          | (Valid {}, leftover) <- validateKVInMap ((k, v) : ts) ct+          , res@Valid {} <- validate [] leftover (exhausted <> rs) ->+              res+          | otherwise -> validate (r : exhausted) ((k, v) : ts) rs+        OIZeroOrMore+          | (Valid {}, leftover) <- validateKVInMap ((k, v) : ts) ct+          , res@Valid {} <- validate [] leftover (r : exhausted <> rs) ->+              res+          | otherwise -> validate (r : exhausted) ((k, v) : ts) rs+        OIOneOrMore -> case validateKVInMap ((k, v) : ts) ct of+          (Valid {}, leftover) -> validate [] leftover (Occur ct OIZeroOrMore : exhausted <> rs)+          (err, _) -> err+        OIBounded _ (Just ub) | 0 > ub -> traceShow ub $ MapExpansionFail rule [] []+        OIBounded lb ub+          | (Valid {}, leftover) <- validateKVInMap ((k, v) : ts) ct+          , not (isWithinBoundsInclusive 0 lb ub) ->+              validate [] leftover (Occur ct (decrementBounds lb ub) : exhausted <> rs)+          | isWithinBoundsInclusive 0 lb ub && not (isValidTerm ((k, v) : ts) ct) ->+              validate (r : exhausted) ((k, v) : ts) rs+          | otherwise -> UnapplicableRule "validateMap" r+      _ -> case validateKVInMap ((k, v) : ts) r of+        (Valid {}, leftover) -> validate [] leftover (exhausted <> rs)+        (err, _) -> err+    validate _ _ _ = error "Impossible happened"++    validateKVInMap ((tk, tv) : ts) (KV k v _) = case (validateTerm cddl tk k, validateTerm cddl tv v) of+      (CBORTermResult _ Valid {}, CBORTermResult _ x@Valid {}) -> (x, ts)+      (CBORTermResult _ Valid {}, CBORTermResult _ err) -> (err, ts)+      (CBORTermResult _ err, _) -> (err, ts)+    validateKVInMap [] _ = error "No remaining KV pairs"+    validateKVInMap _ x = error $ "Unexpected value in map: " <> show x+    isValidTerm ts r = case validateKVInMap ts r of+      (Valid {}, _) -> True+      _ -> False++--------------------------------------------------------------------------------+-- Choices++validateChoice :: (Rule -> CDDLResult) -> NE.NonEmpty Rule -> Rule -> CDDLResult+validateChoice v rules = go rules+  where+    go :: NE.NonEmpty Rule -> Rule -> CDDLResult+    go (choice NE.:| xs) rule = do+      case v choice of+        Valid _ -> Valid rule+        err -> case NE.nonEmpty xs of+          Nothing -> ChoiceFail rule rules ((choice, err) NE.:| [])+          Just choices ->+            case go choices rule of+              Valid _ -> Valid rule+              ChoiceFail _ _ errors -> ChoiceFail rule rules ((choice, err) NE.<| errors)+              _ -> error "Not yet implemented"++--------------------------------------------------------------------------------+-- Control helpers++-- | Validate both rules+ctrlAnd :: (Rule -> CDDLResult) -> Rule -> Rule -> Rule -> CDDLResult+ctrlAnd v tgt ctrl rule =+  case v tgt of+    Valid _ ->+      case v ctrl of+        Valid _ -> Valid rule+        _ -> InvalidControl rule Nothing+    _ -> InvalidRule rule++-- | Dispatch to the appropriate control+ctrlDispatch ::+  (Rule -> CDDLResult) ->+  CtlOp ->+  Rule ->+  Rule ->+  (CtlOp -> Rule -> Either (Maybe CBORTermResult) ()) ->+  Rule ->+  CDDLResult+ctrlDispatch v And tgt ctrl _ rule = ctrlAnd v tgt ctrl rule+ctrlDispatch v Within tgt ctrl _ rule = ctrlAnd v tgt ctrl rule+ctrlDispatch v op tgt ctrl vctrl rule =+  case v tgt of+    Valid _ ->+      case vctrl op ctrl of+        Left err -> InvalidControl rule err+        Right () -> Valid rule+    _ -> InvalidRule rule++-- | A boolean control+boolCtrl :: Bool -> Either (Maybe CBORTermResult) ()+boolCtrl c = if c then Right () else Left Nothing++--------------------------------------------------------------------------------+-- Bits control++getIndicesOfChoice :: CDDL -> NE.NonEmpty Rule -> [Word64]+getIndicesOfChoice cddl =+  concatMap $ \case+    Literal (Value (VUInt v) _) -> [fromIntegral v]+    KV _ v _ ->+      case resolveIfRef cddl v of+        Literal (Value (VUInt v') _) -> [fromIntegral v']+        somethingElse ->+          error $+            "Malformed value in KV in choice in .bits: "+              <> show somethingElse+    Range ff tt incl -> getIndicesOfRange cddl ff tt incl+    Enum g -> getIndicesOfEnum cddl g+    somethingElse ->+      error $+        "Malformed alternative in choice in .bits: "+          <> show somethingElse++getIndicesOfRange :: CDDL -> Rule -> Rule -> RangeBound -> [Word64]+getIndicesOfRange cddl ff tt incl =+  case (resolveIfRef cddl ff, resolveIfRef cddl tt) of+    (Literal (Value (VUInt ff') _), Literal (Value (VUInt tt') _)) ->+      case incl of+        ClOpen -> init rng+        Closed -> rng+      where+        rng = [ff' .. tt']+    somethingElse -> error $ "Malformed range in .bits: " <> show somethingElse++getIndicesOfEnum :: CDDL -> Rule -> [Word64]+getIndicesOfEnum cddl g =+  case resolveIfRef cddl g of+    Group g' -> getIndicesOfChoice cddl (fromJust $ NE.nonEmpty g')+    somethingElse -> error $ "Malformed enum in .bits: " <> show somethingElse++--------------------------------------------------------------------------------+-- Resolving rules from the CDDL spec++resolveIfRef :: CDDL -> Rule -> Rule+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+resolveIfRef _ r = r++--------------------------------------------------------------------------------+-- Utils++replaceRule :: CDDLResult -> Rule -> CDDLResult+replaceRule (ChoiceFail _ a b) r = ChoiceFail r a b+replaceRule (ListExpansionFail _ a b) r = ListExpansionFail r a b+replaceRule (MapExpansionFail _ a b) r = MapExpansionFail r a b+replaceRule (InvalidTagged _ a) r = InvalidTagged r a+replaceRule InvalidRule {} r = InvalidRule r+replaceRule (InvalidControl _ a) r = InvalidControl r a+replaceRule (UnapplicableRule m _) r = UnapplicableRule m r+replaceRule Valid {} r = Valid r  check :: Bool -> Rule -> CDDLResult check c = if c then Valid else InvalidRule

@@ -1,5 +1,9 @@+{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE OverloadedLabels #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}  -- | This module defined the data structure of CDDL as specified in --   https://datatracker.ietf.org/doc/rfc8610/@@ -7,16 +11,17 @@   CDDL (..),   sortCDDL,   cddlTopLevel,-  cddlRules,-  fromRules,   fromRule,+  fromRules,+  appendRules,   TopLevel (..),   Name (..),   Rule (..),   TypeOrGroup (..),   Assign (..),   GenericArg (..),-  GenericParam (..),+  GenericParameters (..),+  GenericParameter (..),   Type0 (..),   Type1 (..),   Type2 (..),@@ -33,67 +38,101 @@   GrpChoice (..),   unwrap,   compareRuleName,+  HasName (..),+  -- Extension+  ForAllExtensions,+  XCddl,+  XTerm,+  XRule,+  XXTopLevel,+  XXType2, ) where  import Codec.CBOR.Cuddle.CDDL.CtlOp (CtlOp) import Codec.CBOR.Cuddle.Comments (CollectComments (..), Comment, HasComment (..)) import Data.ByteString qualified as B import Data.Default.Class (Default (..))-import Data.Function (on, (&))+import Data.Function (on) import Data.Hashable (Hashable)-import Data.List.NonEmpty (NonEmpty (..))+import Data.List.NonEmpty (NonEmpty (..), prependList) import Data.List.NonEmpty qualified as NE+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)-import Optics.Core ((%), (.~))-import Optics.Getter (view)-import Optics.Lens (lens)+import Optics.Core ((%), (%~), (&)) +data family XXTopLevel i++data family XCddl i++data family XTerm i++data family XRule i++data family XXType2 i++type ForAllExtensions i (c :: Type -> Constraint) =+  ( c (XCddl i)+  , c (XTerm i)+  , c (XRule i)+  , c (XXTopLevel i)+  , c (XXType2 i)+  )+ -- | 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)+data CDDL i = CDDL+  { rootDefinition :: Rule i+  , topLevelDefinitions :: [TopLevel i]+  , cddlExt :: [XXTopLevel i]+  -- ^ This extension is used for comments that appear before the root definition+  }+  deriving (Generic) +deriving instance ForAllExtensions i Eq => Eq (CDDL i)++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+ -- | Sort the CDDL Rules on the basis of their names--- Top level comments will be removed!-sortCDDL :: CDDL -> CDDL-sortCDDL = fromRules . NE.sortBy (compare `on` ruleName) . cddlRules+sortCDDL :: CDDL i -> NonEmpty (Rule i)+sortCDDL (CDDL r rs _) = NE.sortBy (compare `on` unName . ruleName) $ r :| mapMaybe ruleTopLevel rs -cddlTopLevel :: CDDL -> NonEmpty TopLevel-cddlTopLevel (CDDL cmts cHead cTail) =-  prependList (TopLevelComment <$> cmts) $ TopLevelRule cHead :| cTail-  where-    prependList [] l = l-    prependList (x : xs) (y :| ys) = prependList xs $ x :| (y : ys)+fromRules :: Monoid (XCddl i) => NonEmpty (Rule i) -> CDDL i+fromRules (x :| xs) = CDDL x (TopLevelRule <$> xs) mempty -cddlRules :: CDDL -> NonEmpty Rule-cddlRules (CDDL _ x tls) = x :| concatMap getRule tls-  where-    getRule (TopLevelRule r) = [r]-    getRule _ = mempty+fromRule :: Monoid (XCddl i) => Rule i -> CDDL i+fromRule x = CDDL x [] mempty -fromRules :: NonEmpty Rule -> CDDL-fromRules (x :| xs) = CDDL [] x $ TopLevelRule <$> xs+appendRules :: CDDL i -> [Rule i] -> CDDL i+appendRules cddl rs = cddl & #topLevelDefinitions %~ (<> fmap TopLevelRule rs) -fromRule :: Rule -> CDDL-fromRule x = CDDL [] x []+cddlTopLevel :: CDDL i -> NonEmpty (TopLevel i)+cddlTopLevel (CDDL r tls e) = prependList (XXTopLevel <$> e) $ TopLevelRule r :| tls -instance Semigroup CDDL where-  CDDL aComments aHead aTail <> CDDL bComments bHead bTail =-    CDDL aComments aHead $-      aTail <> fmap TopLevelComment bComments <> (TopLevelRule bHead : bTail)+data TopLevel i+  = TopLevelRule (Rule i)+  | XXTopLevel (XXTopLevel i)+  deriving (Generic) -data TopLevel-  = TopLevelRule Rule-  | TopLevelComment Comment-  deriving (Eq, Generic, Show, ToExpr)+deriving instance ForAllExtensions i Eq => Eq (TopLevel i) +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@@ -117,24 +156,27 @@ -- --  *  Rule names (types or groups) do not appear in the actual CBOR --      encoding, but names used as "barewords" in member keys do.-data Name = Name-  { name :: T.Text-  , nameComment :: Comment-  }-  deriving (Eq, Generic, Ord, Show)-  deriving anyclass (ToExpr)+newtype Name = Name {unName :: T.Text}+  deriving (Generic)+  deriving (Eq, Ord, Show)+  deriving newtype (Semigroup, Monoid) -instance IsString Name where-  fromString x = Name (T.pack x) mempty+deriving anyclass instance ToExpr Name -instance HasComment Name where-  commentL = lens nameComment (\x y -> x {nameComment = y})+instance IsString Name where+  fromString = Name . T.pack  instance CollectComments Name where-  collectComments (Name _ c) = [c]+  collectComments _ = []  instance Hashable Name +class HasName a where+  getName :: a -> Name++instance HasName Name where+  getName = id+ -- | --   assignt = "=" / "/=" --   assigng = "=" / "//="@@ -168,18 +210,45 @@ -- --   Generic rules can be used for establishing names for both types and --   groups.-newtype GenericParam = GenericParam (NE.NonEmpty Name)-  deriving (Eq, Generic, Show)+newtype GenericParameters i = GenericParameters (NE.NonEmpty (GenericParameter i))+  deriving (Generic)   deriving newtype (Semigroup)-  deriving anyclass (ToExpr) -newtype GenericArg = GenericArg (NE.NonEmpty Type1)-  deriving (Eq, Generic, Show)+deriving instance Eq (XTerm i) => Eq (GenericParameters i)++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+  }+  deriving (Generic)++deriving instance Eq (XTerm i) => Eq (GenericParameter i)++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+  commentL = #gpExt % commentL++newtype GenericArg i = GenericArg (NE.NonEmpty (Type1 i))+  deriving (Generic)   deriving newtype (Semigroup)-  deriving anyclass (ToExpr) -instance CollectComments GenericArg+deriving instance ForAllExtensions i Eq => Eq (GenericArg i) +deriving instance ForAllExtensions i Show => Show (GenericArg i)++deriving anyclass instance ForAllExtensions i ToExpr => ToExpr (GenericArg i)++instance ForAllExtensions i CollectComments => CollectComments (GenericArg i)+ -- | --  rule = typename [genericparm] S assignt S type --        / groupname [genericparm] S assigng S grpent@@ -203,20 +272,25 @@ --   clear immediately either whether "b" stands for a group or a type -- --   this semantic processing may need to span several levels of rule --   definitions before a determination can be made.)-data Rule = Rule+data Rule i = Rule   { ruleName :: Name-  , ruleGenParam :: Maybe GenericParam+  , ruleGenParam :: Maybe (GenericParameters i)   , ruleAssign :: Assign-  , ruleTerm :: TypeOrGroup-  , ruleComment :: Comment+  , ruleTerm :: TypeOrGroup i+  , ruleExt :: XRule i   }-  deriving (Eq, Generic, Show)-  deriving anyclass (ToExpr)+  deriving (Generic) -instance HasComment Rule where-  commentL = lens ruleComment (\x y -> x {ruleComment = y})+deriving instance ForAllExtensions i Eq => Eq (Rule i) -compareRuleName :: Rule -> Rule -> Ordering+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++compareRuleName :: Ord (XTerm i) => Rule i -> Rule i -> Ordering compareRuleName = compare `on` ruleName  -- |@@ -235,12 +309,17 @@   deriving (Eq, Generic, Show)   deriving anyclass (ToExpr) -data TypeOrGroup = TOGType Type0 | TOGGroup GroupEntry-  deriving (Eq, Generic, Show)-  deriving anyclass (ToExpr)+data TypeOrGroup i = TOGType (Type0 i) | TOGGroup (GroupEntry i)+  deriving (Generic) -instance CollectComments TypeOrGroup+deriving instance ForAllExtensions i Eq => Eq (TypeOrGroup i) +deriving instance ForAllExtensions i Show => Show (TypeOrGroup i)++deriving instance ForAllExtensions i ToExpr => ToExpr (TypeOrGroup i)++instance ForAllExtensions i CollectComments => CollectComments (TypeOrGroup i)+ {-- |    The group that is used to define a map or an array can often be reused in the    definition of another map or array.  Similarly, a type defined as a tag@@ -290,7 +369,7 @@    described as "threading in" the group or type inside the referenced type,    which suggested the thread-like "~" character.) -}-unwrap :: TypeOrGroup -> Maybe Group+unwrap :: TypeOrGroup i -> Maybe (Group i) unwrap (TOGType (Type0 (Type1 t2 Nothing _ NE.:| []))) = case t2 of   T2Map g -> Just g   T2Array g -> Just g@@ -301,71 +380,84 @@ -- A type can be given as a choice between one or more types.  The --   choice matches a data item if the data item matches any one of the --   types given in the choice.-newtype Type0 = Type0 {t0Type1 :: NE.NonEmpty Type1}-  deriving (Eq, Generic, Show)+newtype Type0 i = Type0 {t0Type1 :: NE.NonEmpty (Type1 i)}+  deriving (Generic)   deriving newtype (Semigroup)-  deriving anyclass (ToExpr) -instance HasComment Type0 where-  commentL = lens (view commentL . t0Type1) (\(Type0 x) y -> Type0 $ x & commentL .~ y)+deriving instance ForAllExtensions i Eq => Eq (Type0 i) -instance CollectComments Type0+deriving instance ForAllExtensions i Show => Show (Type0 i) +deriving anyclass instance ForAllExtensions i ToExpr => ToExpr (Type0 i)++instance ForAllExtensions i CollectComments => CollectComments (Type0 i)+ -- | -- Two types can be combined with a range operator (see below)-data Type1 = Type1-  { t1Main :: Type2-  , t1TyOp :: Maybe (TyOp, Type2)-  , t1Comment :: Comment+data Type1 i = Type1+  { t1Main :: Type2 i+  , t1TyOp :: Maybe (TyOp, Type2 i)+  , t1Comment :: XTerm i   }-  deriving (Eq, Generic, Show)-  deriving anyclass (ToExpr, Default)+  deriving (Generic) -instance HasComment Type1 where-  commentL = lens t1Comment (\x y -> x {t1Comment = y})+deriving instance ForAllExtensions i Eq => Eq (Type1 i) -instance CollectComments Type1 where-  collectComments (Type1 m tyOp c) = c : collectComments m <> collectComments (fmap snd tyOp)+deriving instance ForAllExtensions i Show => Show (Type1 i) -data Type2+deriving instance ForAllExtensions i ToExpr => ToExpr (Type1 i)++instance HasComment (XTerm i) => HasComment (Type1 i) where+  commentL = #t1Comment % commentL++instance ForAllExtensions i CollectComments => CollectComments (Type1 i) where+  collectComments (Type1 m tyOp c) = collectComments c <> collectComments m <> collectComments (fmap snd tyOp)++data Type2 i   = -- | A type can be just a single value (such as 1 or "icecream" or     --   h'0815'), which matches only a data item with that specific value     --   (no conversions defined),     T2Value Value   | -- | or be defined by a rule giving a meaning to a name (possibly after     --   supplying generic arguments as required by the generic parameters)-    T2Name Name (Maybe GenericArg)+    T2Name Name (Maybe (GenericArg i))   | -- | or be defined in a parenthesized type expression (parentheses may be     --   necessary to override some operator precedence),-    T2Group Type0+    T2Group (Type0 i)   | -- | a map expression, which matches a valid CBOR map the key/value pairs     --  of which can be ordered in such a way that the resulting sequence     --  matches the group expression, or-    T2Map Group+    T2Map (Group i)   | -- | an array expression, which matches a CBOR array the elements of which     -- when taken as values and complemented by a wildcard (matches     -- anything) key each -- match the group, or-    T2Array Group+    T2Array (Group i)   | -- | an "unwrapped" group (see Section 3.7), which matches the group     --  inside a type defined as a map or an array by wrapping the group, or-    T2Unwrapped Name (Maybe GenericArg)+    T2Unwrapped Name (Maybe (GenericArg i))   | -- | an enumeration expression, which matches any value that is within the     --  set of values that the values of the group given can take, or-    T2Enum Group-  | T2EnumRef Name (Maybe GenericArg)+    T2Enum (Group i)+  | T2EnumRef Name (Maybe (GenericArg i))   | -- | a tagged data item, tagged with the "uint" given and containing the     --  type given as the tagged value, or-    T2Tag (Maybe Word64) Type0+    T2Tag (Maybe Word64) (Type0 i)   | -- | a data item of a major type (given by the DIGIT), optionally     --  constrained to the additional information given by the uint, or     T2DataItem Word8 (Maybe Word64)   | -- | Any data item     T2Any-  deriving (Eq, Generic, Show, Default)-  deriving anyclass (ToExpr)+  | XXType2 (XXType2 i)+  deriving (Generic) -instance CollectComments Type2+deriving instance ForAllExtensions i Eq => Eq (Type2 i) +deriving instance ForAllExtensions i Show => Show (Type2 i)++deriving instance ForAllExtensions i ToExpr => ToExpr (Type2 i)++instance ForAllExtensions i CollectComments => CollectComments (Type2 i)+ -- | --  An optional _occurrence_ indicator can be given in front of a group --  entry.  It is either (1) one of the characters "?" (optional), "*"@@ -393,30 +485,40 @@ -- | --   A group matches any sequence of key/value pairs that matches any of --   the choices given (again using PEG semantics).-newtype Group = Group {unGroup :: NE.NonEmpty GrpChoice}-  deriving (Eq, Generic, Show)+newtype Group i = Group {unGroup :: NE.NonEmpty (GrpChoice i)}+  deriving (Generic)   deriving newtype (Semigroup)-  deriving anyclass (ToExpr) -instance HasComment Group where-  commentL = lens unGroup (\x y -> x {unGroup = y}) % commentL+deriving instance ForAllExtensions i Eq => Eq (Group i) -instance CollectComments Group where+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++instance ForAllExtensions i CollectComments => CollectComments (Group i) where   collectComments (Group xs) = concatMap collectComments xs -data GrpChoice = GrpChoice-  { gcGroupEntries :: [GroupEntry]-  , gcComment :: Comment+data GrpChoice i = GrpChoice+  { gcGroupEntries :: [GroupEntry i]+  , gcComment :: XTerm i   }-  deriving (Eq, Generic, Show)-  deriving anyclass (ToExpr)+  deriving (Generic) -instance HasComment GrpChoice where-  commentL = lens gcComment (\x y -> x {gcComment = y})+deriving instance ForAllExtensions i Eq => Eq (GrpChoice i) -instance CollectComments GrpChoice where-  collectComments (GrpChoice ges c) = c : concatMap collectComments ges+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++instance ForAllExtensions i CollectComments => CollectComments (GrpChoice i) where+  collectComments (GrpChoice ges c) = collectComments c <> concatMap collectComments ges+ -- | --  A group entry can be given by a value type, which needs to be matched --  by the value part of a single element; and, optionally, a memberkey@@ -424,26 +526,38 @@ --  the memberkey is given.  If the memberkey is not given, the entry can --  only be used for matching arrays, not for maps.  (See below for how --  that is modified by the occurrence indicator.)-data GroupEntry = GroupEntry+data GroupEntry i = GroupEntry   { geOccurrenceIndicator :: Maybe OccurrenceIndicator-  , geComment :: Comment-  , geVariant :: GroupEntryVariant+  , geVariant :: GroupEntryVariant i+  , geExt :: XTerm i   }-  deriving (Eq, Show, Generic, ToExpr)+  deriving (Generic) -instance CollectComments GroupEntry where-  collectComments (GroupEntry _ c x) = c : collectComments x+deriving instance ForAllExtensions i Eq => Eq (GroupEntry i) -data GroupEntryVariant-  = GEType (Maybe MemberKey) Type0-  | GERef Name (Maybe GenericArg)-  | GEGroup Group-  deriving (Eq, Show, Generic, ToExpr)+deriving instance ForAllExtensions i Show => Show (GroupEntry i) -instance HasComment GroupEntry where-  commentL = lens geComment (\x y -> x {geComment = y})+deriving instance ForAllExtensions i ToExpr => ToExpr (GroupEntry i) -instance CollectComments GroupEntryVariant where+instance ForAllExtensions i CollectComments => CollectComments (GroupEntry i) where+  collectComments (GroupEntry _ c x) = collectComments c <> collectComments x++data GroupEntryVariant i+  = GEType (Maybe (MemberKey i)) (Type0 i)+  | GERef Name (Maybe (GenericArg i))+  | GEGroup (Group i)+  deriving (Generic)++deriving instance ForAllExtensions i Eq => Eq (GroupEntryVariant i)++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++instance ForAllExtensions i CollectComments => CollectComments (GroupEntryVariant i) where   collectComments (GEType _ t0) = collectComments t0   collectComments (GERef n mga) = collectComments n <> collectComments mga   collectComments (GEGroup g) = collectComments g@@ -456,12 +570,17 @@ --  member of the key type, unless a cut preceding it in the group --  applies (see Section 3.5.4 for how map matching is influenced by the --  presence of the cuts denoted by "^" or ":" in previous entries).-data MemberKey-  = MKType Type1+data MemberKey i+  = MKType (Type1 i)   | MKBareword Name   | MKValue Value-  deriving (Eq, Generic, Show)-  deriving anyclass (ToExpr)+  deriving (Generic)++deriving instance ForAllExtensions i Eq => Eq (MemberKey i)++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)

@@ -0,0 +1,23 @@+module Codec.CBOR.Cuddle.CDDL.CBORGenerator (+  CBORGenerator (..),+  HasGenerator (..),+  WrappedTerm (..),+) where++import Codec.CBOR.Term (Term)+import Optics.Core (Lens')+import System.Random.Stateful (StatefulGen)++data WrappedTerm+  = -- | Single term+    S Term+  | -- | Pair term+    P Term Term+  | -- | Group term+    G [WrappedTerm]+  deriving (Eq, Show)++newtype CBORGenerator = CBORGenerator (forall g m. StatefulGen g m => g -> m WrappedTerm)++class HasGenerator a where+  generatorL :: Lens' a (Maybe CBORGenerator)

@@ -1,4 +1,9 @@ {-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE TypeData #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}  module Codec.CBOR.Cuddle.CDDL.CTree where @@ -7,12 +12,20 @@   OccurrenceIndicator,   RangeBound,   Value,+  XCddl,+  XRule,+  XTerm,+  XXTopLevel,+  XXType2,  )+import Codec.CBOR.Cuddle.CDDL.CBORGenerator (CBORGenerator) import Codec.CBOR.Cuddle.CDDL.CtlOp-import Codec.CBOR.Cuddle.CDDL.Postlude (PTerm)+import Control.Monad.Identity (Identity (..))+import Data.Default.Class (Default) import Data.Hashable (Hashable) import Data.List.NonEmpty qualified as NE import Data.Map.Strict qualified as Map+import Data.Void (Void) import Data.Word (Word64) import GHC.Generics (Generic) @@ -26,66 +39,138 @@ -- to manipulate. -------------------------------------------------------------------------------- --- | CDDL Tree, parametrised over a functor------   We principally use this functor to represent references - thus, every 'f a'---   may be either an a or a reference to another CTree.-data CTree f+data family XXCTree i++type data CTreePhase++data instance XTerm CTreePhase = CTreeXTerm+  deriving (Generic, Show, Eq, Ord)+  deriving anyclass (Hashable, Default)++newtype instance XXTopLevel CTreePhase = CTreeXXTopLevel Void+  deriving (Generic, Show, Eq, Ord)++data instance XCddl CTreePhase = CTreeXCddl+  deriving (Generic, Show, Eq, Ord)++newtype instance XRule CTreePhase = CTreeXRule (Maybe CBORGenerator)+  deriving (Generic)++newtype instance XXType2 CTreePhase = CTreeXXType2 Void+  deriving (Generic, Show, Eq, Ord)+  deriving anyclass (Hashable)++data CTree i   = Literal Value   | Postlude PTerm-  | Map [Node f]-  | Array [Node f]-  | Choice (NE.NonEmpty (Node f))-  | Group [Node f]-  | KV {key :: Node f, value :: Node f, cut :: Bool}-  | Occur {item :: Node f, occurs :: OccurrenceIndicator}-  | Range {from :: Node f, to :: Node f, inclusive :: RangeBound}-  | Control {op :: CtlOp, target :: Node f, controller :: Node f}-  | Enum (Node f)-  | Unwrap (Node f)-  | Tag Word64 (Node f)+  | Map [CTree i]+  | Array [CTree i]+  | Choice (NE.NonEmpty (CTree i))+  | Group [CTree i]+  | KV {key :: CTree i, value :: CTree i, cut :: Bool}+  | Occur {item :: CTree i, occurs :: OccurrenceIndicator}+  | Range {from :: CTree i, to :: CTree i, inclusive :: RangeBound}+  | Control {op :: CtlOp, target :: CTree i, controller :: CTree i}+  | Enum (CTree i)+  | Unwrap (CTree i)+  | Tag Word64 (CTree i)+  | CTreeE (XXCTree i)   deriving (Generic) +deriving instance Eq (Node f) => Eq (CTree f)++deriving instance Show (Node f) => Show (CTree f)++instance Hashable (Node f) => Hashable (CTree 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)-traverseCTree _ (Literal a) = pure $ Literal a-traverseCTree _ (Postlude a) = pure $ Postlude a-traverseCTree atNode (Map xs) = Map <$> traverse atNode xs-traverseCTree atNode (Array xs) = Array <$> traverse atNode xs-traverseCTree atNode (Group xs) = Group <$> traverse atNode xs-traverseCTree atNode (Choice xs) = Choice <$> traverse atNode xs-traverseCTree atNode (KV k v c) = do+traverseCTree ::+  Monad m => (XXCTree i -> m (CTree j)) -> (CTree i -> m (CTree j)) -> CTree i -> m (CTree j)+traverseCTree _ _ (Literal a) = pure $ Literal a+traverseCTree _ _ (Postlude a) = pure $ Postlude a+traverseCTree _ atNode (Map xs) = Map <$> traverse atNode xs+traverseCTree _ atNode (Array xs) = Array <$> traverse atNode xs+traverseCTree _ atNode (Group xs) = Group <$> traverse atNode xs+traverseCTree _ atNode (Choice xs) = Choice <$> traverse atNode xs+traverseCTree _ atNode (KV k v c) = do   k' <- atNode k   v' <- atNode v   pure $ KV k' v' c-traverseCTree atNode (Occur i occ) = flip Occur occ <$> atNode i-traverseCTree atNode (Range f t inc) = do+traverseCTree _ atNode (Occur i occ) = flip Occur occ <$> atNode i+traverseCTree _ atNode (Range f t inc) = do   f' <- atNode f   t' <- atNode t   pure $ Range f' t' inc-traverseCTree atNode (Control o t c) = do+traverseCTree _ atNode (Control o t c) = do   t' <- atNode t   c' <- atNode c   pure $ Control o t' c'-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 (Enum ref) = Enum <$> atNode ref+traverseCTree _ atNode (Unwrap ref) = Unwrap <$> atNode ref+traverseCTree _ atNode (Tag i ref) = Tag i <$> atNode ref+traverseCTree atExt _ (CTreeE x) = atExt x -type Node f = f (CTree f)+foldCTree ::+  (XXCTree i -> CTree j) ->+  (CTree i -> CTree j) ->+  CTree i ->+  CTree j+foldCTree atExt atNode x = runIdentity $ traverseCTree (pure . atExt) (pure . atNode) x -newtype CTreeRoot' poly f-  = CTreeRoot-      (Map.Map Name (poly (Node f)))+type Node i = XXCTree i++newtype CTreeRoot i = CTreeRoot (Map.Map Name (CTree i))   deriving (Generic) -type CTreeRoot f = CTreeRoot' (ParametrisedWith [Name]) f+deriving instance Show (CTree i) => Show (CTreeRoot i) -data ParametrisedWith w a-  = Unparametrised {underlying :: a}-  | Parametrised-      { underlying :: a-      , params :: w-      }-  deriving (Eq, Functor, Generic, Foldable, Traversable, Show)+-- |+--+--  CDDL predefines a number of names.  This subsection summarizes these+--  names, but please see Appendix D for the exact definitions.+--+--  The following keywords for primitive datatypes are defined:+--+--  "bool"  Boolean value (major type 7, additional information 20+--    or 21).+--+--  "uint"  An unsigned integer (major type 0).+--+--  "nint"  A negative integer (major type 1).+--+--  "int"  An unsigned integer or a negative integer.+--+--  "float16"  A number representable as a half-precision float [IEEE754]+--    (major type 7, additional information 25).+--+--  "float32"  A number representable as a single-precision float+--    [IEEE754] (major type 7, additional information 26).+--+--+--  "float64"  A number representable as a double-precision float+--    [IEEE754] (major type 7, additional information 27).+--+--  "float"  One of float16, float32, or float64.+--+--  "bstr" or "bytes"  A byte string (major type 2).+--+--  "tstr" or "text"  Text string (major type 3).+--+--  (Note that there are no predefined names for arrays or maps; these+--  are defined with the syntax given below.)+data PTerm+  = PTBool+  | PTUInt+  | PTNInt+  | PTInt+  | PTHalf+  | PTFloat+  | PTDouble+  | PTBytes+  | PTText+  | PTAny+  | PTNil+  | PTUndefined+  deriving (Eq, Generic, Ord, Show) -instance (Hashable w, Hashable a) => Hashable (ParametrisedWith w a)+instance Hashable PTerm

@@ -1,55 +1,73 @@+{-# LANGUAGE OverloadedStrings #-}+ module Codec.CBOR.Cuddle.CDDL.Postlude where -import Data.Hashable (Hashable)-import GHC.Generics (Generic)+import Codec.CBOR.Cuddle.CDDL (CDDL (..), TopLevel (..), XRule, XTerm, XXType2, appendRules)+import Codec.CBOR.Cuddle.IndexMappable (IndexMappable (..))+import Codec.CBOR.Cuddle.Parser (ParserStage, pCDDL)+import Data.Maybe (mapMaybe)+import Text.Megaparsec (errorBundlePretty, parse) --- |------  CDDL predefines a number of names.  This subsection summarizes these---  names, but please see Appendix D for the exact definitions.------  The following keywords for primitive datatypes are defined:------  "bool"  Boolean value (major type 7, additional information 20---    or 21).------  "uint"  An unsigned integer (major type 0).------  "nint"  A negative integer (major type 1).------  "int"  An unsigned integer or a negative integer.------  "float16"  A number representable as a half-precision float [IEEE754]---    (major type 7, additional information 25).------  "float32"  A number representable as a single-precision float---    [IEEE754] (major type 7, additional information 26).---------  "float64"  A number representable as a double-precision float---    [IEEE754] (major type 7, additional information 27).------  "float"  One of float16, float32, or float64.------  "bstr" or "bytes"  A byte string (major type 2).------  "tstr" or "text"  Text string (major type 3).------  (Note that there are no predefined names for arrays or maps; these---  are defined with the syntax given below.)-data PTerm-  = PTBool-  | PTUInt-  | PTNInt-  | PTInt-  | PTHalf-  | PTFloat-  | PTDouble-  | PTBytes-  | PTText-  | PTAny-  | PTNil-  | PTUndefined-  deriving (Eq, Generic, Ord, Show)+-- TODO switch to quasiquotes+cddlPostlude :: CDDL ParserStage+cddlPostlude =+  either (error . errorBundlePretty) id $+    parse+      pCDDL+      "<HARDCODED>"+      " any = # \+      \ uint = #0 \+      \ nint = #1 \+      \ int = uint / nint \+      \ \+      \ bstr = #2 \+      \ bytes = bstr \+      \ tstr = #3 \+      \ text = tstr \+      \ \+      \ tdate = #6.0(tstr) \+      \ time = #6.1(number) \+      \ number = int / float \+      \ biguint = #6.2(bstr) \+      \ bignint = #6.3(bstr) \+      \ bigint = biguint / bignint \+      \ integer = int / bigint \+      \ unsigned = uint / biguint \+      \ decfrac = #6.4([e10: int, m: integer]) \+      \ bigfloat = #6.5([e2: int, m: integer]) \+      \ eb64url = #6.21(any) \+      \ eb64legacy = #6.22(any) \+      \ eb16 = #6.23(any) \+      \ encoded-cbor = #6.24(bstr) \+      \ uri = #6.32(tstr) \+      \ b64url = #6.33(tstr) \+      \ b64legacy = #6.34(tstr) \+      \ regexp = #6.35(tstr) \+      \ mime-message = #6.36(tstr) \+      \ cbor-any = #6.55799(any) \+      \ float16 = #7.25 \+      \ float32 = #7.26 \+      \ float64 = #7.27 \+      \ float16-32 = float16 / float32 \+      \ float32-64 = float32 / float64 \+      \ float = float16-32 / float64 \+      \  \+      \ false = #7.20 \+      \ true = #7.21 \+      \ bool = false / true \+      \ nil = #7.22 \+      \ null = nil \+      \ undefined = #7.23" -instance Hashable PTerm+appendPostlude ::+  ( IndexMappable XXType2 ParserStage i+  , IndexMappable XTerm ParserStage i+  , IndexMappable XRule ParserStage i+  ) =>+  CDDL i -> CDDL i+appendPostlude cddl = appendRules cddl $ mapIndex <$> (r : rs)+  where+    CDDL r tls _ = cddlPostlude+    f (TopLevelRule x) = Just x+    f _ = Nothing+    rs = mapMaybe f tls

@@ -1,61 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--module Codec.CBOR.Cuddle.CDDL.Prelude (prependPrelude) where--import Codec.CBOR.Cuddle.CDDL (CDDL (..))-import Codec.CBOR.Cuddle.Parser (pCDDL)-import Text.Megaparsec (errorBundlePretty, parse)---- TODO switch to quasiquotes-cddlPrelude :: CDDL-cddlPrelude =-  either (error . errorBundlePretty) id $-    parse-      pCDDL-      "<HARDCODED>"-      " any = # \-      \ uint = #0 \-      \ nint = #1 \-      \ int = uint / nint \-      \ \-      \ bstr = #2 \-      \ bytes = bstr \-      \ tstr = #3 \-      \ text = tstr \-      \ \-      \ tdate = #6.0(tstr) \-      \ time = #6.1(number) \-      \ number = int / float \-      \ biguint = #6.2(bstr) \-      \ bignint = #6.3(bstr) \-      \ bigint = biguint / bignint \-      \ integer = int / bigint \-      \ unsigned = uint / biguint \-      \ decfrac = #6.4([e10: int, m: integer]) \-      \ bigfloat = #6.5([e2: int, m: integer]) \-      \ eb64url = #6.21(any) \-      \ eb64legacy = #6.22(any) \-      \ eb16 = #6.23(any) \-      \ encoded-cbor = #6.24(bstr) \-      \ uri = #6.32(tstr) \-      \ b64url = #6.33(tstr) \-      \ b64legacy = #6.34(tstr) \-      \ regexp = #6.35(tstr) \-      \ mime-message = #6.36(tstr) \-      \ cbor-any = #6.55799(any) \-      \ float16 = #7.25 \-      \ float32 = #7.26 \-      \ float64 = #7.27 \-      \ float16-32 = float16 / float32 \-      \ float32-64 = float32 / float64 \-      \ float = float16-32 / float64 \-      \  \-      \ false = #7.20 \-      \ true = #7.21 \-      \ bool = false / true \-      \ nil = #7.22 \-      \ null = nil \-      \ undefined = #7.23"--prependPrelude :: CDDL -> CDDL-prependPrelude = (cddlPrelude <>)

@@ -2,7 +2,10 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DerivingVia #-} {-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeData #-}+{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE ViewPatterns #-} @@ -29,8 +32,9 @@   asMap,   buildMonoCTree,   fullResolveCDDL,-  MonoRef (..),   NameResolutionFailure (..),+  MonoReferenced,+  XXCTree (..), ) where @@ -41,142 +45,161 @@ import Capability.Sink (HasSink) import Capability.Source (HasSource) import Capability.State (HasState, MonadState (..), modify)-import Codec.CBOR.Cuddle.CDDL+import Codec.CBOR.Cuddle.CDDL as CDDL import Codec.CBOR.Cuddle.CDDL.CTree (-  CTree,-  CTreeRoot,-  CTreeRoot' (CTreeRoot),-  ParametrisedWith (..),+  CTree (..),+  CTreePhase,+  CTreeRoot (..),+  PTerm (..),+  XRule (..),+  XXCTree,+  XXType2 (..),+  foldCTree,  ) import Codec.CBOR.Cuddle.CDDL.CTree qualified as CTree-import Codec.CBOR.Cuddle.CDDL.Postlude (PTerm (..)) import Control.Monad.Except (ExceptT (..), runExceptT) import Control.Monad.Reader (Reader, ReaderT (..), runReader) import Control.Monad.State.Strict (StateT (..))-import Data.Functor.Identity (Identity (..)) import Data.Generics.Product import Data.Generics.Sum import Data.Hashable #if __GLASGOW_HASKELL__ < 910 import Data.List (foldl') #endif+import Codec.CBOR.Cuddle.CDDL.CBORGenerator (CBORGenerator)+import Codec.CBOR.Cuddle.IndexMappable (IndexMappable (..)) import Data.List.NonEmpty qualified as NE import Data.Map.Strict qualified as Map import Data.Text qualified as T+import Data.Void (absurd) import GHC.Generics (Generic) import Optics.Core +data ProvidedParameters a = ProvidedParameters+  { parameters :: [Name]+  , underlying :: a+  }+  deriving (Generic, Functor, Show, Eq, Foldable, Traversable)++instance Hashable a => Hashable (ProvidedParameters a)+ -------------------------------------------------------------------------------- -- 1. Rule extensions -------------------------------------------------------------------------------- -type CDDLMap = Map.Map Name (Parametrised TypeOrGroup)--type Parametrised a = ParametrisedWith [Name] a+newtype PartialCTreeRoot i = PartialCTreeRoot (Map.Map Name (ProvidedParameters (CTree i)))+  deriving (Generic) -toParametrised :: a -> Maybe GenericParam -> Parametrised a-toParametrised a Nothing = Unparametrised a-toParametrised a (Just (GenericParam gps)) = Parametrised a (NE.toList gps)+type CDDLMap =+  Map.Map Name (ProvidedParameters (TypeOrGroup CTreePhase), Maybe CBORGenerator) -parameters :: Parametrised a -> [Name]-parameters (Unparametrised _) = mempty-parameters (Parametrised _ ps) = ps+toParametrised ::+  TypeOrGroup CTreePhase ->+  Maybe (GenericParameters CTreePhase) ->+  ProvidedParameters (TypeOrGroup CTreePhase)+toParametrised a Nothing = ProvidedParameters [] a+toParametrised a (Just (GenericParameters gps)) = ProvidedParameters (gpName <$> NE.toList gps) a -asMap :: CDDL -> CDDLMap+asMap :: CDDL CTreePhase -> CDDLMap asMap cddl = foldl' go Map.empty rules   where     rules = cddlTopLevel cddl-    go x (TopLevelComment _) = x+    go x (XXTopLevel _) = x     go x (TopLevelRule r) = assignOrExtend x r -    assignOrExtend :: CDDLMap -> Rule -> CDDLMap-    assignOrExtend m (Rule n gps assign tog _) = case assign of+    assignOrExtend :: CDDLMap -> Rule CTreePhase -> CDDLMap+    assignOrExtend m (Rule n gps assign tog (CTreeXRule g)) = case assign of       -- Equals assignment-      AssignEq -> Map.insert n (toParametrised tog gps) m-      AssignExt -> Map.alter (extend tog gps) n m+      AssignEq -> Map.insert n (toParametrised tog gps, g) m+      AssignExt ->+        Map.alter (extend tog gps) n m      extend ::-      TypeOrGroup ->-      Maybe GenericParam ->-      Maybe (Parametrised TypeOrGroup) ->-      Maybe (Parametrised TypeOrGroup)-    extend tog _gps (Just existing) = case (underlying existing, tog) of+      TypeOrGroup CTreePhase ->+      Maybe (GenericParameters CTreePhase) ->+      Maybe (ProvidedParameters (TypeOrGroup CTreePhase), Maybe CBORGenerator) ->+      Maybe (ProvidedParameters (TypeOrGroup CTreePhase), Maybe CBORGenerator)+    extend tog _gps (Just (existing, gen)) = case (underlying existing, tog) of       (TOGType _, TOGType (Type0 new)) ->         Just $-          existing-            & field @"underlying"-            % _Ctor @"TOGType"-            % _Ctor @"Type0"-            %~ (<> new)+          ( existing+              & field @"underlying"+              % _Ctor @"TOGType"+              % _Ctor @"Type0"+              %~ (<> new)+          , gen+          )       -- From the CDDL spec, I don't see how one is meant to extend a group.       -- According to the description, it's meant to add a group choice, but the       -- assignment to a group takes a 'GrpEntry', not a Group, and there is no       -- ability to add a choice. For now, we simply ignore attempt at       -- extension.-      (TOGGroup _, TOGGroup _new) -> Just existing+      (TOGGroup _, TOGGroup _new) -> Just (existing, gen)       (TOGType _, _) -> error "Attempting to extend a type with a group"       (TOGGroup _, _) -> error "Attempting to extend a group with a type"-    extend tog gps Nothing = Just $ toParametrised tog gps+    extend tog gps Nothing = Just (toParametrised tog gps, Nothing)  -------------------------------------------------------------------------------- -- 2. Conversion to CTree -------------------------------------------------------------------------------- --- | Indicates that an item may be referenced rather than defined.-data OrRef a-  = -- | The item is inlined directly-    It a-  | -- | Reference to another node with possible generic arguments supplied-    Ref Name [CTree.Node OrRef]-  deriving (Show, Functor)+type data OrReferenced -type RefCTree = CTreeRoot OrRef+data instance XXCTree OrReferenced+  = -- | Reference to another node with possible generic arguments supplied+    OrRef Name [CTree OrReferenced]+  | OGenerator CBORGenerator (CTree OrReferenced) -deriving instance Show (CTree OrRef)+type data OrReferencedDropGen -deriving instance Show (CTreeRoot OrRef)+data instance XXCTree OrReferencedDropGen = DGOrRef Name [CTree OrReferencedDropGen]+  deriving (Eq, Show) +instance IndexMappable CTree OrReferenced OrReferencedDropGen where+  mapIndex = foldCTree mapExt mapIndex+    where+      mapExt (OrRef n xs) = CTreeE . DGOrRef n $ mapIndex <$> xs+      mapExt (OGenerator _ x) = mapIndex x+ -- | Build a CTree incorporating references. -- -- This translation cannot fail.-buildRefCTree :: CDDLMap -> RefCTree-buildRefCTree rules = CTreeRoot $ fmap toCTreeRule rules+buildRefCTree :: CDDLMap -> PartialCTreeRoot OrReferenced+buildRefCTree rules = PartialCTreeRoot $ uncurry toCTreeRule <$> rules   where     toCTreeRule ::-      Parametrised TypeOrGroup ->-      ParametrisedWith [Name] (CTree.Node OrRef)-    toCTreeRule = fmap toCTreeTOG+      ProvidedParameters (TypeOrGroup CTreePhase) ->+      Maybe CBORGenerator ->+      ProvidedParameters (CTree OrReferenced)+    toCTreeRule params gen = fmap (maybe id (\g x -> CTreeE $ OGenerator g x) gen . toCTreeTOG) params -    toCTreeTOG :: TypeOrGroup -> CTree.Node OrRef+    toCTreeTOG :: TypeOrGroup CTreePhase -> CTree OrReferenced     toCTreeTOG (TOGType t0) = toCTreeT0 t0     toCTreeTOG (TOGGroup ge) = toCTreeGroupEntry ge -    toCTreeT0 :: Type0 -> CTree.Node OrRef+    toCTreeT0 :: Type0 CTreePhase -> CTree OrReferenced     toCTreeT0 (Type0 (t1 NE.:| [])) = toCTreeT1 t1-    toCTreeT0 (Type0 xs) = It . CTree.Choice $ toCTreeT1 <$> xs+    toCTreeT0 (Type0 xs) = CTree.Choice $ toCTreeT1 <$> xs -    toCTreeT1 :: Type1 -> CTree.Node OrRef+    toCTreeT1 :: Type1 CTreePhase -> CTree OrReferenced     toCTreeT1 (Type1 t2 Nothing _) = toCTreeT2 t2     toCTreeT1 (Type1 t2 (Just (op, t2')) _) = case op of       RangeOp bound ->-        It $-          CTree.Range-            { CTree.from = toCTreeT2 t2-            , CTree.to = toCTreeT2 t2'-            , CTree.inclusive = bound-            }+        CTree.Range+          { CTree.from = toCTreeT2 t2+          , CTree.to = toCTreeT2 t2'+          , CTree.inclusive = bound+          }       CtrlOp ctlop ->-        It $-          CTree.Control-            { CTree.op = ctlop-            , CTree.target = toCTreeT2 t2-            , CTree.controller = toCTreeT2 t2'-            }+        CTree.Control+          { CTree.op = ctlop+          , CTree.target = toCTreeT2 t2+          , CTree.controller = toCTreeT2 t2'+          } -    toCTreeT2 :: Type2 -> CTree.Node OrRef-    toCTreeT2 (T2Value v) = It $ CTree.Literal v-    toCTreeT2 (T2Name n garg) =-      Ref n (fromGenArgs garg)+    toCTreeT2 :: Type2 CTreePhase -> CTree OrReferenced+    toCTreeT2 (T2Value v) = CTree.Literal v+    toCTreeT2 (T2Name n garg) = CTreeE $ OrRef n (fromGenArgs garg)     toCTreeT2 (T2Group t0) =       -- This behaviour seems questionable, but I don't really see how better to       -- interpret the spec here.@@ -184,113 +207,107 @@     toCTreeT2 (T2Map g) = toCTreeMap g     toCTreeT2 (T2Array g) = toCTreeArray g     toCTreeT2 (T2Unwrapped n margs) =-      It . CTree.Unwrap $-        Ref n (fromGenArgs margs)+      CTree.Unwrap . CTreeE $+        OrRef n (fromGenArgs margs)     toCTreeT2 (T2Enum g) = toCTreeEnum g-    toCTreeT2 (T2EnumRef n margs) = Ref n $ fromGenArgs margs+    toCTreeT2 (T2EnumRef n margs) = CTreeE . OrRef n $ fromGenArgs margs     toCTreeT2 (T2Tag Nothing t0) =       -- Currently not validating tags       toCTreeT0 t0     toCTreeT2 (T2Tag (Just tag) t0) =-      It . CTree.Tag tag $ toCTreeT0 t0+      CTree.Tag tag $ toCTreeT0 t0     toCTreeT2 (T2DataItem 7 (Just mmin)) =       toCTreeDataItem mmin     toCTreeT2 (T2DataItem _maj _mmin) =       -- We don't validate numerical items yet-      It $ CTree.Postlude PTAny-    toCTreeT2 T2Any = It $ CTree.Postlude PTAny+      CTree.Postlude PTAny+    toCTreeT2 T2Any = CTree.Postlude PTAny+    toCTreeT2 (XXType2 (CTreeXXType2 v)) = absurd v      toCTreeDataItem 20 =-      It . CTree.Literal $ Value (VBool False) mempty+      CTree.Literal $ Value (VBool False) mempty     toCTreeDataItem 21 =-      It . CTree.Literal $ Value (VBool True) mempty+      CTree.Literal $ Value (VBool True) mempty     toCTreeDataItem 25 =-      It $ CTree.Postlude PTHalf+      CTree.Postlude PTHalf     toCTreeDataItem 26 =-      It $ CTree.Postlude PTFloat+      CTree.Postlude PTFloat     toCTreeDataItem 27 =-      It $ CTree.Postlude PTDouble+      CTree.Postlude PTDouble     toCTreeDataItem 23 =-      It $ CTree.Postlude PTUndefined+      CTree.Postlude PTUndefined     toCTreeDataItem _ =-      It $ CTree.Postlude PTAny+      CTree.Postlude PTAny -    toCTreeGroupEntry :: GroupEntry -> CTree.Node OrRef-    toCTreeGroupEntry (GroupEntry (Just occi) _ (GEType mmkey t0)) =-      It $-        CTree.Occur-          { CTree.item = toKVPair mmkey t0-          , CTree.occurs = occi-          }-    toCTreeGroupEntry (GroupEntry Nothing _ (GEType mmkey t0)) = toKVPair mmkey t0-    toCTreeGroupEntry (GroupEntry (Just occi) _ (GERef n margs)) =-      It $-        CTree.Occur-          { CTree.item = Ref n (fromGenArgs margs)-          , CTree.occurs = occi-          }-    toCTreeGroupEntry (GroupEntry Nothing _ (GERef n margs)) = Ref n (fromGenArgs margs)-    toCTreeGroupEntry (GroupEntry (Just occi) _ (GEGroup g)) =-      It $-        CTree.Occur-          { CTree.item = groupToGroup g-          , CTree.occurs = occi-          }-    toCTreeGroupEntry (GroupEntry Nothing _ (GEGroup g)) = groupToGroup g+    toCTreeGroupEntry :: GroupEntry CTreePhase -> CTree OrReferenced+    toCTreeGroupEntry (GroupEntry (Just occi) (GEType mmkey t0) _) =+      CTree.Occur+        { CTree.item = toKVPair mmkey t0+        , CTree.occurs = occi+        }+    toCTreeGroupEntry (GroupEntry Nothing (GEType mmkey t0) _) = toKVPair mmkey t0+    toCTreeGroupEntry (GroupEntry (Just occi) (GERef n margs) _) =+      CTree.Occur+        { CTree.item = CTreeE $ OrRef n (fromGenArgs margs)+        , CTree.occurs = occi+        }+    toCTreeGroupEntry (GroupEntry Nothing (GERef n margs) _) = CTreeE $ OrRef n (fromGenArgs margs)+    toCTreeGroupEntry (GroupEntry (Just occi) (GEGroup g) _) =+      CTree.Occur+        { CTree.item = groupToGroup g+        , CTree.occurs = occi+        }+    toCTreeGroupEntry (GroupEntry Nothing (GEGroup g) _) = groupToGroup g -    fromGenArgs :: Maybe GenericArg -> [CTree.Node OrRef]+    fromGenArgs :: Maybe (GenericArg CTreePhase) -> [CTree OrReferenced]     fromGenArgs = maybe [] (\(GenericArg xs) -> NE.toList $ fmap toCTreeT1 xs)      -- Interpret a group as an enumeration. Note that we float out the     -- choice options-    toCTreeEnum :: Group -> CTree.Node OrRef-    toCTreeEnum (Group (a NE.:| [])) =-      It . CTree.Enum . It . CTree.Group $ toCTreeGroupEntry <$> gcGroupEntries a-    toCTreeEnum (Group xs) =-      It . CTree.Choice $-        It . CTree.Enum . It . CTree.Group . fmap toCTreeGroupEntry <$> groupEntries+    toCTreeEnum :: Group CTreePhase -> CTree OrReferenced+    toCTreeEnum (CDDL.Group (a NE.:| [])) =+      CTree.Enum . CTree.Group $ toCTreeGroupEntry <$> gcGroupEntries a+    toCTreeEnum (CDDL.Group xs) =+      CTree.Choice $ CTree.Enum . CTree.Group . fmap toCTreeGroupEntry <$> groupEntries       where         groupEntries = fmap gcGroupEntries xs      -- Embed a group in another group, again floating out the choice options-    groupToGroup :: Group -> CTree.Node OrRef-    groupToGroup (Group (a NE.:| [])) =-      It . CTree.Group $ fmap toCTreeGroupEntry (gcGroupEntries a)-    groupToGroup (Group xs) =-      It . CTree.Choice $-        fmap (It . CTree.Group . fmap toCTreeGroupEntry) (gcGroupEntries <$> xs)+    groupToGroup :: Group CTreePhase -> CTree OrReferenced+    groupToGroup (CDDL.Group (a NE.:| [])) =+      CTree.Group $ fmap toCTreeGroupEntry (gcGroupEntries a)+    groupToGroup (CDDL.Group xs) =+      CTree.Choice $ fmap (CTree.Group . fmap toCTreeGroupEntry) (gcGroupEntries <$> xs) -    toKVPair :: Maybe MemberKey -> Type0 -> CTree.Node OrRef+    toKVPair :: Maybe (MemberKey CTreePhase) -> Type0 CTreePhase -> CTree OrReferenced     toKVPair Nothing t0 = toCTreeT0 t0     toKVPair (Just mkey) t0 =-      It $-        CTree.KV-          { CTree.key = toCTreeMemberKey mkey-          , CTree.value = toCTreeT0 t0-          , -- TODO Handle cut semantics-            CTree.cut = False-          }+      CTree.KV+        { CTree.key = toCTreeMemberKey mkey+        , CTree.value = toCTreeT0 t0+        , -- TODO Handle cut semantics+          CTree.cut = False+        }      -- Interpret a group as a map. Note that we float out the choice options-    toCTreeMap :: Group -> CTree.Node OrRef-    toCTreeMap (Group (a NE.:| [])) = It . CTree.Map $ fmap toCTreeGroupEntry (gcGroupEntries a)-    toCTreeMap (Group xs) =-      It-        . CTree.Choice-        $ fmap (It . CTree.Map . fmap toCTreeGroupEntry) (gcGroupEntries <$> xs)+    toCTreeMap :: Group CTreePhase -> CTree OrReferenced+    toCTreeMap (CDDL.Group (a NE.:| [])) = CTree.Map $ fmap toCTreeGroupEntry (gcGroupEntries a)+    toCTreeMap (CDDL.Group xs) =+      CTree.Choice $+        fmap (CTree.Map . fmap toCTreeGroupEntry) (gcGroupEntries <$> xs)      -- Interpret a group as an array. Note that we float out the choice     -- options-    toCTreeArray :: Group -> CTree.Node OrRef-    toCTreeArray (Group (a NE.:| [])) =-      It . CTree.Array $ fmap toCTreeGroupEntry (gcGroupEntries a)-    toCTreeArray (Group xs) =-      It . CTree.Choice $-        fmap (It . CTree.Array . fmap toCTreeGroupEntry) (gcGroupEntries <$> xs)+    toCTreeArray :: Group CTreePhase -> CTree OrReferenced+    toCTreeArray (CDDL.Group (a NE.:| [])) =+      CTree.Array $ fmap toCTreeGroupEntry (gcGroupEntries a)+    toCTreeArray (CDDL.Group xs) =+      CTree.Choice $+        fmap (CTree.Array . fmap toCTreeGroupEntry) (gcGroupEntries <$> xs) -    toCTreeMemberKey :: MemberKey -> CTree.Node OrRef-    toCTreeMemberKey (MKValue v) = It $ CTree.Literal v-    toCTreeMemberKey (MKBareword (Name n _)) = It $ CTree.Literal (Value (VText n) mempty)+    toCTreeMemberKey :: MemberKey CTreePhase -> CTree OrReferenced+    toCTreeMemberKey (MKValue v) = CTree.Literal v+    toCTreeMemberKey (MKBareword n) = CTree.Literal (Value (VText $ unName n) mempty)     toCTreeMemberKey (MKType t1) = toCTreeT1 t1  --------------------------------------------------------------------------------@@ -300,116 +317,112 @@ data NameResolutionFailure   = UnboundReference Name   | MismatchingArgs Name [Name]-  | ArgsToPostlude PTerm [CTree.Node OrRef]-  deriving (Show)+  | ArgsToPostlude PTerm [CTree OrReferencedDropGen]+  deriving (Show, Eq)  postludeBinding :: Map.Map Name PTerm postludeBinding =   Map.fromList-    [ (Name "bool" mempty, PTBool)-    , (Name "uint" mempty, PTUInt)-    , (Name "nint" mempty, PTNInt)-    , (Name "int" mempty, PTInt)-    , (Name "half" mempty, PTHalf)-    , (Name "float" mempty, PTFloat)-    , (Name "double" mempty, PTDouble)-    , (Name "bytes" mempty, PTBytes)-    , (Name "bstr" mempty, PTBytes)-    , (Name "text" mempty, PTText)-    , (Name "tstr" mempty, PTText)-    , (Name "any" mempty, PTAny)-    , (Name "nil" mempty, PTNil)-    , (Name "null" mempty, PTNil)+    [ ("bool", PTBool)+    , ("uint", PTUInt)+    , ("nint", PTNInt)+    , ("int", PTInt)+    , ("half", PTHalf)+    , ("float", PTFloat)+    , ("double", PTDouble)+    , ("bytes", PTBytes)+    , ("bstr", PTBytes)+    , ("text", PTText)+    , ("tstr", PTText)+    , ("any", PTAny)+    , ("nil", PTNil)+    , ("null", PTNil)     ] -data BindingEnv poly f g = BindingEnv-  { global :: Map.Map Name (poly (CTree.Node f))+data BindingEnv i j = BindingEnv+  { global :: Map.Map (Name) (ProvidedParameters (CTree i))   -- ^ Global name bindings via 'RuleDef'-  , local :: Map.Map Name (CTree.Node g)+  , local :: Map.Map (Name) (CTree j)   -- ^ Local bindings for generic parameters   }   deriving (Generic) -data DistRef a-  = DIt a-  | -- | Reference to a generic parameter-    GenericRef Name-  | -- | Reference to a rule definition, possibly with generic arguments-    RuleRef Name [CTree.Node DistRef]-  deriving (Eq, Generic, Functor, Show)+type data DistReferenced -instance Hashable a => Hashable (DistRef a)+data DistRef i+  = -- | Reference to a generic parameter+    GenericRef (Name)+  | -- | Reference to a rule definition, possibly with generic arguments+    RuleRef (Name) [CTree i]+  deriving (Generic) -deriving instance Show (CTree DistRef)+deriving instance Eq (CTree.Node i) => Eq (DistRef i) -deriving instance Eq (CTree DistRef)+deriving instance Show (CTree.Node i) => Show (DistRef i) -instance Hashable (CTree DistRef)+instance Hashable (CTree.Node i) => Hashable (DistRef i) -deriving instance Show (CTreeRoot DistRef)+data instance XXCTree DistReferenced+  = DRef (DistRef DistReferenced)+  | DGenerator CBORGenerator (CTree DistReferenced) -deriving instance Eq (CTreeRoot DistRef)+type data DistReferencedNoGen -instance Hashable (CTreeRoot DistRef)+newtype instance XXCTree DistReferencedNoGen = DHRef (DistRef DistReferencedNoGen)+  deriving (Eq, Hashable)  resolveRef ::-  BindingEnv (ParametrisedWith [Name]) OrRef OrRef ->-  CTree.Node OrRef ->-  Either NameResolutionFailure (DistRef (CTree DistRef))-resolveRef env (It a) = DIt <$> resolveCTree env a-resolveRef env (Ref n args) = case Map.lookup n postludeBinding of+  BindingEnv OrReferenced OrReferenced ->+  CTree.Node OrReferenced ->+  Either NameResolutionFailure (CTree DistReferenced)+resolveRef env (OrRef n args) = case Map.lookup n postludeBinding of   Just pterm -> case args of-    [] -> Right . DIt $ CTree.Postlude pterm-    xs -> Left $ ArgsToPostlude pterm xs+    [] -> Right $ CTree.Postlude pterm+    xs -> Left . ArgsToPostlude pterm $ mapIndex <$> xs   Nothing -> case Map.lookup n (global env) of     Just (parameters -> params') ->       if length params' == length args         then           let localBinds = Map.fromList $ zip params' args-              newEnv = env & field @"local" %~ Map.union localBinds-           in RuleRef n <$> traverse (resolveRef newEnv) args+              newEnv = env & #local %~ Map.union localBinds+           in CTreeE . DRef . RuleRef n <$> traverse (resolveCTree newEnv) args         else Left $ MismatchingArgs n params'     Nothing -> case Map.lookup n (local env) of-      Just _ -> Right $ GenericRef n+      Just _ -> Right . CTreeE . DRef $ GenericRef n       Nothing -> Left $ UnboundReference n+resolveRef env (OGenerator g x) = CTreeE . DGenerator g <$> resolveCTree env x  resolveCTree ::-  BindingEnv (ParametrisedWith [Name]) OrRef OrRef ->-  CTree OrRef ->-  Either NameResolutionFailure (CTree DistRef)-resolveCTree e = CTree.traverseCTree (resolveRef e)+  BindingEnv OrReferenced OrReferenced ->+  CTree OrReferenced ->+  Either NameResolutionFailure (CTree DistReferenced)+resolveCTree e = CTree.traverseCTree (resolveRef e) (resolveCTree e)  buildResolvedCTree ::-  CTreeRoot OrRef ->-  Either NameResolutionFailure (CTreeRoot DistRef)-buildResolvedCTree (CTreeRoot ct) = CTreeRoot <$> traverse go ct+  PartialCTreeRoot OrReferenced ->+  Either NameResolutionFailure (PartialCTreeRoot DistReferenced)+buildResolvedCTree (PartialCTreeRoot ct) = PartialCTreeRoot <$> traverse go ct   where-    initBindingEnv = BindingEnv ct mempty     go pn =       let args = parameters pn-          localBinds = Map.fromList $ zip args (flip Ref [] <$> args)-          env = initBindingEnv & field @"local" %~ Map.union localBinds-       in traverse (resolveRef env) pn+          localBinds = Map.fromList $ zip args (CTreeE . flip OrRef [] <$> args)+          env = BindingEnv @OrReferenced @OrReferenced ct localBinds+       in traverse (resolveCTree env) pn  -------------------------------------------------------------------------------- -- 4. Monomorphisation -------------------------------------------------------------------------------- -data MonoRef a-  = MIt a-  | MRuleRef Name-  deriving (Functor, Show)--deriving instance Show (CTree MonoRef)+type data MonoReferenced -deriving instance-  Show (poly (CTree.Node MonoRef)) =>-  Show (CTreeRoot' poly MonoRef)+data instance XXCTree MonoReferenced+  = MRuleRef Name+  | MGenerator CBORGenerator (CTree MonoReferenced) -type MonoEnv = BindingEnv (ParametrisedWith [Name]) DistRef MonoRef+type MonoEnv = BindingEnv DistReferenced MonoReferenced  -- | We introduce additional bindings in the state-type MonoState = Map.Map Name (CTree.Node MonoRef)+type MonoState = Map.Map Name (CTree MonoReferenced)  -- | Monad to run the monomorphisation process. We need some additional -- capabilities for this, so 'Either' doesn't fully cut it anymore.@@ -431,10 +444,10 @@   deriving     ( HasSource         "local"-        (Map.Map Name (CTree.Node MonoRef))+        (Map.Map (Name) (CTree MonoReferenced))     , HasReader         "local"-        (Map.Map Name (CTree.Node MonoRef))+        (Map.Map (Name) (CTree MonoReferenced))     )     via Field           "local"@@ -448,10 +461,10 @@   deriving     ( HasSource         "global"-        (Map.Map Name (ParametrisedWith [Name] (CTree.Node DistRef)))+        (Map.Map (Name) (ProvidedParameters (CTree DistReferenced)))     , HasReader         "global"-        (Map.Map Name (ParametrisedWith [Name] (CTree.Node DistRef)))+        (Map.Map (Name) (ProvidedParameters (CTree DistReferenced)))     )     via Field           "global"@@ -477,87 +490,87 @@ throwNR = throw @"nameResolution"  -- | Synthesize a monomorphic rule definition, returning the name-synthMono :: Name -> [CTree.Node DistRef] -> MonoM Name-synthMono n@(Name origName _) args =-  let fresh =+synthMono :: Name -> [CTree DistReferenced] -> MonoM Name+synthMono origName args =+  let dropGenerator = fmap $ mapIndex @_ @_ @DistReferencedNoGen+      fresh =         -- % is not a valid CBOR name, so this should avoid conflict-        Name (origName <> "%" <> T.pack (show $ hash args)) mempty+        origName <> "%" <> Name (T.pack (show . hash $ dropGenerator args))    in do         -- Lookup the original name in the global bindings         globalBinds <- ask @"global"-        case Map.lookup n globalBinds of-          Just (Unparametrised _) -> throwNR $ MismatchingArgs n []-          Just (Parametrised r params') ->+        case Map.lookup origName globalBinds of+          Just (ProvidedParameters [] _) -> throwNR $ MismatchingArgs origName []+          Just (ProvidedParameters params' r) ->             if length params' == length args               then do-                rargs <- traverse resolveGenericRef args+                rargs <- traverse resolveGenericCTree args                 let localBinds = Map.fromList $ zip params' rargs                 Reader.local @"local" (Map.union localBinds) $ do-                  foo <- resolveGenericRef r+                  foo <- resolveGenericCTree r                   modify @"synth" $ Map.insert fresh foo-              else throwNR $ MismatchingArgs n params'-          Nothing -> throwNR $ UnboundReference n+              else throwNR $ MismatchingArgs origName params'+          Nothing -> throwNR $ UnboundReference origName         pure fresh  resolveGenericRef ::-  CTree.Node DistRef ->-  MonoM (MonoRef (CTree MonoRef))-resolveGenericRef (DIt a) = MIt <$> resolveGenericCTree a-resolveGenericRef (RuleRef n margs) =-  case margs of-    [] -> pure $ MRuleRef n-    args -> do-      fresh <- synthMono n args-      pure $ MRuleRef fresh-resolveGenericRef (GenericRef n) = do+  CTree.Node DistReferenced ->+  MonoM (CTree MonoReferenced)+resolveGenericRef (DRef (RuleRef n [])) = pure . CTreeE $ MRuleRef n+resolveGenericRef (DRef (RuleRef n args)) = do+  fresh <- synthMono n args+  pure . CTreeE $ MRuleRef fresh+resolveGenericRef (DRef (GenericRef n)) = do   localBinds <- ask @"local"   case Map.lookup n localBinds of     Just node -> pure node     Nothing -> throwNR $ UnboundReference n+resolveGenericRef (DGenerator g x) = CTreeE . MGenerator g <$> resolveGenericCTree x  resolveGenericCTree ::-  CTree DistRef ->-  MonoM (CTree MonoRef)-resolveGenericCTree = CTree.traverseCTree resolveGenericRef+  CTree DistReferenced ->+  MonoM (CTree MonoReferenced)+resolveGenericCTree = CTree.traverseCTree resolveGenericRef resolveGenericCTree  -- | Monomorphise the CTree -- -- Concretely, for each reference in the tree to a generic rule, we synthesize a -- new monomorphic instance of that rule at top-level with the correct -- parameters applied.-monoCTree ::-  CTreeRoot' Identity DistRef ->-  MonoM (CTreeRoot' Identity MonoRef)-monoCTree (CTreeRoot ct) = CTreeRoot <$> traverse go ct-  where-    go = traverse resolveGenericRef- buildMonoCTree ::-  CTreeRoot DistRef ->-  Either NameResolutionFailure (CTreeRoot' Identity MonoRef)-buildMonoCTree (CTreeRoot ct) = do-  let a1 = runExceptT $ runMonoM (monoCTree monoC)+  PartialCTreeRoot DistReferenced ->+  Either NameResolutionFailure (CTreeRoot MonoReferenced)+buildMonoCTree (PartialCTreeRoot ct) = do+  let a1 = runExceptT $ runMonoM (traverse resolveGenericCTree monoC)       a2 = runStateT a1 mempty-      (er, newBindings) = runReader a2 initBindingEnv-  CTreeRoot r <- er-  pure . CTreeRoot $ Map.union r $ fmap Identity newBindings+      (r, newBindings) = runReader a2 initBindingEnv+  CTreeRoot . (`Map.union` newBindings) <$> r   where     initBindingEnv = BindingEnv ct mempty     monoC =-      CTreeRoot $-        Map.mapMaybe-          ( \case-              Unparametrised f -> Just $ Identity f-              Parametrised _ _ -> Nothing-          )-          ct+      Map.mapMaybe+        ( \case+            ProvidedParameters [] f -> Just f+            _ -> Nothing+        )+        ct  -------------------------------------------------------------------------------- -- Combined resolution -------------------------------------------------------------------------------- -fullResolveCDDL :: CDDL -> Either NameResolutionFailure (CTreeRoot' Identity MonoRef)+fullResolveCDDL :: CDDL CTreePhase -> Either NameResolutionFailure (CTreeRoot MonoReferenced) fullResolveCDDL cddl = do   let refCTree = buildRefCTree (asMap cddl)   rCTree <- buildResolvedCTree refCTree   buildMonoCTree rCTree++instance IndexMappable CTree DistReferenced DistReferencedNoGen where+  mapIndex = foldCTree mapExt mapIndex+    where+      mapExt (DRef x) = CTreeE . DHRef $ mapIndex x+      mapExt (DGenerator _ x) = mapIndex x++instance IndexMappable DistRef DistReferenced DistReferencedNoGen where+  mapIndex (GenericRef n) = GenericRef n+  mapIndex (RuleRef n args) = RuleRef n $ mapIndex <$> args

@@ -26,6 +26,7 @@ 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, (:*:) (..), (:+:) (..)) import Optics.Core (Lens', lens, view, (%~), (&), (.~), (^.))@@ -84,6 +85,10 @@   collectComments :: a -> [Comment]   default collectComments :: (Generic a, GCollectComments (Rep a)) => a -> [Comment]   collectComments = collectCommentsG . from++instance CollectComments Void where collectComments = absurd++instance CollectComments () where collectComments = mempty  instance CollectComments a => CollectComments (Maybe a) where   collectComments Nothing = []

@@ -2,7 +2,10 @@ {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TypeData #-} {-# LANGUAGE TypeFamilies #-}  -- | Module for building CDDL in Haskell@@ -16,11 +19,19 @@   Huddle,   HuddleItem (..),   huddleAugment,-  Rule,-  Named,+  Rule (..),+  GroupDef (..),   IsType0 (..),   Value (..), +  -- * AST extensions+  HuddleStage,+  C.XCddl (..),+  C.XTerm (..),+  C.XRule (..),+  C.XXTopLevel (..),+  C.XXType2 (..),+   -- * Rules and assignment   (=:=),   (=:~),@@ -55,6 +66,7 @@   bstr,   int,   text,+  bool,    -- * Ctl operators   IsConstrainable,@@ -71,12 +83,18 @@    -- * Generics   GRef,-  GRuleDef,-  GRuleCall,+  GRuleDef (..),+  GRuleCall (..),   binding,   binding2,   callToDef, +  -- * Generators+  withGenerator,++  -- * Name+  HasName (..),+   -- * Conversion to CDDL   collectFrom,   collectFromInit,@@ -85,20 +103,24 @@ ) where -import Codec.CBOR.Cuddle.CDDL (CDDL)+import Codec.CBOR.Cuddle.CDDL (CDDL, GenericParameter (..), HasName (..), Name (..), XRule) import Codec.CBOR.Cuddle.CDDL qualified as C+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 import Control.Monad (when)-import Control.Monad.State (MonadState (get), execState, modify)+import Control.Monad.State (MonadState (get), State, execState, modify) import Data.ByteString (ByteString)+import Data.ByteString.Base16 qualified as Base16 import Data.Default.Class (Default (..)) import Data.Function (on)-import Data.Generics.Product (HasField' (field'), field, getField)+import Data.Generics.Product (field, getField) import Data.List qualified as L import Data.List.NonEmpty qualified as NE import Data.Map.Ordered.Strict (OMap, (|<>)) import Data.Map.Ordered.Strict qualified as OMap+import Data.Set qualified as Set import Data.String (IsString (fromString)) import Data.Text qualified as T import Data.Tuple.Optics (Field2 (..))@@ -106,45 +128,90 @@ import Data.Word (Word64) import GHC.Exts (IsList (Item, fromList, toList)) import GHC.Generics (Generic)-import Optics.Core (lens, view, (%~), (&), (.~), (^.))+import Optics.Core (lens, view, (%), (%~), (&))+import Optics.Core qualified as L+import System.Random.Stateful (StatefulGen) import Prelude hiding ((/)) +type data HuddleStage++newtype instance C.XTerm HuddleStage = HuddleXTerm C.Comment+  deriving (Generic, Semigroup, Monoid, Show, Eq)++newtype instance C.XCddl HuddleStage = HuddleXCddl [C.Comment]+  deriving (Generic, Semigroup, Monoid, Show, Eq)++data instance C.XRule HuddleStage = HuddleXRule+  { hxrComment :: C.Comment+  , hxrGenerator :: Maybe CBORGenerator+  }+  deriving (Generic)++instance HasComment (C.XRule HuddleStage) where+  commentL = #hxrComment++instance Default (XRule HuddleStage)++newtype instance C.XXTopLevel HuddleStage = HuddleXXTopLevel C.Comment+  deriving (Generic, Semigroup, Monoid, Show, Eq)++newtype instance C.XXType2 HuddleStage = HuddleXXType2 Void+  deriving (Generic, Semigroup, Show, Eq)+ data Named a = Named-  { name :: T.Text+  { name :: Name   , value :: a-  , description :: Maybe T.Text   }-  deriving (Functor, Generic)+  deriving (Functor, Generic, Show)  -- | Add a description to a rule or group entry, to be included as a comment.-comment :: HasField' "description" a (Maybe T.Text) => T.Text -> a -> a-comment desc n = n & field' @"description" .~ Just desc+comment :: HasComment a => Comment -> a -> a+comment desc n = n & commentL %~ (<> desc) -instance Show (Named a) where-  show (Named n _ _) = T.unpack n+data Rule = Rule+  { ruleDefinition :: Named Type0+  , ruleExtra :: XRule HuddleStage+  }+  deriving (Generic) -type Rule = Named Type0+instance HasGenerator Rule where+  generatorL = #ruleExtra % #hxrGenerator +instance HasComment Rule where+  commentL = #ruleExtra % #hxrComment++instance HasName Rule where+  getName = getName . ruleDefinition++data GroupDef = GroupDef {gdNamed :: Named Group, gdExt :: XRule HuddleStage}+  deriving (Generic)++instance HasComment GroupDef where+  commentL = #gdExt % commentL++instance HasName GroupDef where+  getName = getName . gdNamed+ data HuddleItem   = HIRule Rule   | HIGRule GRuleDef-  | HIGroup (Named Group)-  deriving (Generic, Show)+  | HIGroup GroupDef+  deriving (Generic)  -- | Top-level Huddle type is a list of rules. data Huddle = Huddle   { roots :: [Rule]   -- ^ Root elements-  , items :: OMap T.Text HuddleItem+  , items :: OMap Name HuddleItem   }-  deriving (Generic, Show)+  deriving (Generic)  -- | Joins two `Huddle` values with a left-bias. This means that this function -- is not symmetric and that any rules that are present in both prefer the -- definition from the `Huddle` value on the left. huddleAugment :: Huddle -> Huddle -> Huddle huddleAugment (Huddle rootsL itemsL) (Huddle rootsR itemsR) =-  Huddle (L.nubBy ((==) `on` name) $ rootsL <> rootsR) (itemsL |<> itemsR)+  Huddle (L.nubBy ((==) `on` name . ruleDefinition) $ rootsL <> rootsR) (itemsL |<> itemsR)  -- | This semigroup instance: --   - Takes takes the roots from the RHS unless they are empty, in which case@@ -169,8 +236,8 @@ instance IsList Huddle where   type Item Huddle = Rule   fromList [] = Huddle mempty OMap.empty-  fromList (x : xs) =-    (field @"items" %~ (OMap.|> (x ^. field @"name", HIRule x))) $ fromList xs+  fromList (r@(Rule x _) : xs) =+    (#items %~ (OMap.|> (getName x, HIRule r))) $ fromList xs    toList = const [] @@ -193,7 +260,6 @@ data Key   = LiteralKey Literal   | TypeKey Type2-  deriving (Show)  -- | Instance for the very general case where we use text keys instance IsString Key where@@ -214,13 +280,12 @@   , quantifier :: Occurs   , meDescription :: C.Comment   }-  deriving (Generic, Show)+  deriving (Generic)  instance C.HasComment MapEntry where   commentL = lens meDescription (\x y -> x {meDescription = y})  newtype MapChoice = MapChoice {unMapChoice :: [MapEntry]}-  deriving (Show)  instance IsList MapChoice where   type Item MapChoice = MapEntry@@ -238,7 +303,7 @@   , quantifier :: Occurs   , aeDescription :: C.Comment   }-  deriving (Generic, Show)+  deriving (Generic)  instance C.HasComment ArrayEntry where   commentL = lens aeDescription (\x y -> x {aeDescription = y})@@ -260,7 +325,6 @@   { unArrayChoice :: [ArrayEntry]   , acComment :: C.Comment   }-  deriving (Show)  instance Semigroup ArrayChoice where   ArrayChoice x xc <> ArrayChoice y yc = ArrayChoice (x <> y) (xc <> yc)@@ -279,8 +343,8 @@  type Array = Choice ArrayChoice -newtype Group = Group {unGroup :: [ArrayEntry]}-  deriving (Show, Monoid, Semigroup)+newtype Group = Group {_unGroup :: [ArrayEntry]}+  deriving (Monoid, Semigroup)  instance IsList Group where   type Item Group = ArrayEntry@@ -294,13 +358,12 @@   | T2Map Map   | T2Array Array   | T2Tagged (Tagged Type0)-  | T2Ref (Named Type0)-  | T2Group (Named Group)+  | T2Ref Rule+  | T2Group GroupDef   | -- | Call to a generic rule, binding arguments     T2Generic GRuleCall   | -- | Reference to a generic parameter within the body of the definition     T2GenericRef GRef-  deriving (Show)  type Type0 = Choice Type2 @@ -362,17 +425,23 @@   LFloat :: Float -> LiteralVariant   LDouble :: Double -> LiteralVariant   LBytes :: ByteString -> LiteralVariant+  LBool :: Bool -> LiteralVariant   deriving (Show)  int :: Integer -> Literal int = inferInteger  bstr :: ByteString -> Literal-bstr x = Literal (LBytes x) mempty+bstr x = case Base16.decode x of+  Right bs -> Literal (LBytes bs) mempty+  Left e -> error $ "`bstr` expects a hex string, but received " <> show x <> " instead\n" <> e  text :: T.Text -> Literal text x = Literal (LText x) mempty +bool :: Bool -> Literal+bool x = Literal (LBool x) mempty+ inferInteger :: Integer -> Literal inferInteger i   | i >= 0 && i < fromIntegral (maxBound @Word64) = Literal (LInt (fromInteger i)) mempty@@ -390,7 +459,6 @@   = CValue (Value a)   | CRef (AnyRef a)   | CGRef GRef-  deriving (Show)  -- | Uninhabited type used as marker for the type of thing a CRef sizes data CRefType@@ -403,17 +471,15 @@ data Constrained where   Constrained ::     forall a.-    { value :: Constrainable a-    , constraint :: ValueConstraint a-    , refs :: [Rule]+    { _value :: Constrainable a+    , _constraint :: ValueConstraint a+    , _refs :: [Rule]     -- ^ Sometimes constraints reference rules. In this case we need to     -- collect the references in order to traverse them when collecting all     -- relevant rules.     } ->     Constrained -deriving instance Show Constrained- class IsConstrainable a x | a -> x where   toConstrainable :: a -> Constrainable x @@ -432,13 +498,10 @@ -- | A constraint on a 'Value' is something applied via CtlOp or RangeOp on a -- Type2, forming a Type1. data ValueConstraint a = ValueConstraint-  { applyConstraint :: C.Type2 -> C.Type1+  { applyConstraint :: C.Type2 HuddleStage -> C.Type1 HuddleStage   , showConstraint :: String   } -instance Show (ValueConstraint a) where-  show = showConstraint- instance Default (ValueConstraint a) where   def =     ValueConstraint@@ -462,7 +525,7 @@  -- | Things which can be used on the RHS of the '.size' operator. class IsSize a where-  sizeAsCDDL :: a -> C.Type2+  sizeAsCDDL :: a -> C.Type2 HuddleStage   sizeAsString :: a -> String  instance IsSize Word where@@ -516,16 +579,16 @@ instance IsCborable GRef  cbor :: (IsCborable b, IsConstrainable c b) => c -> Rule -> Constrained-cbor v r@(Named n _ _) =+cbor v r@(Rule (Named n _) _) =   Constrained     (toConstrainable v)     ValueConstraint       { applyConstraint = \t2 ->           C.Type1             t2-            (Just (C.CtrlOp CtlOp.Cbor, C.T2Name (C.Name n mempty) Nothing))+            (Just (C.CtrlOp CtlOp.Cbor, C.T2Name n Nothing))             mempty-      , showConstraint = ".cbor " <> T.unpack n+      , showConstraint = ".cbor " <> T.unpack (unName n)       }     [r] @@ -553,7 +616,6 @@ data RangeBound   = RangeBoundLiteral Literal   | RangeBoundRef (Named Type0)-  deriving (Show)  class IsRangeBound a where   toRangeBound :: a -> RangeBound@@ -567,15 +629,17 @@ instance IsRangeBound (Named Type0) where   toRangeBound = RangeBoundRef +instance IsRangeBound Rule where+  toRangeBound (Rule x _) = toRangeBound x+ data Ranged where   Ranged ::-    { lb :: RangeBound-    , ub :: RangeBound-    , bounds :: C.RangeBound+    { _lb :: RangeBound+    , _ub :: RangeBound+    , _bounds :: C.RangeBound     } ->     Ranged   Unranged :: Literal -> Ranged-  deriving (Show)  -- | Establish a closed range bound. (...) :: (IsRangeBound a, IsRangeBound b) => a -> b -> Ranged@@ -637,7 +701,7 @@ instance IsType0 (Value a) where   toType0 = NoChoice . T2Constrained . unconstrained -instance IsType0 (Named Group) where+instance IsType0 GroupDef where   toType0 = NoChoice . T2Group  instance IsType0 GRuleCall where@@ -654,7 +718,8 @@   toType0 (HIGroup g) = toType0 g   toType0 (HIGRule g) =     error $-      "Attempt to reference generic rule from HuddleItem not supported: " <> show g+      "Attempt to reference generic rule from HuddleItem not supported: "+        <> T.unpack (unName (getName g))  class CanQuantify a where   -- | Apply a lower bound@@ -719,13 +784,13 @@ infixl 8 ==>  -- | Assign a rule-(=:=) :: IsType0 a => T.Text -> a -> Rule-n =:= b = Named n (toType0 b) Nothing+(=:=) :: IsType0 a => Name -> a -> Rule+n =:= b = Rule (Named n (toType0 b)) def  infixl 1 =:= -(=:~) :: T.Text -> Group -> Named Group-n =:~ b = Named n b Nothing+(=:~) :: Name -> Group -> GroupDef+n =:~ b = GroupDef (Named n b) def  infixl 1 =:~ @@ -790,7 +855,7 @@ instance IsChoosable (Value a) Type2 where   toChoice = toChoice . T2Constrained . unconstrained -instance IsChoosable (Named Group) Type2 where+instance IsChoosable GroupDef Type2 where   toChoice = toChoice . T2Group  instance IsChoosable (Seal Array) Type2 where@@ -918,12 +983,20 @@   { args :: NE.NonEmpty a   , body :: Type0   }-  deriving (Show) -type GRuleCall = Named (GRule Type2)+data GRuleCall = GRuleCall+  { grcBody :: Named (GRule Type2)+  , grcExtra :: XRule HuddleStage+  } -type GRuleDef = Named (GRule GRef)+data GRuleDef = GRuleDef+  { grdBody :: Named (GRule GRef)+  , grdExtra :: XRule HuddleStage+  } +instance HasName GRuleDef where+  getName = getName . grdBody+ callToDef :: GRule Type2 -> GRule GRef callToDef gr = gr {args = refs}   where@@ -939,15 +1012,17 @@ -- | Bind a single variable into a generic call binding :: IsType0 t0 => (GRef -> Rule) -> t0 -> GRuleCall binding fRule t0 =-  Named-    (name rule)-    GRule-      { args = t2 NE.:| []-      , body = getField @"value" rule-      }-    Nothing+  GRuleCall+    ( Named+        (name ruleDefinition)+        GRule+          { args = t2 NE.:| []+          , body = getField @"value" ruleDefinition+          }+    )+    ruleExtra   where-    rule = fRule (freshName 0)+    Rule {..} = fRule (freshName 0)     t2 = case toType0 t0 of       NoChoice x -> x       _ -> error "Cannot use a choice of types as a generic argument"@@ -955,15 +1030,17 @@ -- | Bind two variables as a generic call binding2 :: (IsType0 t0, IsType0 t1) => (GRef -> GRef -> Rule) -> t0 -> t1 -> GRuleCall binding2 fRule t0 t1 =-  Named-    (name rule)-    GRule-      { args = t02 NE.:| [t12]-      , body = getField @"value" rule-      }-    Nothing+  GRuleCall+    ( Named+        (name ruleDefinition)+        GRule+          { args = t02 NE.:| [t12]+          , body = getField @"value" ruleDefinition+          }+    )+    ruleExtra   where-    rule = fRule (freshName 0) (freshName 1)+    Rule {..} = fRule (freshName 0) (freshName 1)     t02 = case toType0 t0 of       NoChoice x -> x       _ -> error "Cannot use a choice of types as a generic argument"@@ -979,10 +1056,10 @@ hiRule (HIRule r) = [r] hiRule _ = [] -hiName :: HuddleItem -> T.Text-hiName (HIRule (Named n _ _)) = n-hiName (HIGroup (Named n _ _)) = n-hiName (HIGRule (Named n _ _)) = n+instance HasName HuddleItem where+  getName (HIRule (Rule (Named n _) _)) = n+  getName (HIGroup (GroupDef (Named n _) _)) = n+  getName (HIGRule (GRuleDef (Named n _) _)) = n  -- | Collect all rules starting from a given point. This will also insert a --   single pseudo-rule as the first element which references the specified@@ -1001,8 +1078,9 @@         }     goHuddleItem (HIRule r) = goRule r     goHuddleItem (HIGroup g) = goNamedGroup g-    goHuddleItem (HIGRule (Named _ (GRule _ t0) _)) = goT0 t0-    goRule r@(Named n t0 _) = do+    goHuddleItem (HIGRule (GRuleDef (Named _ (GRule _ t0)) _)) = goT0 t0+    goRule :: Rule -> State (OMap Name HuddleItem) ()+    goRule r@(Rule (Named n t0) _) = do       items <- get       when (OMap.notMember n items) $ do         modify (OMap.|> (n, HIRule r))@@ -1010,15 +1088,15 @@     goChoice f (NoChoice x) = f x     goChoice f (ChoiceOf x xs) = f x >> goChoice f xs     goT0 = goChoice goT2-    goNamedGroup r@(Named n g _) = do+    goNamedGroup gd@(GroupDef (Named n g) _) = do       items <- get       when (OMap.notMember n items) $ do-        modify (OMap.|> (n, HIGroup r))+        modify (OMap.|> (n, HIGroup gd))         goGroup g-    goGRule r@(Named n g _) = do+    goGRule (GRuleCall r@(Named n g) extra) = do       items <- get       when (OMap.notMember n items) $ do-        modify (OMap.|> (n, HIGRule $ fmap callToDef r))+        modify (OMap.|> (n, HIGRule $ GRuleDef (fmap callToDef r) extra))         goT0 (body g)       -- Note that the parameters here may be different, so this doesn't live       -- under the guard@@ -1027,13 +1105,13 @@     goT2 (T2Map m) = goChoice (mapM_ goMapEntry . unMapChoice) m     goT2 (T2Array m) = goChoice (mapM_ goArrayEntry . unArrayChoice) m     goT2 (T2Tagged (Tagged _ t0)) = goT0 t0-    goT2 (T2Ref n) = goRule n+    goT2 (T2Ref r) = goRule r     goT2 (T2Group r) = goNamedGroup r     goT2 (T2Generic x) = goGRule x     goT2 (T2Constrained (Constrained c _ refs)) =       ( case c of           CValue _ -> pure ()-          CRef r -> goRule r+          CRef r -> goRule $ Rule r def           CGRef _ -> pure ()       )         >> mapM_ goRule refs@@ -1047,49 +1125,80 @@     goRanged (Unranged _) = pure ()     goRanged (Ranged lb ub _) = goRangeBound lb >> goRangeBound ub     goRangeBound (RangeBoundLiteral _) = pure ()-    goRangeBound (RangeBoundRef r) = goRule r+    goRangeBound (RangeBoundRef r) = goRule . Rule r $ HuddleXRule mempty Nothing  -- | Same as `collectFrom`, but the rules passed into this function will be put --   at the top of the Huddle, and all of their dependencies will be added at --   the end in depth-first order. collectFromInit :: [HuddleItem] -> Huddle collectFromInit rules =-  Huddle (concatMap hiRule rules) (OMap.fromList $ (\x -> (hiName x, x)) <$> rules)+  Huddle (concatMap hiRule rules) (OMap.fromList $ (\x -> (getName x, x)) <$> rules)     `huddleAugment` collectFrom rules  -------------------------------------------------------------------------------- -- Conversion to CDDL -------------------------------------------------------------------------------- +data HuddleConfig = HuddleConfig+  { hcMakePseudoRoot :: Bool+  , hcFailOnDuplicateDefinitions :: Bool+  }++defaultHuddleConfig :: HuddleConfig+defaultHuddleConfig =+  HuddleConfig+    { hcMakePseudoRoot = True+    , hcFailOnDuplicateDefinitions = True+    }+ -- | Convert from Huddle to CDDL, generating a top level root element.-toCDDL :: Huddle -> CDDL-toCDDL = toCDDL' True+toCDDL :: Huddle -> CDDL HuddleStage+toCDDL = toCDDL' defaultHuddleConfig  -- | Convert from Huddle to CDDL, skipping a root element.-toCDDLNoRoot :: Huddle -> CDDL-toCDDLNoRoot = toCDDL' False+toCDDLNoRoot :: Huddle -> CDDL HuddleStage+toCDDLNoRoot =+  toCDDL'+    defaultHuddleConfig+      { hcMakePseudoRoot = False+      }  -- | Convert from Huddle to CDDL for the purpose of pretty-printing.-toCDDL' :: Bool -> Huddle -> CDDL-toCDDL' mkPseudoRoot hdl =+toCDDL' :: HuddleConfig -> Huddle -> CDDL HuddleStage+toCDDL' HuddleConfig {..} hdl =   C.fromRules-    $ ( if mkPseudoRoot-          then (toTopLevelPseudoRoot (roots hdl) NE.<|)-          else id-      )+    . failOnDuplicate+    . makePseudoRoot     $ fmap toCDDLItem (NE.fromList $ fmap (view _2) $ toList $ items hdl)   where+    makePseudoRoot+      | hcMakePseudoRoot = (toTopLevelPseudoRoot (roots hdl) NE.<|)+      | otherwise = id++    failOnDuplicate rs+      | hcFailOnDuplicateDefinitions = go mempty $ toList rs+      | otherwise = rs+      where+        go _ [] = rs+        go s (x : xs)+          | n `Set.member` s = error . T.unpack $ "Duplicate definitions found for '" <> unName n <> "'"+          | otherwise = go (Set.insert n s) xs+          where+            n = C.ruleName x+     toCDDLItem (HIRule r) = toCDDLRule r-    toCDDLItem (HIGroup g) = toCDDLGroup g+    toCDDLItem (HIGroup g) = toCDDLGroupDef g     toCDDLItem (HIGRule g) = toGenRuleDef g-    toTopLevelPseudoRoot :: [Rule] -> C.Rule+    toTopLevelPseudoRoot :: [Rule] -> C.Rule HuddleStage     toTopLevelPseudoRoot topRs =       toCDDLRule $         comment "Pseudo-rule introduced by Cuddle to collect root elements" $           "huddle_root_defs" =:= arr (fromList (fmap a topRs))-    toCDDLRule :: Rule -> C.Rule-    toCDDLRule (Named n t0 c) =-      (\x -> C.Rule (C.Name n mempty) Nothing C.AssignEq x (foldMap C.Comment c))+    toCDDLRule :: Rule -> C.Rule HuddleStage+    toCDDLRule (Rule (Named n t0) extra) =+      ( \x ->+          C.Rule n Nothing C.AssignEq x extra+      )         . C.TOGType         . C.Type0         $ toCDDLType1 <$> choiceToNE t0@@ -1102,19 +1211,20 @@     toCDDLValue' (LDouble d) = C.VFloat64 d     toCDDLValue' (LText t) = C.VText t     toCDDLValue' (LBytes b) = C.VBytes b+    toCDDLValue' (LBool b) = C.VBool b -    mapToCDDLGroup :: Map -> C.Group+    mapToCDDLGroup :: Map -> C.Group HuddleStage     mapToCDDLGroup xs = C.Group $ mapChoiceToCDDL <$> choiceToNE xs -    mapChoiceToCDDL :: MapChoice -> C.GrpChoice+    mapChoiceToCDDL :: MapChoice -> C.GrpChoice HuddleStage     mapChoiceToCDDL (MapChoice entries) = C.GrpChoice (fmap mapEntryToCDDL entries) mempty -    mapEntryToCDDL :: MapEntry -> C.GroupEntry+    mapEntryToCDDL :: MapEntry -> C.GroupEntry HuddleStage     mapEntryToCDDL (MapEntry k v occ cmnt) =       C.GroupEntry         (toOccurrenceIndicator occ)-        cmnt         (C.GEType (Just $ toMemberKey k) (toCDDLType0 v))+        (HuddleXTerm cmnt)      toOccurrenceIndicator :: Occurs -> Maybe C.OccurrenceIndicator     toOccurrenceIndicator (Occurs Nothing Nothing) = Nothing@@ -1123,7 +1233,7 @@     toOccurrenceIndicator (Occurs (Just 1) Nothing) = Just C.OIOneOrMore     toOccurrenceIndicator (Occurs lb ub) = Just $ C.OIBounded lb ub -    toCDDLType1 :: Type2 -> C.Type1+    toCDDLType1 :: Type2 -> C.Type1 HuddleStage     toCDDLType1 = \case       T2Constrained (Constrained x constr _) ->         -- TODO Need to handle choices at the top level@@ -1137,51 +1247,51 @@       T2Array x -> C.Type1 (C.T2Array $ arrayToCDDLGroup x) Nothing mempty       T2Tagged (Tagged mmin x) ->         C.Type1 (C.T2Tag mmin $ toCDDLType0 x) Nothing mempty-      T2Ref (Named n _ _) -> C.Type1 (C.T2Name (C.Name n mempty) Nothing) Nothing mempty-      T2Group (Named n _ _) -> C.Type1 (C.T2Name (C.Name n mempty) Nothing) Nothing mempty+      T2Ref (Rule (Named n _) _) -> C.Type1 (C.T2Name n Nothing) Nothing mempty+      T2Group (GroupDef (Named n _) _) -> C.Type1 (C.T2Name n Nothing) Nothing mempty       T2Generic g -> C.Type1 (toGenericCall g) Nothing mempty-      T2GenericRef (GRef n) -> C.Type1 (C.T2Name (C.Name n mempty) Nothing) Nothing mempty+      T2GenericRef (GRef n) -> C.Type1 (C.T2Name (C.Name n) Nothing) Nothing mempty -    toMemberKey :: Key -> C.MemberKey-    toMemberKey (LiteralKey (Literal (LText t) _)) = C.MKBareword (C.Name t mempty)+    toMemberKey :: Key -> C.MemberKey HuddleStage+    toMemberKey (LiteralKey (Literal (LText t) _)) = C.MKBareword (C.Name t)     toMemberKey (LiteralKey v) = C.MKValue $ toCDDLValue v     toMemberKey (TypeKey t) = C.MKType (toCDDLType1 t) -    toCDDLType0 :: Type0 -> C.Type0+    toCDDLType0 :: Type0 -> C.Type0 HuddleStage     toCDDLType0 = C.Type0 . fmap toCDDLType1 . choiceToNE -    arrayToCDDLGroup :: Array -> C.Group+    arrayToCDDLGroup :: Array -> C.Group HuddleStage     arrayToCDDLGroup xs = C.Group $ arrayChoiceToCDDL <$> choiceToNE xs -    arrayChoiceToCDDL :: ArrayChoice -> C.GrpChoice-    arrayChoiceToCDDL (ArrayChoice entries cmt) = C.GrpChoice (fmap arrayEntryToCDDL entries) cmt+    arrayChoiceToCDDL :: ArrayChoice -> C.GrpChoice HuddleStage+    arrayChoiceToCDDL (ArrayChoice entries cmt) = C.GrpChoice (fmap arrayEntryToCDDL entries) (HuddleXTerm cmt) -    arrayEntryToCDDL :: ArrayEntry -> C.GroupEntry+    arrayEntryToCDDL :: ArrayEntry -> C.GroupEntry HuddleStage     arrayEntryToCDDL (ArrayEntry k v occ cmnt) =       C.GroupEntry         (toOccurrenceIndicator occ)-        cmnt         (C.GEType (fmap toMemberKey k) (toCDDLType0 v))+        (HuddleXTerm cmnt)      toCDDLPostlude :: Value a -> C.Name-    toCDDLPostlude VBool = C.Name "bool" mempty-    toCDDLPostlude VUInt = C.Name "uint" mempty-    toCDDLPostlude VNInt = C.Name "nint" mempty-    toCDDLPostlude VInt = C.Name "int" mempty-    toCDDLPostlude VHalf = C.Name "half" mempty-    toCDDLPostlude VFloat = C.Name "float" mempty-    toCDDLPostlude VDouble = C.Name "double" mempty-    toCDDLPostlude VBytes = C.Name "bytes" mempty-    toCDDLPostlude VText = C.Name "text" mempty-    toCDDLPostlude VAny = C.Name "any" mempty-    toCDDLPostlude VNil = C.Name "nil" mempty+    toCDDLPostlude VBool = C.Name "bool"+    toCDDLPostlude VUInt = C.Name "uint"+    toCDDLPostlude VNInt = C.Name "nint"+    toCDDLPostlude VInt = C.Name "int"+    toCDDLPostlude VHalf = C.Name "half"+    toCDDLPostlude VFloat = C.Name "float"+    toCDDLPostlude VDouble = C.Name "double"+    toCDDLPostlude VBytes = C.Name "bytes"+    toCDDLPostlude VText = C.Name "text"+    toCDDLPostlude VAny = C.Name "any"+    toCDDLPostlude VNil = C.Name "nil"      toCDDLConstrainable c = case c of       CValue v -> toCDDLPostlude v-      CRef r -> C.Name (name r) mempty-      CGRef (GRef n) -> C.Name n mempty+      CRef r -> name r+      CGRef (GRef n) -> C.Name n -    toCDDLRanged :: Ranged -> C.Type1+    toCDDLRanged :: Ranged -> C.Type1 HuddleStage     toCDDLRanged (Unranged x) =       C.Type1 (C.T2Value $ toCDDLValue x) Nothing mempty     toCDDLRanged (Ranged lb ub rop) =@@ -1190,18 +1300,18 @@         (Just (C.RangeOp rop, toCDDLRangeBound ub))         mempty -    toCDDLRangeBound :: RangeBound -> C.Type2+    toCDDLRangeBound :: RangeBound -> C.Type2 HuddleStage     toCDDLRangeBound (RangeBoundLiteral l) = C.T2Value $ toCDDLValue l-    toCDDLRangeBound (RangeBoundRef (Named n _ _)) = C.T2Name (C.Name n mempty) Nothing+    toCDDLRangeBound (RangeBoundRef (Named n _)) = C.T2Name n Nothing -    toCDDLGroup :: Named Group -> C.Rule-    toCDDLGroup (Named n (Group t0s) c) =+    toCDDLGroupDef :: GroupDef -> C.Rule HuddleStage+    toCDDLGroupDef (GroupDef (Named n (Group t0s)) extra) =       C.Rule-        (C.Name n mempty)+        n         Nothing         C.AssignEq         ( C.TOGGroup-            . C.GroupEntry Nothing mempty+            . (\x -> C.GroupEntry Nothing x mempty)             . C.GEGroup             . C.Group             . (NE.:| [])@@ -1210,25 +1320,32 @@               arrayEntryToCDDL               t0s         )-        (foldMap C.Comment c)+        extra -    toGenericCall :: GRuleCall -> C.Type2-    toGenericCall (Named n gr _) =+    toGenericCall :: GRuleCall -> C.Type2 HuddleStage+    toGenericCall (GRuleCall (Named n gr) _) =       C.T2Name-        (C.Name n mempty)+        n         (Just . C.GenericArg $ fmap toCDDLType1 (args gr)) -    toGenRuleDef :: GRuleDef -> C.Rule-    toGenRuleDef (Named n gr c) =+    toGenRuleDef :: GRuleDef -> C.Rule HuddleStage+    toGenRuleDef (GRuleDef (Named n gr) extra) =       C.Rule-        (C.Name n mempty)+        n         (Just gps)         C.AssignEq         ( C.TOGType             . C.Type0             $ toCDDLType1 <$> choiceToNE (body gr)         )-        (foldMap C.Comment c)+        extra       where         gps =-          C.GenericParam $ fmap (\(GRef t) -> C.Name t mempty) (args gr)+          C.GenericParameters $+            fmap (\(GRef t) -> GenericParameter (C.Name t) $ HuddleXTerm mempty) (args gr)++withGenerator :: HasGenerator a => (forall g m. StatefulGen g m => g -> m WrappedTerm) -> a -> a+withGenerator f = L.set generatorL (Just $ CBORGenerator f)++instance HasName (Named a) where+  getName = name

@@ -15,25 +15,25 @@ ) where +import Codec.CBOR.Cuddle.CDDL (Name) import Codec.CBOR.Cuddle.Huddle hiding (binding, (=:=), (=:~)) import Codec.CBOR.Cuddle.Huddle qualified as Huddle import Control.Monad.State.Strict (State, modify, runState) import Data.Default.Class (def) import Data.Generics.Product (HasField (..)) import Data.Map.Ordered.Strict qualified as OMap-import Data.Text qualified as T import Optics.Core (set, (%~), (^.))  type HuddleM = State Huddle  -- | Overridden version of assignment which also adds the rule to the state-(=:=) :: IsType0 a => T.Text -> a -> HuddleM Rule+(=:=) :: IsType0 a => Name -> a -> HuddleM Rule n =:= b = let r = n Huddle.=:= b in include r  infixl 1 =:=  -- | Overridden version of group assignment which adds the rule to the state-(=:~) :: T.Text -> Group -> HuddleM (Named Group)+(=:~) :: Name -> Group -> HuddleM GroupDef n =:~ b = let r = n Huddle.=:~ b in include r  infixl 1 =:~@@ -46,7 +46,7 @@ binding fRule = include (Huddle.binding fRule)  -- | Renamed version of Huddle's underlying '=:=' for use in generic bindings-(=::=) :: IsType0 a => T.Text -> a -> Rule+(=::=) :: IsType0 a => Name -> a -> Rule n =::= b = n Huddle.=:= b  infixl 1 =::=@@ -65,39 +65,39 @@   include :: a -> HuddleM a  instance Includable Rule where-  include r =-    modify (field @"items" %~ (OMap.|> (r ^. field @"name", HIRule r)))+  include r@(Rule x _) =+    modify (field @"items" %~ (OMap.|> (getName x, HIRule r)))       >> pure r -instance Includable (Named Group) where+instance Includable GroupDef where   include r =     modify       ( (field @"items")-          %~ (OMap.|> (r ^. field @"name", HIGroup r))+          %~ (OMap.|> (getName r, HIGroup r))       )       >> pure r  instance IsType0 t0 => Includable (t0 -> GRuleCall) where   include gr =     let fakeT0 = error "Attempting to unwrap fake value in generic call"-        grDef = callToDef <$> gr fakeT0-        n = grDef ^. field @"name"+        GRuleCall g extra = gr fakeT0+        grDef = callToDef <$> g+        n = getName grDef      in do-          modify (field @"items" %~ (OMap.|> (n, HIGRule grDef)))+          modify (field @"items" %~ (OMap.|> (n, HIGRule $ GRuleDef grDef extra)))           pure gr  instance Includable HuddleItem where   include x@(HIRule r) = include r >> pure x   include x@(HIGroup g) = include g >> pure x   include x@(HIGRule g) =-    let n = g ^. field @"name"-     in do-          modify (field @"items" %~ (OMap.|> (n, x)))-          pure x+    do+      modify (field @"items" %~ (OMap.|> (getName g, x)))+      pure x  unsafeIncludeFromHuddle ::   Huddle ->-  T.Text ->+  Name ->   HuddleM HuddleItem unsafeIncludeFromHuddle h name =   let items = h ^. field @"items"

@@ -1,26 +0,0 @@-{-# LANGUAGE DataKinds #-}---- | Optics for mutating Huddle rules-module Codec.CBOR.Cuddle.Huddle.Optics (commentL, nameL) where--import Codec.CBOR.Cuddle.Huddle-import Data.Generics.Product (HasField' (field'))-import Data.Text qualified as T-import Optics.Core--mcommentL ::-  HasField' "description" a (Maybe T.Text) =>-  Lens a a (Maybe T.Text) (Maybe T.Text)-mcommentL = field' @"description"---- | Traversal to the comment field of a description. Using this we can for---   example set the comment with 'a & commentL .~ "This is a comment"'-commentL ::-  HasField' "description" a (Maybe T.Text) =>-  AffineTraversal a a T.Text T.Text-commentL = mcommentL % _Just---- | Lens to the name of a rule (or other named entity). Using this we can---   for example append to the name with 'a & nameL %~ (<> "_1")'-nameL :: Lens (Named a) (Named a) T.Text T.Text-nameL = field' @"name"

@@ -0,0 +1,291 @@+{-# LANGUAGE DefaultSignatures #-}++module Codec.CBOR.Cuddle.IndexMappable (IndexMappable (..), mapCDDLDropExt) where++import Codec.CBOR.Cuddle.CDDL (+  CDDL (..),+  GenericArg (..),+  GenericParameter (..),+  GenericParameters (..),+  Group (..),+  GroupEntry (..),+  GroupEntryVariant (..),+  GrpChoice (..),+  MemberKey (..),+  Rule (..),+  TopLevel (..),+  Type0 (..),+  Type1 (..),+  Type2 (..),+  TypeOrGroup (..),+  XCddl,+  XRule,+  XTerm,+  XXTopLevel,+  XXType2,+ )+import Codec.CBOR.Cuddle.CDDL.CTree (+  CTreePhase,+  XCddl (..),+  XRule (..),+  XTerm (..),+  XXType2 (..),+ )+import Codec.CBOR.Cuddle.Huddle (+  HuddleStage,+  XCddl (..),+  XRule (..),+  XTerm (..),+  XXTopLevel (..),+  XXType2 (..),+ )+import Codec.CBOR.Cuddle.Parser (+  ParserStage,+  XCddl (..),+  XRule (..),+  XTerm (..),+  XXTopLevel (..),+  XXType2 (..),+ )+import Codec.CBOR.Cuddle.Pretty (PrettyStage, XCddl (..), XRule (..), XTerm (..), XXTopLevel (..))+import Data.Bifunctor (Bifunctor (..))+import Data.Coerce (Coercible, coerce)+import Data.Void (absurd)++class IndexMappable f i j where+  mapIndex :: f i -> f j+  default mapIndex :: Coercible (f i) (f j) => f i -> f j+  mapIndex = coerce++mapCDDLDropExt ::+  ( IndexMappable XXType2 i j+  , IndexMappable XTerm i j+  , IndexMappable XRule i j+  ) =>+  CDDL i ->+  CDDL j+mapCDDLDropExt (CDDL r tls _) = CDDL (mapIndex r) (foldMap mapTopLevelDropExt tls) []+  where+    mapTopLevelDropExt (TopLevelRule x) = [TopLevelRule $ mapIndex x]+    mapTopLevelDropExt (XXTopLevel _) = []++instance+  ( IndexMappable XCddl i j+  , IndexMappable XXTopLevel i j+  , IndexMappable XXType2 i j+  , IndexMappable XTerm i j+  , IndexMappable XRule i j+  ) =>+  IndexMappable CDDL i j+  where+  mapIndex (CDDL r tls e) = CDDL (mapIndex r) (mapIndex <$> tls) (mapIndex <$> e)++instance+  ( IndexMappable XXType2 i j+  , IndexMappable XTerm i j+  , IndexMappable XRule i j+  ) =>+  IndexMappable Rule i j+  where+  mapIndex (Rule n mg a t c) = Rule n (mapIndex <$> mg) a (mapIndex t) (mapIndex c)++instance+  ( IndexMappable XXTopLevel i j+  , IndexMappable XXType2 i j+  , IndexMappable XTerm i j+  , IndexMappable XRule i j+  ) =>+  IndexMappable TopLevel i j+  where+  mapIndex (TopLevelRule r) = TopLevelRule $ mapIndex r+  mapIndex (XXTopLevel e) = XXTopLevel $ mapIndex e++instance IndexMappable XTerm i j => IndexMappable GenericParameter i j where+  mapIndex (GenericParameter n e) = GenericParameter n $ mapIndex e++instance IndexMappable XTerm i j => IndexMappable GenericParameters i j where+  mapIndex (GenericParameters ns) = GenericParameters $ mapIndex <$> ns++instance+  ( IndexMappable XXType2 i j+  , IndexMappable XTerm i j+  ) =>+  IndexMappable TypeOrGroup i j+  where+  mapIndex (TOGType t) = TOGType $ mapIndex t+  mapIndex (TOGGroup g) = TOGGroup $ mapIndex g++instance+  ( IndexMappable XTerm i j+  , IndexMappable XXType2 i j+  ) =>+  IndexMappable GroupEntry i j+  where+  mapIndex (GroupEntry mo gev e) = GroupEntry mo (mapIndex gev) (mapIndex e)++instance+  ( IndexMappable XXType2 i j+  , IndexMappable XTerm i j+  ) =>+  IndexMappable GroupEntryVariant i j+  where+  mapIndex (GEType mk t) = GEType (mapIndex <$> mk) $ mapIndex t+  mapIndex (GERef n ma) = GERef n (mapIndex <$> ma)+  mapIndex (GEGroup g) = GEGroup (mapIndex g)++instance+  ( IndexMappable XXType2 i j+  , IndexMappable XTerm i j+  ) =>+  IndexMappable MemberKey i j+  where+  mapIndex (MKType t) = MKType $ mapIndex t+  mapIndex (MKBareword n) = MKBareword n+  mapIndex (MKValue x) = MKValue x++instance+  ( IndexMappable XXType2 i j+  , IndexMappable XTerm i j+  ) =>+  IndexMappable Type0 i j+  where+  mapIndex (Type0 ts) = Type0 $ mapIndex <$> ts++instance+  ( IndexMappable XXType2 i j+  , IndexMappable XTerm i j+  ) =>+  IndexMappable Type1 i j+  where+  mapIndex (Type1 t mo e) = Type1 (mapIndex t) (second mapIndex <$> mo) (mapIndex e)++instance+  ( IndexMappable XXType2 i j+  , IndexMappable XTerm i j+  ) =>+  IndexMappable Type2 i j+  where+  mapIndex (T2Value v) = T2Value v+  mapIndex (T2Name n mg) = T2Name n (mapIndex <$> mg)+  mapIndex (T2Group t) = T2Group $ mapIndex t+  mapIndex (T2Map g) = T2Map $ mapIndex g+  mapIndex (T2Array a) = T2Array $ mapIndex a+  mapIndex (T2Unwrapped n mg) = T2Unwrapped n (mapIndex <$> mg)+  mapIndex (T2Enum g) = T2Enum $ mapIndex g+  mapIndex (T2EnumRef n mg) = T2EnumRef n (mapIndex <$> mg)+  mapIndex (T2Tag mt t) = T2Tag mt $ mapIndex t+  mapIndex (T2DataItem t mt) = T2DataItem t mt+  mapIndex T2Any = T2Any+  mapIndex (XXType2 e) = XXType2 $ mapIndex e++instance+  ( IndexMappable XXType2 i j+  , IndexMappable XTerm i j+  ) =>+  IndexMappable GenericArg i j+  where+  mapIndex (GenericArg g) = GenericArg $ mapIndex <$> g++instance+  ( IndexMappable XTerm i j+  , IndexMappable XXType2 i j+  ) =>+  IndexMappable Group i j+  where+  mapIndex (Group g) = Group $ mapIndex <$> g++instance+  ( IndexMappable XTerm i j+  , IndexMappable XXType2 i j+  ) =>+  IndexMappable GrpChoice i j+  where+  mapIndex (GrpChoice gs e) = GrpChoice (mapIndex <$> gs) $ mapIndex e++-- ParserStage -> PrettyStage++instance IndexMappable XCddl ParserStage PrettyStage where+  mapIndex (ParserXCddl c) = PrettyXCddl c++instance IndexMappable XTerm ParserStage PrettyStage where+  mapIndex (ParserXTerm c) = PrettyXTerm c++instance IndexMappable XRule ParserStage PrettyStage where+  mapIndex (ParserXRule c) = PrettyXRule c++instance IndexMappable XXType2 ParserStage PrettyStage where+  mapIndex (ParserXXType2 v) = absurd v++instance IndexMappable XXTopLevel ParserStage PrettyStage where+  mapIndex (ParserXXTopLevel c) = PrettyXXTopLevel c++-- ParserStage -> CTreePhase++instance IndexMappable XCddl ParserStage CTreePhase where+  mapIndex _ = CTreeXCddl++instance IndexMappable XXType2 ParserStage CTreePhase where+  mapIndex (ParserXXType2 c) = CTreeXXType2 c++instance IndexMappable XTerm ParserStage CTreePhase where+  mapIndex _ = CTreeXTerm++instance IndexMappable XRule ParserStage CTreePhase where+  mapIndex _ = CTreeXRule Nothing++-- ParserStage -> HuddleStage++instance IndexMappable XCddl ParserStage HuddleStage where+  mapIndex (ParserXCddl c) = HuddleXCddl c++instance IndexMappable XXTopLevel ParserStage HuddleStage where+  mapIndex (ParserXXTopLevel c) = HuddleXXTopLevel c++instance IndexMappable XXType2 ParserStage HuddleStage where+  mapIndex (ParserXXType2 c) = HuddleXXType2 c++instance IndexMappable XTerm ParserStage HuddleStage where+  mapIndex (ParserXTerm c) = HuddleXTerm c++-- HuddleStage -> CTreePhase++instance IndexMappable XCddl HuddleStage CTreePhase where+  mapIndex _ = CTreeXCddl++instance IndexMappable XXType2 HuddleStage CTreePhase where+  mapIndex (HuddleXXType2 c) = CTreeXXType2 c++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+  mapIndex (HuddleXCddl c) = PrettyXCddl c++instance IndexMappable XXTopLevel HuddleStage PrettyStage where+  mapIndex (HuddleXXTopLevel c) = PrettyXXTopLevel c++instance IndexMappable XXType2 HuddleStage PrettyStage where+  mapIndex (HuddleXXType2 c) = absurd c++instance IndexMappable XTerm HuddleStage PrettyStage where+  mapIndex (HuddleXTerm c) = PrettyXTerm c++instance IndexMappable XRule HuddleStage PrettyStage where+  mapIndex (HuddleXRule c _) = PrettyXRule c++-- ParserStage -> ParserStage++instance IndexMappable XCddl ParserStage ParserStage++instance IndexMappable XXTopLevel ParserStage ParserStage++instance IndexMappable XXType2 ParserStage ParserStage++instance IndexMappable XTerm ParserStage ParserStage++instance IndexMappable XRule ParserStage ParserStage