diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 diff --git a/bin/Main.hs b/bin/Main.hs --- a/bin/Main.hs +++ b/bin/Main.hs @@ -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 diff --git a/cuddle.cabal b/cuddle.cabal --- a/cuddle.cabal +++ b/cuddle.cabal @@ -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, diff --git a/example/cddl-files/basic_assign.cddl b/example/cddl-files/basic_assign.cddl new file mode 100644 --- /dev/null +++ b/example/cddl-files/basic_assign.cddl @@ -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 = [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] +set2 = set + +coin_bag = set2 + +big_group = ( + "hello", + 32, + 8* 4, + & group, + uint, + unit_interval<3>, + 5 ...10, + h'11aaff3351bc' +) diff --git a/example/cddl-files/byron.cddl b/example/cddl-files/byron.cddl new file mode 100644 --- /dev/null +++ b/example/cddl-files/byron.cddl @@ -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] + ] diff --git a/example/cddl-files/conway.cddl b/example/cddl-files/conway.cddl new file mode 100644 --- /dev/null +++ b/example/cddl-files/conway.cddl @@ -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 = #6.258([* a]) / [* a] + +; Just like `set`, but must contain at least one element. +nonempty_set = #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 = #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 .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 ; 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 ; collateral inputs + , ? 14 : required_signers + , ? 15 : network_id + , ? 16 : transaction_output ; collateral return + , ? 17 : coin ; total collateral + , ? 18 : nonempty_set ; 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 + +certificates = nonempty_set + +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 => 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 + +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 + , 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 + , ? 1: nonempty_set + , ? 2: nonempty_set + , ? 3: nonempty_set + , ? 4: nonempty_set + , ? 5: redeemers + , ? 6: nonempty_set + , ? 7: nonempty_set + } + +; 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 +plutus_v2_script = distinct +plutus_v3_script = distinct + +plutus_data = + constr + / { * 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 = + #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 = { + 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] + +mint = multiasset + +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 ] diff --git a/example/cddl-files/costmdls_min.cddl b/example/cddl-files/costmdls_min.cddl new file mode 100644 --- /dev/null +++ b/example/cddl-files/costmdls_min.cddl @@ -0,0 +1,3 @@ +costmdls = + { 0 : [ 11* int ] ; Plutus v1, only 166 integers are used, but more are accepted (and ignored) + } diff --git a/example/cddl-files/issue80-min.cddl b/example/cddl-files/issue80-min.cddl new file mode 100644 --- /dev/null +++ b/example/cddl-files/issue80-min.cddl @@ -0,0 +1,8 @@ +main = test +set = [x] +test = [ + 1, + x, + set +] + diff --git a/example/cddl-files/pretty.cddl b/example/cddl-files/pretty.cddl new file mode 100644 --- /dev/null +++ b/example/cddl-files/pretty.cddl @@ -0,0 +1,13 @@ +set = [* a] + +a = [ 2*30 2 : uint + , ? 33 : bytes + , 4444 : set + , * 55 => uint + ] + +b = [1,uint,(3,4)] + +c = { 1: a +, 2: b ; hello +} diff --git a/example/cddl-files/shelley.cddl b/example/cddl-files/shelley.cddl new file mode 100644 --- /dev/null +++ b/example/cddl-files/shelley.cddl @@ -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 + , 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 + , 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] + +;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] + +address = bytes + +reward_account = bytes diff --git a/example/cddl-files/validator.cddl b/example/cddl-files/validator.cddl new file mode 100644 --- /dev/null +++ b/example/cddl-files/validator.cddl @@ -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 diff --git a/example/cddl-files/validator/negative/args-to-postlude.cddl b/example/cddl-files/validator/negative/args-to-postlude.cddl new file mode 100644 --- /dev/null +++ b/example/cddl-files/validator/negative/args-to-postlude.cddl @@ -0,0 +1,1 @@ +x = uint<3> diff --git a/example/cddl-files/validator/negative/too-few-args.cddl b/example/cddl-files/validator/negative/too-few-args.cddl new file mode 100644 --- /dev/null +++ b/example/cddl-files/validator/negative/too-few-args.cddl @@ -0,0 +1,3 @@ +foo = [a, b] + +x = foo diff --git a/example/cddl-files/validator/negative/too-many-args.cddl b/example/cddl-files/validator/negative/too-many-args.cddl new file mode 100644 --- /dev/null +++ b/example/cddl-files/validator/negative/too-many-args.cddl @@ -0,0 +1,3 @@ +foo = [a] + +x = foo diff --git a/example/cddl-files/validator/negative/unknown-name.cddl b/example/cddl-files/validator/negative/unknown-name.cddl new file mode 100644 --- /dev/null +++ b/example/cddl-files/validator/negative/unknown-name.cddl @@ -0,0 +1,1 @@ +x = a diff --git a/src/Codec/CBOR/Cuddle/CBOR/Gen.hs b/src/Codec/CBOR/Cuddle/CBOR/Gen.hs --- a/src/Codec/CBOR/Cuddle/CBOR/Gen.hs +++ b/src/Codec/CBOR/Cuddle/CBOR/Gen.hs @@ -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} diff --git a/src/Codec/CBOR/Cuddle/CBOR/Validator.hs b/src/Codec/CBOR/Cuddle/CBOR/Validator.hs --- a/src/Codec/CBOR/Cuddle/CBOR/Validator.hs +++ b/src/Codec/CBOR/Cuddle/CBOR/Validator.hs @@ -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 = - 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 = + 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 diff --git a/src/Codec/CBOR/Cuddle/CDDL.hs b/src/Codec/CBOR/Cuddle/CDDL.hs --- a/src/Codec/CBOR/Cuddle/CDDL.hs +++ b/src/Codec/CBOR/Cuddle/CDDL.hs @@ -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) diff --git a/src/Codec/CBOR/Cuddle/CDDL/CBORGenerator.hs b/src/Codec/CBOR/Cuddle/CDDL/CBORGenerator.hs new file mode 100644 --- /dev/null +++ b/src/Codec/CBOR/Cuddle/CDDL/CBORGenerator.hs @@ -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) diff --git a/src/Codec/CBOR/Cuddle/CDDL/CTree.hs b/src/Codec/CBOR/Cuddle/CDDL/CTree.hs --- a/src/Codec/CBOR/Cuddle/CDDL/CTree.hs +++ b/src/Codec/CBOR/Cuddle/CDDL/CTree.hs @@ -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 diff --git a/src/Codec/CBOR/Cuddle/CDDL/Postlude.hs b/src/Codec/CBOR/Cuddle/CDDL/Postlude.hs --- a/src/Codec/CBOR/Cuddle/CDDL/Postlude.hs +++ b/src/Codec/CBOR/Cuddle/CDDL/Postlude.hs @@ -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 + "" + " 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 diff --git a/src/Codec/CBOR/Cuddle/CDDL/Prelude.hs b/src/Codec/CBOR/Cuddle/CDDL/Prelude.hs deleted file mode 100644 --- a/src/Codec/CBOR/Cuddle/CDDL/Prelude.hs +++ /dev/null @@ -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 - "" - " 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 <>) diff --git a/src/Codec/CBOR/Cuddle/CDDL/Resolve.hs b/src/Codec/CBOR/Cuddle/CDDL/Resolve.hs --- a/src/Codec/CBOR/Cuddle/CDDL/Resolve.hs +++ b/src/Codec/CBOR/Cuddle/CDDL/Resolve.hs @@ -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 diff --git a/src/Codec/CBOR/Cuddle/Comments.hs b/src/Codec/CBOR/Cuddle/Comments.hs --- a/src/Codec/CBOR/Cuddle/Comments.hs +++ b/src/Codec/CBOR/Cuddle/Comments.hs @@ -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 = [] diff --git a/src/Codec/CBOR/Cuddle/Huddle.hs b/src/Codec/CBOR/Cuddle/Huddle.hs --- a/src/Codec/CBOR/Cuddle/Huddle.hs +++ b/src/Codec/CBOR/Cuddle/Huddle.hs @@ -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 diff --git a/src/Codec/CBOR/Cuddle/Huddle/HuddleM.hs b/src/Codec/CBOR/Cuddle/Huddle/HuddleM.hs --- a/src/Codec/CBOR/Cuddle/Huddle/HuddleM.hs +++ b/src/Codec/CBOR/Cuddle/Huddle/HuddleM.hs @@ -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" diff --git a/src/Codec/CBOR/Cuddle/Huddle/Optics.hs b/src/Codec/CBOR/Cuddle/Huddle/Optics.hs deleted file mode 100644 --- a/src/Codec/CBOR/Cuddle/Huddle/Optics.hs +++ /dev/null @@ -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" diff --git a/src/Codec/CBOR/Cuddle/IndexMappable.hs b/src/Codec/CBOR/Cuddle/IndexMappable.hs new file mode 100644 --- /dev/null +++ b/src/Codec/CBOR/Cuddle/IndexMappable.hs @@ -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 diff --git a/src/Codec/CBOR/Cuddle/Parser.hs b/src/Codec/CBOR/Cuddle/Parser.hs --- a/src/Codec/CBOR/Cuddle/Parser.hs +++ b/src/Codec/CBOR/Cuddle/Parser.hs @@ -1,12 +1,23 @@ {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeData #-} +{-# LANGUAGE TypeFamilies #-} module Codec.CBOR.Cuddle.Parser where import Codec.CBOR.Cuddle.CDDL import Codec.CBOR.Cuddle.CDDL.CtlOp (CtlOp) import Codec.CBOR.Cuddle.CDDL.CtlOp qualified as COp -import Codec.CBOR.Cuddle.Comments (Comment, WithComment (..), withComment, (!*>), (//-), (<*!)) +import Codec.CBOR.Cuddle.Comments ( + Comment, + HasComment (..), + WithComment (..), + withComment, + (!*>), + (//-), + (<*!), + ) import Codec.CBOR.Cuddle.Parser.Lexer ( Parser, charInRange, @@ -14,41 +25,70 @@ space, ) import Control.Applicative.Combinators.NonEmpty qualified as NE +import Data.ByteString.Base16 qualified as Base16 import Data.Foldable (Foldable (..)) import Data.Functor (void, ($>)) -import Data.List.NonEmpty (NonEmpty) +import Data.List.NonEmpty (NonEmpty (..)) import Data.List.NonEmpty qualified as NE import Data.Maybe (isJust) import Data.Text (Text) import Data.Text qualified as T import Data.Text.Encoding (encodeUtf8) +import Data.TreeDiff (ToExpr) +import Data.Void (Void) +import GHC.Generics (Generic) import GHC.Word (Word64, Word8) +import Optics.Core ((&), (.~)) import Text.Megaparsec import Text.Megaparsec.Char hiding (space) import Text.Megaparsec.Char qualified as C import Text.Megaparsec.Char.Lexer qualified as L -pCDDL :: Parser CDDL +type data ParserStage + +newtype instance XXTopLevel ParserStage = ParserXXTopLevel Comment + deriving (Generic, Show, Eq, ToExpr) + +newtype instance XXType2 ParserStage = ParserXXType2 Void + deriving (Generic, Show, Eq, ToExpr) + +newtype instance XTerm ParserStage = ParserXTerm {unParserXTerm :: Comment} + deriving (Generic, Semigroup, Monoid, Show, Eq, ToExpr) + +newtype instance XRule ParserStage = ParserXRule {unParserXRule :: Comment} + deriving (Generic, Semigroup, Monoid, Show, Eq, ToExpr) + +newtype instance XCddl ParserStage = ParserXCddl [Comment] + deriving (Generic, Semigroup, Monoid, Show, Eq, ToExpr) + +instance HasComment (XTerm ParserStage) where + commentL = #unParserXTerm + +instance HasComment (XRule ParserStage) where + commentL = #unParserXRule + +pCDDL :: Parser (CDDL ParserStage) pCDDL = do initialComments <- many (try $ C.space *> pCommentBlock <* notFollowedBy pRule) initialRuleComment <- C.space *> optional pCommentBlock initialRule <- pRule cddlTail <- many $ pTopLevel <* C.space - eof $> CDDL initialComments (initialRule //- fold initialRuleComment) cddlTail + eof + $> CDDL (initialRule //- fold initialRuleComment) cddlTail (ParserXXTopLevel <$> initialComments) -pTopLevel :: Parser TopLevel +pTopLevel :: Parser (TopLevel ParserStage) pTopLevel = try tlRule <|> tlComment where tlRule = do mCmt <- optional pCommentBlock rule <- pRule pure . TopLevelRule $ rule //- fold mCmt - tlComment = TopLevelComment <$> pCommentBlock + tlComment = XXTopLevel . ParserXXTopLevel <$> pCommentBlock -pRule :: Parser Rule +pRule :: Parser (Rule ParserStage) pRule = do name <- pName - genericParam <- optcomp pGenericParam + genericParam <- optcomp pGenericParameters cmt <- space (assign, typeOrGrp) <- choice @@ -59,13 +99,13 @@ <*> (TOGType <$> pType0 <* notFollowedBy (space >> (":" <|> "=>"))) , (,) <$> pAssignG <* space <*> (TOGGroup <$> pGrpEntry) ] - pure $ Rule name genericParam assign typeOrGrp cmt + pure $ Rule name genericParam assign typeOrGrp (ParserXRule cmt) pName :: Parser Name pName = label "name" $ do fc <- firstChar rest <- many midChar - pure $ (`Name` mempty) . T.pack $ (fc : rest) + pure $ Name . T.pack $ (fc : rest) where firstChar = letterChar <|> char '@' <|> char '_' <|> char '$' midChar = @@ -89,20 +129,23 @@ , AssignExt <$ "//=" ] -pGenericParam :: Parser GenericParam -pGenericParam = - GenericParam - <$> between "<" ">" (NE.sepBy1 (space !*> pName <*! space) ",") +pGenericParameter :: Parser (GenericParameter ParserStage) +pGenericParameter = GenericParameter <$> pName <*> pure mempty -pGenericArg :: Parser GenericArg +pGenericParameters :: Parser (GenericParameters ParserStage) +pGenericParameters = + GenericParameters + <$> between "<" ">" (NE.sepBy1 (space !*> pGenericParameter <*! space) ",") + +pGenericArg :: Parser (GenericArg ParserStage) pGenericArg = GenericArg <$> between "<" ">" (NE.sepBy1 (space !*> pType1 <*! space) ",") -pType0 :: Parser Type0 +pType0 :: Parser (Type0 ParserStage) pType0 = Type0 <$> sepBy1' (space !*> pType1 <*! space) (try "/") -pType1 :: Parser Type1 +pType1 :: Parser (Type1 ParserStage) pType1 = do v <- pType2 rest <- optional $ do @@ -115,18 +158,18 @@ pure (cmtFst, tyOp, cmtSnd, w) case rest of Just (cmtFst, tyOp, cmtSnd, w) -> - pure $ Type1 v (Just (tyOp, w)) $ cmtFst <> cmtSnd + pure $ Type1 v (Just (tyOp, w)) . ParserXTerm $ cmtFst <> cmtSnd Nothing -> pure $ Type1 v Nothing mempty -pType2 :: Parser Type2 +pType2 :: Parser (Type2 ParserStage) pType2 = choice [ T2Value <$> pValue , T2Name <$> pName <*> optional pGenericArg - , T2Group <$> label "group" ("(" *> space !*> pType0 <*! space <* ")") + , T2Group <$> label "group" ("(" *> pType0Cmt <* ")") , T2Map <$> label "map" ("{" *> pGroup <* "}") , T2Array <$> label "array" ("[" *> space !*> pGroup <*! space <* "]") - , T2Unwrapped <$> ("~" *> space !*> pName) <*> optional pGenericArg + , T2Unwrapped <$> ("~" *> space *> pName) <*> optional pGenericArg , do _ <- "&" cmt <- space @@ -141,11 +184,17 @@ mminor <- optional ("." *> L.decimal) let pTag - | major == 6 = T2Tag mminor <$> ("(" *> space !*> pType0 <*! space <* ")") + | major == 6 = T2Tag mminor <$> ("(" *> pType0Cmt <* ")") | otherwise = empty pTag <|> pure (T2DataItem major mminor) Nothing -> pure T2Any ] + where + pType0Cmt = do + pre <- space + Type0 (t :| ts) <- pType0 + post <- space + pure . Type0 $ (t & commentL .~ (pre <> post)) :| ts pHeadNumber :: Parser Word64 pHeadNumber = L.decimal @@ -176,13 +225,13 @@ ] ) -pGroup :: Parser Group +pGroup :: Parser (Group ParserStage) pGroup = Group <$> NE.sepBy1 (space !*> pGrpChoice) "//" -pGrpChoice :: Parser GrpChoice +pGrpChoice :: Parser (GrpChoice ParserStage) pGrpChoice = GrpChoice <$> many (space !*> pGrpEntry <*! pOptCom) <*> mempty -pGrpEntry :: Parser GroupEntry +pGrpEntry :: Parser (GroupEntry ParserStage) pGrpEntry = do occur <- optcomp pOccur cmt <- space @@ -195,9 +244,9 @@ , try $ withComment <$> (GERef <$> pName <*> optional pGenericArg) , withComment . GEGroup <$> ("(" *> space !*> pGroup <*! space <* ")") ] - pure $ GroupEntry occur (cmt <> cmt') variant + pure $ GroupEntry occur variant (ParserXTerm $ cmt <> cmt') -pMemberKey :: Parser (WithComment MemberKey) +pMemberKey :: Parser (WithComment (MemberKey ParserStage)) pMemberKey = choice [ try $ do @@ -238,6 +287,7 @@ , try pInt , try pBytes , pText + , try pBool ] where pSignedNum :: Num a => Parser a -> Parser (Bool, a) @@ -249,8 +299,12 @@ -- value. pInt = pSignedNum L.decimal >>= \case - (False, val) -> pure $ VUInt val - (True, val) -> pure $ VNInt val + (False, val) + | val < fromIntegral (maxBound @Word64) -> pure . VUInt $ fromIntegral val + | otherwise -> pure $ VBignum val + (True, val) + | val < fromIntegral (maxBound @Word64) -> pure . VNInt $ fromIntegral val + | otherwise -> pure . VBignum $ -val pFloat = pSignedNum L.float >>= \case (False, val) -> pure $ VFloat64 val @@ -275,7 +329,15 @@ <*> pure x pBytes = do _qualifier <- optional ("h" <|> "b64") - between "'" "'" $ VBytes . encodeUtf8 <$> pSByte + bytes <- between "'" "'" pSByte + case Base16.decode $ encodeUtf8 bytes of + Right x -> pure $ VBytes x + Left err -> fail err + pBool = label "boolean" $ do + b <- + (True <$ string "true") + <|> (False <$ string "false") + pure $ VBool b pTyOp :: Parser TyOp pTyOp = diff --git a/src/Codec/CBOR/Cuddle/Pretty.hs b/src/Codec/CBOR/Cuddle/Pretty.hs --- a/src/Codec/CBOR/Cuddle/Pretty.hs +++ b/src/Codec/CBOR/Cuddle/Pretty.hs @@ -1,13 +1,24 @@ {-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeData #-} +{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -Wno-orphans #-} -module Codec.CBOR.Cuddle.Pretty where +module Codec.CBOR.Cuddle.Pretty ( + CommentRender (..), + PrettyStage, + XXTopLevel (..), + XXType2 (..), + XTerm (..), + XCddl (..), + XRule (..), +) where import Codec.CBOR.Cuddle.CDDL import Codec.CBOR.Cuddle.CDDL.CtlOp (CtlOp) -import Codec.CBOR.Cuddle.Comments (CollectComments (..), Comment (..), unComment) +import Codec.CBOR.Cuddle.Comments (CollectComments (..), Comment (..), HasComment (..), unComment) import Codec.CBOR.Cuddle.Pretty.Columnar ( Cell (..), CellAlign (..), @@ -21,22 +32,52 @@ singletonRow, ) import Codec.CBOR.Cuddle.Pretty.Utils (renderedLen, softspace) +import Data.ByteString.Base16 qualified as B16 import Data.ByteString.Char8 qualified as BS +import Data.Default.Class (Default) import Data.Foldable (Foldable (..)) import Data.List.NonEmpty qualified as NE -import Data.String (fromString) +import Data.String (IsString, fromString) import Data.Text qualified as T +import Data.TreeDiff (ToExpr) +import Data.Void (Void, absurd) +import GHC.Generics (Generic) +import Optics.Core ((^.)) import Prettyprinter -instance Pretty CDDL where +type data PrettyStage + +newtype instance XXTopLevel PrettyStage = PrettyXXTopLevel Comment + deriving (Generic, CollectComments, ToExpr, Show, Eq) + +newtype instance XXType2 PrettyStage = PrettyXXType2 Void + deriving (Generic, CollectComments, ToExpr, Show, Eq) + +newtype instance XTerm PrettyStage = PrettyXTerm {unPrettyXTerm :: Comment} + deriving (Generic, CollectComments, Semigroup, Monoid, IsString, ToExpr, Show, Eq) + +newtype instance XCddl PrettyStage = PrettyXCddl [Comment] + deriving (Generic, CollectComments, ToExpr, Show, Eq) + +newtype instance XRule PrettyStage = PrettyXRule {unPrettyXRule :: Comment} + deriving (Generic, CollectComments, ToExpr, Show, Eq) + deriving newtype (Default) + +instance HasComment (XTerm PrettyStage) where + commentL = #unPrettyXTerm + +instance HasComment (XRule PrettyStage) where + commentL = #unPrettyXRule + +instance Pretty (CDDL PrettyStage) where pretty = vsep . fmap pretty . NE.toList . cddlTopLevel -instance Pretty TopLevel where - pretty (TopLevelComment cmt) = pretty cmt +instance Pretty (TopLevel PrettyStage) where + pretty (XXTopLevel (PrettyXXTopLevel cmt)) = pretty cmt pretty (TopLevelRule x) = pretty x <> hardline instance Pretty Name where - pretty (Name name cmt) = pretty name <> prettyCommentNoBreakWS cmt + pretty (Name name) = pretty name data CommentRender = PreComment @@ -54,12 +95,12 @@ pretty (Comment "") = mempty pretty c = prettyCommentNoBreak c <> hardline -type0Def :: Type0 -> Doc ann +type0Def :: Type0 PrettyStage -> Doc ann type0Def t = nest 2 $ line' <> pretty t -instance Pretty Rule where +instance Pretty (Rule PrettyStage) where pretty (Rule n mgen assign tog cmt) = - pretty cmt + pretty (cmt ^. commentL) <> groupIfNoComments tog ( pretty n <> pretty mgen <+> case tog of @@ -74,21 +115,24 @@ AssignEq -> "=" AssignExt -> "//=" -instance Pretty GenericArg where +instance Pretty (GenericArg PrettyStage) where pretty (GenericArg (NE.toList -> l)) | null (collectComments l) = group . cEncloseSep "<" ">" "," $ fmap pretty l | otherwise = columnarListing "<" ">" "," . Columnar $ singletonRow . pretty <$> l -instance Pretty GenericParam where - pretty (GenericParam (NE.toList -> l)) - | null (collectComments l) = group . cEncloseSep "<" ">" "," $ fmap pretty l +instance Pretty (GenericParameter PrettyStage) where + pretty (GenericParameter n (PrettyXTerm c)) = pretty n <> prettyCommentNoBreakWS c + +instance Pretty (GenericParameters PrettyStage) where + pretty (GenericParameters (NE.toList -> l)) + | null (collectComments l) = group . cEncloseSep "<" ">" "," $ pretty <$> l | otherwise = columnarListing "<" ">" "," . Columnar $ singletonRow . pretty <$> l -instance Pretty Type0 where +instance Pretty (Type0 PrettyStage) where pretty t0@(Type0 (NE.toList -> l)) = groupIfNoComments t0 $ columnarSepBy "/" . Columnar $ type1ToRow <$> l where - type1ToRow (Type1 t2 tyOp cmt) = + type1ToRow (Type1 t2 tyOp (PrettyXTerm cmt)) = let valCell = case tyOp of Nothing -> cellL t2 @@ -104,15 +148,15 @@ pretty (RangeOp Closed) = ".." pretty (CtrlOp n) = "." <> pretty n -instance Pretty Type1 where - pretty (Type1 t2 Nothing cmt) = groupIfNoComments t2 (pretty t2) <> prettyCommentNoBreakWS cmt - pretty (Type1 t2 (Just (tyop, t2')) cmt) = +instance Pretty (Type1 PrettyStage) where + pretty (Type1 t2 Nothing (PrettyXTerm cmt)) = groupIfNoComments t2 (pretty t2) <> prettyCommentNoBreakWS cmt + pretty (Type1 t2 (Just (tyop, t2')) (PrettyXTerm cmt)) = groupIfNoComments t2 (pretty t2) <+> pretty tyop <+> groupIfNoComments t2' (pretty t2') <> prettyCommentNoBreakWS cmt -instance Pretty Type2 where +instance Pretty (Type2 PrettyStage) where pretty (T2Value v) = pretty v pretty (T2Name n mg) = pretty n <> pretty mg pretty (T2Group g) = cEncloseSep "(" ")" mempty [pretty g] @@ -131,6 +175,7 @@ Nothing -> mempty Just minor -> "." <> pretty minor pretty T2Any = "#" + pretty (XXType2 (PrettyXXType2 v)) = absurd v instance Pretty OccurrenceIndicator where pretty OIOptional = "?" @@ -144,7 +189,7 @@ | AsArray | AsGroup -memberKeySep :: MemberKey -> Doc ann +memberKeySep :: MemberKey i -> Doc ann memberKeySep MKType {} = " => " memberKeySep _ = " : " @@ -165,10 +210,10 @@ | not (any (mempty /=) $ collectComments x) = group | otherwise = id -columnarGroupChoice :: GrpChoice -> Columnar ann +columnarGroupChoice :: GrpChoice PrettyStage -> Columnar ann columnarGroupChoice (GrpChoice ges _cmt) = Columnar grpEntryRows where - groupEntryRow (GroupEntry oi cmt gev) = + groupEntryRow (GroupEntry oi gev (PrettyXTerm cmt)) = Row $ [maybe emptyCell (\x -> Cell (pretty x <> space) LeftAlign) oi] <> groupEntryVariantCells gev @@ -179,7 +224,7 @@ groupEntryVariantCells (GEGroup g) = [Cell (prettyGroup AsGroup g) LeftAlign, emptyCell] grpEntryRows = groupEntryRow <$> ges -prettyGroup :: GroupRender -> Group -> Doc ann +prettyGroup :: GroupRender -> Group PrettyStage -> Doc ann prettyGroup gr g@(Group (toList -> xs)) = groupIfNoComments g . columnarListing (lEnc <> softspace) rEnc "// " . Columnar $ (\x -> singletonRow . groupIfNoComments x . columnarSepBy "," $ columnarGroupChoice x) <$> xs @@ -189,10 +234,10 @@ AsArray -> ("[", "]") AsGroup -> ("(", ")") -instance Pretty GroupEntry where +instance Pretty (GroupEntry PrettyStage) where pretty ge = prettyColumnar . columnarGroupChoice $ GrpChoice [ge] mempty -instance Pretty MemberKey where +instance Pretty (MemberKey PrettyStage) where pretty (MKType t1) = pretty t1 pretty (MKBareword n) = pretty n pretty (MKValue v) = pretty v @@ -208,6 +253,6 @@ pretty (VFloat32 i) = pretty i pretty (VFloat64 i) = pretty i pretty (VText t) = enclose "\"" "\"" $ pretty t - pretty (VBytes b) = fromString $ "h" <> "'" <> BS.unpack b <> "'" + pretty (VBytes b) = fromString $ "h" <> "'" <> BS.unpack (B16.encode b) <> "'" pretty (VBool True) = "true" pretty (VBool False) = "false" diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -2,7 +2,9 @@ import System.IO (BufferMode (..), hSetBuffering, hSetEncoding, stdout, utf8) import Test.Codec.CBOR.Cuddle.CDDL.Examples qualified as Examples +import Test.Codec.CBOR.Cuddle.CDDL.GeneratorSpec qualified as Generator import Test.Codec.CBOR.Cuddle.CDDL.Parser (parserSpec) +import Test.Codec.CBOR.Cuddle.CDDL.Validator qualified as Validator import Test.Codec.CBOR.Cuddle.Huddle (huddleSpec) import Test.Hspec import Test.Hspec.Runner @@ -18,6 +20,8 @@ hSetBuffering stdout LineBuffering hSetEncoding stdout utf8 hspecWith hspecConfig $ do - describe "cddlParser" parserSpec + describe "Parser" parserSpec describe "Huddle" huddleSpec describe "Examples" Examples.spec + describe "Generator" Generator.spec + describe "Validator" Validator.spec diff --git a/test/Test/Codec/CBOR/Cuddle/CDDL/Examples.hs b/test/Test/Codec/CBOR/Cuddle/CDDL/Examples.hs --- a/test/Test/Codec/CBOR/Cuddle/CDDL/Examples.hs +++ b/test/Test/Codec/CBOR/Cuddle/CDDL/Examples.hs @@ -1,27 +1,63 @@ +{-# LANGUAGE OverloadedStrings #-} + module Test.Codec.CBOR.Cuddle.CDDL.Examples (spec) where -import Codec.CBOR.Cuddle.CDDL.Prelude (prependPrelude) -import Codec.CBOR.Cuddle.CDDL.Resolve (fullResolveCDDL) +import Codec.CBOR.Cuddle.CDDL (Value (..), ValueVariant (..)) +import Codec.CBOR.Cuddle.CDDL.CTree (CTree (..), CTreeRoot, PTerm (..)) +import Codec.CBOR.Cuddle.CDDL.Postlude (appendPostlude) +import Codec.CBOR.Cuddle.CDDL.Resolve ( + MonoReferenced, + NameResolutionFailure (..), + fullResolveCDDL, + ) +import Codec.CBOR.Cuddle.IndexMappable (mapCDDLDropExt) import Codec.CBOR.Cuddle.Parser (pCDDL) -import Data.Either (isRight) import Data.Text.IO qualified as T +import Paths_cuddle (getDataFileName) +import Test.HUnit (assertFailure) import Test.Hspec import Text.Megaparsec (parse) import Text.Megaparsec.Error (errorBundlePretty) -validateFile :: FilePath -> Spec -validateFile filePath = it ("Successfully validates " <> filePath) $ do - contents <- T.readFile filePath +tryValidateFile :: FilePath -> IO (Either NameResolutionFailure (CTreeRoot MonoReferenced)) +tryValidateFile filePath = do + absoluteFilePath <- getDataFileName filePath + contents <- T.readFile absoluteFilePath cddl <- case parse pCDDL "" contents of - Right x -> pure $ prependPrelude x + Right x -> pure $ appendPostlude x Left x -> fail $ "Failed to parse the file:\n" <> errorBundlePretty x - fullResolveCDDL cddl `shouldSatisfy` isRight + pure . fullResolveCDDL $ mapCDDLDropExt cddl +validateExpectSuccess :: FilePath -> Spec +validateExpectSuccess filePath = it ("Successfully validates " <> filePath) $ do + res <- tryValidateFile filePath + case res of + Right _ -> pure () + Left err -> assertFailure $ "Failed to validate:\n" <> show err + +validateExpectFailure :: FilePath -> NameResolutionFailure -> Spec +validateExpectFailure filePath expectedFailure = it ("Fails to validate " <> filePath) $ do + res <- tryValidateFile filePath + case res of + Right _ -> assertFailure "Expected a failure, but succeeded instead" + Left e -> e `shouldBe` expectedFailure + spec :: Spec spec = do - validateFile "example/cddl-files/byron.cddl" - validateFile "example/cddl-files/conway.cddl" - validateFile "example/cddl-files/shelley.cddl" - --- TODO this one does not seem to terminate --- validateFile "example/cddl-files/basic_assign.cddl" + describe "Validator" $ do + describe "Positive" $ do + validateExpectSuccess "example/cddl-files/byron.cddl" + validateExpectSuccess "example/cddl-files/conway.cddl" + validateExpectSuccess "example/cddl-files/shelley.cddl" + validateExpectSuccess "example/cddl-files/basic_assign.cddl" + validateExpectSuccess "example/cddl-files/issue80-min.cddl" + validateExpectSuccess "example/cddl-files/pretty.cddl" + describe "Negative" $ do + validateExpectFailure "example/cddl-files/validator/negative/unknown-name.cddl" $ + UnboundReference "a" + validateExpectFailure "example/cddl-files/validator/negative/too-few-args.cddl" $ + MismatchingArgs "foo" ["a", "b"] + validateExpectFailure "example/cddl-files/validator/negative/too-many-args.cddl" $ + MismatchingArgs "foo" ["a"] + validateExpectFailure "example/cddl-files/validator/negative/args-to-postlude.cddl" $ + ArgsToPostlude PTUInt [Literal (Value (VUInt 3) mempty)] diff --git a/test/Test/Codec/CBOR/Cuddle/CDDL/Gen.hs b/test/Test/Codec/CBOR/Cuddle/CDDL/Gen.hs --- a/test/Test/Codec/CBOR/Cuddle/CDDL/Gen.hs +++ b/test/Test/Codec/CBOR/Cuddle/CDDL/Gen.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -Wno-orphans #-} @@ -7,6 +9,8 @@ import Codec.CBOR.Cuddle.CDDL import Codec.CBOR.Cuddle.CDDL.CtlOp import Codec.CBOR.Cuddle.Comments (Comment (..)) +import Codec.CBOR.Cuddle.Parser (ParserStage, XTerm (..)) +import Codec.CBOR.Cuddle.Pretty (PrettyStage, XRule (..), XTerm (..), XXTopLevel (..)) import Data.ByteString (ByteString) import Data.ByteString qualified as BS import Data.List.NonEmpty qualified as NE @@ -15,18 +19,26 @@ import Test.QuickCheck import Test.QuickCheck qualified as Gen -instance Arbitrary CDDL where +instance Arbitrary (CDDL PrettyStage) where arbitrary = CDDL <$> arbitrary <*> arbitrary <*> arbitrary shrink = genericShrink -instance Arbitrary TopLevel where +deriving newtype instance Arbitrary (XXTopLevel PrettyStage) + +deriving newtype instance Arbitrary (XTerm PrettyStage) + +deriving newtype instance Arbitrary (XRule PrettyStage) + +instance Arbitrary (TopLevel PrettyStage) where arbitrary = Gen.oneof - [ TopLevelComment <$> arbitrary + [ XXTopLevel <$> arbitrary , TopLevelRule <$> arbitrary ] shrink = genericShrink +deriving newtype instance Arbitrary (XTerm ParserStage) + instance Arbitrary T.Text where arbitrary = T.pack <$> arbitrary shrink = fmap T.pack . shrink . T.unpack @@ -55,12 +67,10 @@ fstChar <- elements nameFstChars midChar <- veryShortListOf . elements $ nameMidChars lastChar <- elements nameEndChars - pure $ Name (T.pack $ fstChar : midChar <> [lastChar]) mempty + pure $ Name (T.pack $ fstChar : midChar <> [lastChar]) - shrink (Name xs cmt) = - Name - <$> fmap T.pack (filter isValidName (shrink $ T.unpack xs)) - <*> shrink cmt + shrink (Name xs) = + Name <$> fmap T.pack (filter isValidName (shrink $ T.unpack xs)) where isValidName [] = False isValidName (h : tl) = h `elem` nameFstChars && isValidNameTail tl @@ -73,15 +83,24 @@ arbitrary = Gen.elements [AssignEq, AssignExt] shrink = genericShrink -instance Arbitrary GenericParam where - arbitrary = GenericParam <$> nonEmpty arbitrary - shrink (GenericParam neName) = GenericParam <$> shrinkNE neName +instance Arbitrary (XTerm i) => Arbitrary (GenericParameter i) where + arbitrary = GenericParameter <$> arbitrary <*> arbitrary -instance Arbitrary GenericArg where +instance (Monoid (XTerm i), Arbitrary (XTerm i)) => Arbitrary (GenericParameters i) where + arbitrary = GenericParameters <$> nonEmpty arbitrary + shrink (GenericParameters neName) = GenericParameters <$> shrinkNE neName + +instance (Arbitrary (XTerm i), Monoid (XTerm i)) => Arbitrary (GenericArg i) where arbitrary = GenericArg <$> nonEmpty arbitrary shrink (GenericArg neArg) = GenericArg <$> shrinkNE neArg -instance Arbitrary Rule where +instance + ( Monoid (XTerm i) + , Arbitrary (XTerm i) + , Arbitrary (XRule i) + ) => + Arbitrary (Rule i) + where arbitrary = Rule <$> arbitrary @@ -103,7 +122,12 @@ ] shrink = genericShrink -instance Arbitrary TypeOrGroup where +instance + ( Arbitrary (XTerm i) + , Monoid (XTerm i) + ) => + Arbitrary (TypeOrGroup i) + where arbitrary = Gen.oneof [ TOGGroup <$> arbitrary @@ -111,15 +135,15 @@ ] shrink = genericShrink -instance Arbitrary Type0 where +instance (Arbitrary (XTerm i), Monoid (XTerm i)) => Arbitrary (Type0 i) where arbitrary = Type0 <$> nonEmpty arbitrary shrink (Type0 neType1) = Type0 <$> shrinkNE neType1 -instance Arbitrary Type1 where +instance (Arbitrary (XTerm i), Monoid (XTerm i)) => Arbitrary (Type1 i) where arbitrary = Type1 <$> arbitrary <*> arbitrary <*> arbitrary shrink = genericShrink -instance Arbitrary Type2 where +instance (Monoid (XTerm i), Arbitrary (XTerm i)) => Arbitrary (Type2 i) where arbitrary = recursive Gen.oneof @@ -138,7 +162,6 @@ [ T2Group <$> arbitrary , T2Tag <$> arbitrary <*> arbitrary ] - shrink = genericShrink instance Arbitrary OccurrenceIndicator where arbitrary = @@ -153,15 +176,15 @@ shrink = genericShrink -instance Arbitrary Group where +instance (Monoid (XTerm i), Arbitrary (XTerm i)) => Arbitrary (Group i) where arbitrary = Group <$> nonEmpty arbitrary shrink (Group gr) = Group <$> shrinkNE gr -instance Arbitrary GrpChoice where +instance (Monoid (XTerm i), Arbitrary (XTerm i)) => Arbitrary (GrpChoice i) where arbitrary = GrpChoice <$> listOf' arbitrary <*> pure mempty shrink = genericShrink -instance Arbitrary GroupEntryVariant where +instance (Monoid (XTerm i), Arbitrary (XTerm i)) => Arbitrary (GroupEntryVariant i) where arbitrary = recursive Gen.oneof @@ -176,15 +199,20 @@ ] shrink = genericShrink -instance Arbitrary GroupEntry where +instance + ( Arbitrary (XTerm i) + , Monoid (XTerm i) + ) => + Arbitrary (GroupEntry i) + where arbitrary = GroupEntry <$> arbitrary - <*> pure mempty <*> arbitrary + <*> pure mempty shrink = genericShrink -instance Arbitrary MemberKey where +instance (Monoid (XTerm i), Arbitrary (XTerm i)) => Arbitrary (MemberKey i) where arbitrary = recursive Gen.oneof diff --git a/test/Test/Codec/CBOR/Cuddle/CDDL/GeneratorSpec.hs b/test/Test/Codec/CBOR/Cuddle/CDDL/GeneratorSpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/Codec/CBOR/Cuddle/CDDL/GeneratorSpec.hs @@ -0,0 +1,66 @@ +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE OverloadedStrings #-} + +module Test.Codec.CBOR.Cuddle.CDDL.GeneratorSpec (spec) where + +import Codec.CBOR.Cuddle.CBOR.Gen (generateCBORTerm) +import Codec.CBOR.Cuddle.CDDL.CBORGenerator (WrappedTerm (..)) +import Codec.CBOR.Cuddle.CDDL.Resolve (fullResolveCDDL) +import Codec.CBOR.Cuddle.Huddle ( + Huddle, + HuddleItem (..), + a, + arr, + collectFrom, + toCDDL, + withGenerator, + (=:=), + ) +import Codec.CBOR.Cuddle.Huddle qualified as H +import Codec.CBOR.Cuddle.IndexMappable (mapCDDLDropExt) +import Codec.CBOR.Term (Term) +import Codec.CBOR.Term qualified as C +import System.Random (mkStdGen) +import System.Random.Stateful (UniformRange (..)) +import Test.Hspec (Expectation, Spec, describe, it, shouldBe) + +foo :: H.Rule +foo = withGenerator (fmap (S . C.TInt) . uniformRM (4, 6)) $ "foo" =:= arr [1, 2, 3] + +simpleTermExample :: Huddle +simpleTermExample = + collectFrom + [ HIRule foo + ] + +refTermExample :: Huddle +refTermExample = + collectFrom + [ HIRule foo + , HIRule $ "bar" =:= arr [0, a foo] + ] + +bytesExample :: Huddle +bytesExample = + collectFrom + [ HIRule $ "foo" =:= H.bstr "010203ff" + ] + +huddleShouldGenerate :: Huddle -> Term -> Expectation +huddleShouldGenerate huddle term = do + let g = mkStdGen 12345 + ct <- case fullResolveCDDL . mapCDDLDropExt $ toCDDL huddle of + Right x -> pure x + Left err -> fail $ "Failed to resolve CDDL: " <> show err + generateCBORTerm ct "foo" g `shouldBe` term + +spec :: Spec +spec = do + describe "Custom generators" $ do + describe "Huddle" $ do + it "If a term has a custom generator then it is used" $ + simpleTermExample `huddleShouldGenerate` C.TInt 5 + it "Custom generator works when called via reference" $ + refTermExample `huddleShouldGenerate` C.TInt 5 + it "Bytes are generated correctly" $ + bytesExample `huddleShouldGenerate` C.TBytes "\x01\x02\x03\xff" diff --git a/test/Test/Codec/CBOR/Cuddle/CDDL/Parser.hs b/test/Test/Codec/CBOR/Cuddle/CDDL/Parser.hs --- a/test/Test/Codec/CBOR/Cuddle/CDDL/Parser.hs +++ b/test/Test/Codec/CBOR/Cuddle/CDDL/Parser.hs @@ -4,11 +4,10 @@ import Codec.CBOR.Cuddle.CDDL import Codec.CBOR.Cuddle.CDDL.CtlOp qualified as CtlOp -import Codec.CBOR.Cuddle.Comments (Comment (..)) +import Codec.CBOR.Cuddle.IndexMappable (IndexMappable (..)) import Codec.CBOR.Cuddle.Parser import Codec.CBOR.Cuddle.Parser.Lexer (Parser) -import Codec.CBOR.Cuddle.Pretty () -import Data.Default.Class (Default (..)) +import Codec.CBOR.Cuddle.Pretty (PrettyStage) import Data.List.NonEmpty (NonEmpty (..)) import Data.Text qualified as T import Data.TreeDiff (ToExpr (..), ansiWlBgEditExprCompact, exprDiff) @@ -38,9 +37,9 @@ roundtripSpec = describe "Roundtripping should be id" $ do it "Trip Name" $ trip pName xit "Trip Value" $ trip pValue - xit "Trip Type0" $ trip pType0 - xit "Trip GroupEntry" $ trip pGrpEntry - xit "Trip Rule" $ trip pRule + xit "Trip Type0" $ tripIndexed pType0 + xit "Trip GroupEntry" $ tripIndexed pGrpEntry + xit "Trip Rule" $ tripIndexed pRule where -- We show that, for a printed CDDL document p, print (parse p) == p. Note -- that we do not show that parse (print p) is p for a given generated @@ -60,6 +59,17 @@ toExpr x `exprDiff` toExpr parsed ) $ printed `shouldBe` printText parsed + tripIndexed :: + forall a. + ( IndexMappable a ParserStage PrettyStage + , Eq (a PrettyStage) + , ToExpr (a PrettyStage) + , Show (a PrettyStage) + , Pretty (a PrettyStage) + , Arbitrary (a PrettyStage) + ) => + Parser (a ParserStage) -> Property + tripIndexed = trip . fmap (mapIndex @a @ParserStage @PrettyStage) printText :: Pretty a => a -> T.Text printText = renderStrict . layoutPretty defaultLayoutOptions . pretty @@ -73,6 +83,9 @@ parse pValue "" "3.1415" `shouldParse` value (VFloat64 3.1415) it "Parses text" $ parse pValue "" "\"Hello World\"" `shouldParse` value (VText "Hello World") + it "Parses boolean" $ do + parse pValue "" "true" `shouldParse` value (VBool True) + parse pValue "" "false" `shouldParse` value (VBool False) occurSpec :: Spec occurSpec = describe "pOccur" $ do @@ -95,11 +108,11 @@ nameSpec :: SpecWith () nameSpec = describe "pName" $ do it "Parses a boring name" $ - parse pName "" "coin" `shouldParse` Name "coin" mempty + parse pName "" "coin" `shouldParse` Name "coin" it "Allows . in the middle" $ - parse pName "" "coin.me" `shouldParse` Name "coin.me" mempty + parse pName "" "coin.me" `shouldParse` Name "coin.me" it "Allows $ as the last character" $ - parse pName "" "coin.me$" `shouldParse` Name "coin.me$" mempty + parse pName "" "coin.me$" `shouldParse` Name "coin.me$" it "Doesn't allow . as a last character" $ parse pName "" "coin." `shouldFailWith` err 5 ueof @@ -108,14 +121,14 @@ it "Parses a simple value generic" $ parse pRule "" "a = b<0>" `shouldParse` Rule - (Name "a" mempty) + (Name "a") Nothing AssignEq ( TOGType ( Type0 ( Type1 ( T2Name - (Name "b" mempty) + (Name "b") ( Just ( GenericArg ( Type1 @@ -137,14 +150,14 @@ it "Parses a range as a generic" $ parse pRule "" "a = b<0 ... 1>" `shouldParse` Rule - (Name "a" mempty) + (Name "a") Nothing AssignEq ( TOGType ( Type0 ( Type1 ( T2Name - (Name "b" mempty) + (Name "b") ( Just ( GenericArg ( Type1 @@ -167,8 +180,12 @@ type2Spec :: SpecWith () type2Spec = describe "type2" $ do describe "Value" $ do - it "Parses a value" $ + it "Parses a value" $ do parse pType2 "" "123" `shouldParse` T2Value (value $ VUInt 123) + parse pType2 "" "true" `shouldParse` T2Value (value $ VBool True) + parse pType2 "" "false" `shouldParse` T2Value (value $ VBool False) + parse pType2 "" "h'0042ff'" + `shouldParse` T2Value (value $ VBytes "\x00\x42\xff") describe "Map" $ do it "Parses a basic group" $ parse pType2 "" "{ int => string }" @@ -179,15 +196,15 @@ { gcGroupEntries = [ GroupEntry { geOccurrenceIndicator = Nothing - , geComment = Comment mempty + , geExt = mempty , geVariant = GEType ( Just ( MKType ( Type1 - { t1Main = T2Name (Name {name = "int", nameComment = Comment mempty}) Nothing + { t1Main = T2Name "int" Nothing , t1TyOp = Nothing - , t1Comment = Comment mempty + , t1Comment = mempty } ) ) @@ -195,16 +212,16 @@ ( Type0 { t0Type1 = Type1 - { t1Main = T2Name (Name {name = "string", nameComment = Comment mempty}) Nothing + { t1Main = T2Name "string" Nothing , t1TyOp = Nothing - , t1Comment = Comment mempty + , t1Comment = mempty } :| [] } ) } ] - , gcComment = Comment mempty + , gcComment = mempty } :| [] } @@ -218,15 +235,15 @@ { gcGroupEntries = [ GroupEntry { geOccurrenceIndicator = Just OIZeroOrMore - , geComment = Comment mempty + , geExt = mempty , geVariant = GEType ( Just ( MKType ( Type1 - { t1Main = T2Name (Name {name = "int", nameComment = Comment mempty}) Nothing + { t1Main = T2Name "int" Nothing , t1TyOp = Nothing - , t1Comment = Comment mempty + , t1Comment = mempty } ) ) @@ -234,16 +251,16 @@ ( Type0 { t0Type1 = Type1 - { t1Main = T2Name (Name {name = "string", nameComment = Comment mempty}) Nothing + { t1Main = T2Name "string" Nothing , t1TyOp = Nothing - , t1Comment = Comment mempty + , t1Comment = mempty } :| [] } ) } ] - , gcComment = Comment mempty + , gcComment = mempty } :| [] } @@ -257,18 +274,18 @@ { gcGroupEntries = [ GroupEntry { geOccurrenceIndicator = Nothing - , geComment = Comment mempty + , geExt = mempty , geVariant = GEType ( Just - (MKType (Type1 {t1Main = T2Value (value $ VUInt 1), t1TyOp = Nothing, t1Comment = Comment mempty})) + (MKType (Type1 {t1Main = T2Value (value $ VUInt 1), t1TyOp = Nothing, t1Comment = mempty})) ) ( Type0 { t0Type1 = Type1 - { t1Main = T2Name (Name {name = "string", nameComment = Comment mempty}) Nothing + { t1Main = T2Name "string" Nothing , t1TyOp = Nothing - , t1Comment = Comment mempty + , t1Comment = mempty } :| [] } @@ -276,18 +293,18 @@ } , GroupEntry { geOccurrenceIndicator = Nothing - , geComment = Comment mempty + , geExt = mempty , geVariant = GEType ( Just - (MKType (Type1 {t1Main = T2Value (value $ VUInt 2), t1TyOp = Nothing, t1Comment = Comment mempty})) + (MKType (Type1 {t1Main = T2Value (value $ VUInt 2), t1TyOp = Nothing, t1Comment = mempty})) ) ( Type0 { t0Type1 = Type1 - { t1Main = T2Name (Name {name = "int", nameComment = Comment mempty}) Nothing + { t1Main = T2Name "int" Nothing , t1TyOp = Nothing - , t1Comment = Comment mempty + , t1Comment = mempty } :| [] } @@ -295,25 +312,25 @@ } , GroupEntry { geOccurrenceIndicator = Nothing - , geComment = Comment mempty + , geExt = mempty , geVariant = GEType ( Just - (MKType (Type1 {t1Main = T2Value (value $ VUInt 3), t1TyOp = Nothing, t1Comment = Comment mempty})) + (MKType (Type1 {t1Main = T2Value (value $ VUInt 3), t1TyOp = Nothing, t1Comment = mempty})) ) ( Type0 { t0Type1 = Type1 - { t1Main = T2Name (Name {name = "bytes", nameComment = Comment mempty}) Nothing + { t1Main = T2Name "bytes" Nothing , t1TyOp = Nothing - , t1Comment = Comment mempty + , t1Comment = mempty } :| [] } ) } ] - , gcComment = Comment mempty + , gcComment = mempty } :| [] } @@ -328,45 +345,45 @@ { gcGroupEntries = [ GroupEntry { geOccurrenceIndicator = Nothing - , geComment = Comment mempty + , geExt = mempty , geVariant = GEType Nothing ( Type0 { t0Type1 = Type1 - { t1Main = T2Name (Name {name = "int", nameComment = Comment mempty}) Nothing + { t1Main = T2Name "int" Nothing , t1TyOp = Nothing - , t1Comment = Comment mempty + , t1Comment = mempty } :| [] } ) } ] - , gcComment = Comment mempty + , gcComment = mempty } :| [ GrpChoice { gcGroupEntries = [ GroupEntry { geOccurrenceIndicator = Nothing - , geComment = Comment mempty + , geExt = mempty , geVariant = GEType Nothing ( Type0 { t0Type1 = Type1 - { t1Main = T2Name (Name {name = "string", nameComment = Comment mempty}) Nothing + { t1Main = T2Name "string" Nothing , t1TyOp = Nothing - , t1Comment = Comment mempty + , t1Comment = mempty } :| [] } ) } ] - , gcComment = Comment mempty + , gcComment = mempty } ] } @@ -381,35 +398,35 @@ { gcGroupEntries = [ GroupEntry { geOccurrenceIndicator = Nothing - , geComment = Comment mempty + , geExt = mempty , geVariant = GEType Nothing ( Type0 { t0Type1 = - Type1 {t1Main = T2Value (value $ VUInt 0), t1TyOp = Nothing, t1Comment = Comment mempty} :| [] + Type1 {t1Main = T2Value (value $ VUInt 0), t1TyOp = Nothing, t1Comment = mempty} :| [] } ) } ] - , gcComment = Comment mempty + , gcComment = mempty } :| [ GrpChoice { gcGroupEntries = [ GroupEntry { geOccurrenceIndicator = Nothing - , geComment = Comment mempty + , geExt = mempty , geVariant = GEType Nothing ( Type0 { t0Type1 = - Type1 {t1Main = T2Value (value $ VUInt 1), t1TyOp = Nothing, t1Comment = Comment mempty} :| [] + Type1 {t1Main = T2Value (value $ VUInt 1), t1TyOp = Nothing, t1Comment = mempty} :| [] } ) } ] - , gcComment = Comment mempty + , gcComment = mempty } ] } @@ -423,18 +440,18 @@ { gcGroupEntries = [ GroupEntry { geOccurrenceIndicator = Nothing - , geComment = Comment mempty + , geExt = mempty , geVariant = GEType Nothing ( Type0 { t0Type1 = - Type1 {t1Main = T2Value (value $ VUInt 1), t1TyOp = Nothing, t1Comment = Comment mempty} :| [] + Type1 {t1Main = T2Value (value $ VUInt 1), t1TyOp = Nothing, t1Comment = mempty} :| [] } ) } ] - , gcComment = Comment mempty + , gcComment = mempty } :| [] } @@ -448,35 +465,35 @@ { gcGroupEntries = [ GroupEntry { geOccurrenceIndicator = Nothing - , geComment = Comment mempty + , geExt = mempty , geVariant = GEType Nothing ( Type0 { t0Type1 = - Type1 {t1Main = T2Value (value $ VUInt 2), t1TyOp = Nothing, t1Comment = Comment mempty} :| [] + Type1 {t1Main = T2Value (value $ VUInt 2), t1TyOp = Nothing, t1Comment = mempty} :| [] } ) } , GroupEntry { geOccurrenceIndicator = Nothing - , geComment = Comment mempty + , geExt = mempty , geVariant = GEType Nothing ( Type0 { t0Type1 = Type1 - { t1Main = T2Name (Name {name = "soon", nameComment = Comment mempty}) Nothing + { t1Main = T2Name "soon" Nothing , t1TyOp = Nothing - , t1Comment = Comment mempty + , t1Comment = mempty } :| [] } ) } ] - , gcComment = Comment mempty + , gcComment = mempty } :| [] } @@ -488,16 +505,16 @@ parse pGrpEntry "" "int" `shouldParse` GroupEntry { geOccurrenceIndicator = Nothing - , geComment = Comment mempty + , geExt = mempty , geVariant = GEType Nothing ( Type0 { t0Type1 = Type1 - { t1Main = T2Name (Name {name = "int", nameComment = Comment mempty}) Nothing + { t1Main = T2Name "int" Nothing , t1TyOp = Nothing - , t1Comment = Comment mempty + , t1Comment = mempty } :| [] } @@ -507,16 +524,16 @@ parse pGrpEntry "" "int // notConsideredHere" `shouldParse` GroupEntry { geOccurrenceIndicator = Nothing - , geComment = Comment mempty + , geExt = mempty , geVariant = GEType Nothing ( Type0 { t0Type1 = Type1 - { t1Main = T2Name (Name {name = "int", nameComment = Comment mempty}) Nothing + { t1Main = T2Name "int" Nothing , t1TyOp = Nothing - , t1Comment = Comment mempty + , t1Comment = mempty } :| [] } @@ -526,7 +543,7 @@ parse pGrpEntry "" "a<0 ... #6(0)>" `shouldParse` GroupEntry { geOccurrenceIndicator = Nothing - , geComment = Comment mempty + , geExt = mempty , geVariant = GEType Nothing @@ -535,7 +552,7 @@ Type1 { t1Main = T2Name - (Name {name = "a", nameComment = Comment mempty}) + "a" ( Just ( GenericArg ( Type1 @@ -547,18 +564,18 @@ Nothing ( Type0 { t0Type1 = - Type1 {t1Main = T2Value (value $ VUInt 0), t1TyOp = Nothing, t1Comment = Comment mempty} :| [] + Type1 {t1Main = T2Value (value $ VUInt 0), t1TyOp = Nothing, t1Comment = mempty} :| [] } ) ) - , t1Comment = Comment mempty + , t1Comment = mempty } :| [] ) ) ) , t1TyOp = Nothing - , t1Comment = Comment mempty + , t1Comment = mempty } :| [] } @@ -568,28 +585,31 @@ parse pGrpEntry "" "0* a" `shouldParse` GroupEntry (Just (OIBounded (Just 0) Nothing)) - def ( GEType Nothing - (Type0 (Type1 (T2Name (Name "a" mempty) Nothing) Nothing mempty :| [])) + (Type0 (Type1 (T2Name (Name "a") Nothing) Nothing mempty :| [])) ) + mempty grpChoiceSpec :: SpecWith () grpChoiceSpec = describe "GroupChoice" $ do it "Should parse part of a group alternative" $ parse pGrpChoice "" "int // string" `shouldParse` GrpChoice - [ GroupEntry Nothing mempty $ - GEType - Nothing - ( Type0 - ( Type1 - (T2Name (Name "int" mempty) Nothing) - Nothing - mempty - :| [] - ) - ) + [ GroupEntry + Nothing + ( GEType + Nothing + ( Type0 + ( Type1 + (T2Name (Name "int") Nothing) + Nothing + mempty + :| [] + ) + ) + ) + mempty ] mempty @@ -599,7 +619,7 @@ it "Should parse a basic control operator" $ parse pType1 "" "uint .size 3" `shouldParse` Type1 - (T2Name (Name "uint" mempty) Nothing) + (T2Name (Name "uint") Nothing) (Just (CtrlOp CtlOp.Size, T2Value (value $ VUInt 3))) mempty describe "RangeOp" $ do @@ -629,36 +649,38 @@ Type1 { t1Main = T2Map - (Group {unGroup = GrpChoice {gcGroupEntries = [], gcComment = Comment mempty} :| []}) + (Group {unGroup = GrpChoice {gcGroupEntries = [], gcComment = mempty} :| []}) , t1TyOp = Just ( CtrlOp CtlOp.Ge , T2EnumRef - (Name {name = "i", nameComment = Comment mempty}) + "i" ( Just ( GenericArg ( Type1 { t1Main = T2Map - (Group {unGroup = GrpChoice {gcGroupEntries = [], gcComment = Comment mempty} :| []}) + (Group {unGroup = GrpChoice {gcGroupEntries = [], gcComment = mempty} :| []}) , t1TyOp = Nothing - , t1Comment = Comment mempty + , t1Comment = mempty } - :| [Type1 {t1Main = T2Value (value $ VUInt 3), t1TyOp = Nothing, t1Comment = Comment mempty}] + :| [Type1 {t1Main = T2Value (value $ VUInt 3), t1TyOp = Nothing, t1Comment = mempty}] ) ) ) ) - , t1Comment = Comment mempty + , t1Comment = mempty } parseExample "S = 0* ()" pRule $ Rule - (Name "S" mempty) + (Name "S") Nothing AssignEq ( TOGGroup - ( GroupEntry (Just (OIBounded (Just 0) Nothing)) mempty $ - GEGroup (Group (GrpChoice mempty mempty :| [])) + ( GroupEntry + (Just (OIBounded (Just 0) Nothing)) + (GEGroup (Group (GrpChoice mempty mempty :| []))) + mempty ) ) mempty @@ -666,16 +688,17 @@ "W = \"6 ybe2ddl8frq0vqa8zgrk07khrljq7p plrufpd1sff3p95\" : \"u\"" pRule ( Rule - (Name "W" mempty) + (Name "W") Nothing AssignEq ( TOGGroup ( GroupEntry Nothing + ( GEType + (Just (MKValue (value $ VText "6 ybe2ddl8frq0vqa8zgrk07khrljq7p plrufpd1sff3p95"))) + (Type0 (Type1 (T2Value (value $ VText "u")) Nothing mempty :| [])) + ) mempty - $ GEType - (Just (MKValue (value $ VText "6 ybe2ddl8frq0vqa8zgrk07khrljq7p plrufpd1sff3p95"))) - (Type0 (Type1 (T2Value (value $ VText "u")) Nothing mempty :| [])) ) ) mempty diff --git a/test/Test/Codec/CBOR/Cuddle/CDDL/Pretty.hs b/test/Test/Codec/CBOR/Cuddle/CDDL/Pretty.hs --- a/test/Test/Codec/CBOR/Cuddle/CDDL/Pretty.hs +++ b/test/Test/Codec/CBOR/Cuddle/CDDL/Pretty.hs @@ -9,7 +9,7 @@ import Codec.CBOR.Cuddle.CDDL ( Assign (..), CDDL, - Group (Group), + Group (..), GroupEntry (..), GroupEntryVariant (..), GrpChoice (..), @@ -22,7 +22,11 @@ ValueVariant (..), value, ) -import Codec.CBOR.Cuddle.Pretty () +import Codec.CBOR.Cuddle.Huddle (HuddleItem (..), a, bstr, (<+), (=:=), (=:~)) +import Codec.CBOR.Cuddle.Huddle qualified as H +import Codec.CBOR.Cuddle.IndexMappable (IndexMappable (..)) +import Codec.CBOR.Cuddle.Pretty (PrettyStage, XRule (..)) +import Data.Default.Class (Default (..)) import Data.List.NonEmpty (NonEmpty (..)) import Data.Text qualified as T import Data.TreeDiff (ToExpr (..), prettyExpr) @@ -40,13 +44,13 @@ where rendered = renderString (layoutPretty defaultLayoutOptions (pretty x)) -t2Name :: Type2 -t2Name = T2Name (Name "a" mempty) mempty +t2Name :: Type2 PrettyStage +t2Name = T2Name (Name "a") mempty -t1Name :: Type1 +t1Name :: Type1 PrettyStage t1Name = Type1 t2Name Nothing mempty -mkType0 :: Type2 -> Type0 +mkType0 :: Type2 PrettyStage -> Type0 PrettyStage mkType0 t2 = Type0 $ Type1 t2 Nothing mempty :| [] spec :: Spec @@ -56,14 +60,14 @@ qcSpec :: Spec qcSpec = describe "QuickCheck" $ do - xprop "CDDL prettyprinter leaves no trailing spaces" $ \(cddl :: CDDL) -> do + xprop "CDDL prettyprinter leaves no trailing spaces" $ \(cddl :: CDDL PrettyStage) -> do let prettyStr = T.pack . renderString . layoutPretty defaultLayoutOptions $ pretty cddl stripLines = T.unlines . fmap T.stripEnd . T.lines counterexample (show . prettyExpr $ toExpr cddl) $ prettyStr `shouldBe` stripLines prettyStr -drep :: Rule +drep :: Rule PrettyStage drep = Rule "drep" @@ -77,37 +81,37 @@ ( GrpChoice [ GroupEntry Nothing - mempty (GEType Nothing (Type0 $ Type1 (T2Value . value $ VUInt 0) Nothing mempty :| [])) + mempty , GroupEntry Nothing - mempty (GEType Nothing (Type0 $ Type1 (T2Name "addr_keyhash" Nothing) Nothing mempty :| [])) + mempty ] mempty :| [ GrpChoice [ GroupEntry Nothing - mempty (GEType Nothing (Type0 $ Type1 (T2Value . value $ VUInt 1) Nothing mempty :| [])) + mempty , GroupEntry Nothing - mempty (GEType Nothing (Type0 $ Type1 (T2Name "script_hash" Nothing) Nothing mempty :| [])) + mempty ] mempty , GrpChoice [ GroupEntry Nothing - mempty (GEType Nothing (Type0 $ Type1 (T2Value . value $ VUInt 2) Nothing mempty :| [])) + mempty ] mempty , GrpChoice [ GroupEntry Nothing - mempty (GEType Nothing (Type0 $ Type1 (T2Value . value $ VUInt 3) Nothing mempty :| [])) + mempty ] mempty ] @@ -120,68 +124,128 @@ ) ) ) - mempty + def unitSpec :: Spec unitSpec = describe "HUnit" $ do - describe "Name" $ do - it "names" $ Name "a" mempty `prettyPrintsTo` "a" - describe "Type0" $ do - it "name" $ Type0 (t1Name :| []) `prettyPrintsTo` "a" - describe "Type1" $ do - it "name" $ t1Name `prettyPrintsTo` "a" - describe "Type2" $ do - it "T2Name" $ t2Name `prettyPrintsTo` "a" - describe "T2Array" $ do - let groupEntryName = GroupEntry Nothing mempty $ GERef (Name "a" mempty) Nothing - it "one element" $ - T2Array (Group (GrpChoice [groupEntryName] mempty :| [])) `prettyPrintsTo` "[a]" - it "two elements" $ - T2Array - ( Group - ( GrpChoice - [ GroupEntry Nothing mempty $ GEType Nothing (mkType0 . T2Value . value $ VUInt 1) - , groupEntryName - ] - mempty - :| [] - ) - ) - `prettyPrintsTo` "[1, a]" - it "two elements with comments" $ - T2Array - ( Group - ( GrpChoice - [ GroupEntry Nothing "one" $ GEType Nothing (mkType0 . T2Value . value $ VUInt 1) - , GroupEntry Nothing "two" $ GEType Nothing (mkType0 . T2Value . value $ VUInt 2) - ] - mempty - :| [] - ) - ) - `prettyPrintsTo` "[ 1 ; one\n, 2 ; two\n]" - it "two elements with multiline comments" $ - T2Array - ( Group - ( GrpChoice - [ GroupEntry Nothing "first\nmultiline comment" $ GEType Nothing (mkType0 . T2Value . value $ VUInt 1) - , GroupEntry Nothing "second\nmultiline comment" $ - GEType Nothing (mkType0 . T2Value . value $ VUInt 2) - ] - mempty - :| [] - ) - ) - `prettyPrintsTo` "[ 1 ; first\n ; multiline comment\n, 2 ; second\n ; multiline comment\n]" - describe "Rule" $ do - it "simple assignment" $ - Rule - (Name "a" mempty) - Nothing - AssignEq - (TOGType (Type0 (Type1 (T2Name (Name "b" mempty) mempty) Nothing mempty :| []))) - mempty - `prettyPrintsTo` "a = b" - xit "drep" $ - drep - `prettyPrintsTo` "drep = [0, addr_keyhash // 1, script_hash // 2 // 3]" + describe "CDDL" $ do + describe "Name" $ do + it "names" $ Name "a" `prettyPrintsTo` "a" + describe "Type0" $ do + it "name" $ Type0 @PrettyStage (t1Name :| []) `prettyPrintsTo` "a" + describe "Type1" $ do + it "name" $ t1Name `prettyPrintsTo` "a" + describe "Type2" $ do + it "T2Name" $ t2Name `prettyPrintsTo` "a" + describe "T2Array" $ do + let groupEntryName = GroupEntry Nothing (GERef (Name "a") Nothing) "" + it "one element" $ + T2Array (Group (GrpChoice [groupEntryName] mempty :| [])) `prettyPrintsTo` "[a]" + it "two elements" $ + T2Array + ( Group + ( GrpChoice + [ GroupEntry Nothing (GEType Nothing (mkType0 . T2Value . value $ VUInt 1)) "" + , groupEntryName + ] + mempty + :| [] + ) + ) + `prettyPrintsTo` "[1, a]" + it "two elements with comments" $ + T2Array + ( Group + ( GrpChoice + [ GroupEntry Nothing (GEType Nothing (mkType0 . T2Value . value $ VUInt 1)) "one" + , GroupEntry Nothing (GEType Nothing (mkType0 . T2Value . value $ VUInt 2)) "two" + ] + mempty + :| [] + ) + ) + `prettyPrintsTo` "[ 1 ; one\n, 2 ; two\n]" + it "two elements with multiline comments" $ + T2Array + ( Group + ( GrpChoice + [ GroupEntry + Nothing + (GEType Nothing (mkType0 . T2Value . value $ VUInt 1)) + "first\nmultiline comment" + , GroupEntry + Nothing + (GEType Nothing (mkType0 . T2Value . value $ VUInt 2)) + "second\nmultiline comment" + ] + mempty + :| [] + ) + ) + `prettyPrintsTo` "[ 1 ; first\n ; multiline comment\n, 2 ; second\n ; multiline comment\n]" + describe "Rule" $ do + it "simple assignment" $ + Rule @PrettyStage + (Name "a") + Nothing + AssignEq + (TOGType (Type0 (Type1 (T2Name (Name "b") mempty) Nothing mempty :| []))) + def + `prettyPrintsTo` "a = b" + it "simple assignment with comment" $ + Rule @PrettyStage + (Name "a") + Nothing + AssignEq + (TOGType (Type0 (Type1 (T2Name (Name "b") mempty) Nothing mempty :| []))) + (PrettyXRule "comment") + `prettyPrintsTo` "; comment\na = b" + xit "drep" $ + drep + `prettyPrintsTo` "drep = [0, addr_keyhash // 1, script_hash // 2 // 3]" + describe "Huddle" $ do + let + huddlePrettyPrintsTo rs str = + mapIndex @_ @_ @PrettyStage (H.toCDDLNoRoot $ H.collectFrom rs) `prettyPrintsTo` str + describe "Rule" $ do + -- TODO get rid of trailing newline + it "simple assignment" $ + [HIRule $ "a" =:= H.bool True] + `huddlePrettyPrintsTo` "a = true\n" + it "simple assignment with comment" $ + [HIRule $ H.comment "comment" $ "a" =:= H.bool True] + `huddlePrettyPrintsTo` "; comment\na = true\n" + it "comment and reference" $ + let + b = H.comment "this is rule 'b'" $ "b" =:= H.text "bee" + in + [ HIRule $ H.comment "comment" $ "a" =:= b + ] + `huddlePrettyPrintsTo` "; comment\na = b\n\n; this is rule 'b'\nb = \"bee\"\n" + it "bstr expects hex, not bytes" $ + [ HIRule $ "a" =:= bstr "010200ff" + ] + `huddlePrettyPrintsTo` "a = h'010200ff'\n" + describe "Generic rule" $ do + it "comment and generic reference" $ + let + b :: H.IsType0 a => a -> H.GRuleCall + b = H.binding $ \x -> H.comment "bar" $ "b" =:= H.arr [0 <+ a x] + in + [ HIRule . H.comment "foo" $ "a" =:= b (H.bool True) + ] + `huddlePrettyPrintsTo` "; foo\na = b\n\n; bar\nb = [* a0]\n" + describe "GroupDef" $ do + it "simple pair" $ + [HIGroup $ "a" =:~ [a $ H.bool True, a $ H.int 3]] + `huddlePrettyPrintsTo` "a = (true, 3)\n" + it "simple pair with comment" $ + [HIGroup $ H.comment "comment" $ "a" =:~ [a $ H.bool True, a $ H.int 3]] + `huddlePrettyPrintsTo` "; comment\na = (true, 3)\n" + it "comment and reference" $ + let + b = H.comment "bar" $ "b" =:~ [a $ H.int 2, a $ H.text "bee"] + in + [ HIGroup . H.comment "foo" $ "a" =:~ [a $ H.bool True, a b] + ] + `huddlePrettyPrintsTo` "; foo\na = (true, b)\n\n; bar\nb = (2, \"bee\")\n" diff --git a/test/Test/Codec/CBOR/Cuddle/CDDL/Validator.hs b/test/Test/Codec/CBOR/Cuddle/CDDL/Validator.hs new file mode 100644 --- /dev/null +++ b/test/Test/Codec/CBOR/Cuddle/CDDL/Validator.hs @@ -0,0 +1,76 @@ +{-# LANGUAGE LambdaCase #-} + +module Test.Codec.CBOR.Cuddle.CDDL.Validator (spec) where + +import Codec.CBOR.Cuddle.CBOR.Gen (generateCBORTerm) +import Codec.CBOR.Cuddle.CBOR.Validator ( + CBORTermResult (..), + CDDLResult (..), + validateCBOR, + ) +import Codec.CBOR.Cuddle.CDDL (Name (..)) +import Codec.CBOR.Cuddle.CDDL.CTree (CTreeRoot (..)) +import Codec.CBOR.Cuddle.CDDL.CTree qualified as CTree +import Codec.CBOR.Cuddle.CDDL.Postlude (appendPostlude) +import Codec.CBOR.Cuddle.CDDL.Resolve (fullResolveCDDL) +import Codec.CBOR.Cuddle.IndexMappable (mapCDDLDropExt, mapIndex) +import Codec.CBOR.Cuddle.Parser (pCDDL) +import Codec.CBOR.Term (encodeTerm) +import Codec.CBOR.Write (toStrictByteString) +import Control.Monad (forM_) +import Data.Either (fromRight) +import Data.Map qualified as Map +import Data.Text qualified as T +import Data.Text.IO qualified as T +import Data.Text.Lazy qualified as LT +import Paths_cuddle (getDataFileName) +import Test.Hspec (Spec, describe, runIO, shouldSatisfy) +import Test.Hspec.QuickCheck +import Test.QuickCheck (counterexample, noShrinking) +import Test.QuickCheck.Random (mkQCGen) +import Text.Megaparsec (runParser) +import Text.Pretty.Simple (pShow) + +genAndValidateFromFile :: FilePath -> Spec +genAndValidateFromFile path = do + contents <- runIO $ T.readFile =<< getDataFileName path + let + cddl = fromRight (error "Failed to parse CDDL") $ runParser pCDDL path contents + resolverError x = + error $ "Failed to resolve the CDDL from file " <> show path <> ":\n" <> show x + resolvedCddl@(CTreeRoot m) = + either resolverError id . fullResolveCDDL . appendPostlude $ + mapCDDLDropExt cddl + isRule CTree.Group {} = False + isRule _ = True + describe path $ + forM_ (Map.keys $ Map.filter isRule m) $ \name@(Name n) -> + prop (T.unpack n) . noShrinking $ \seed -> do + let + gen = mkQCGen seed + cborTerm = generateCBORTerm resolvedCddl name gen + generatedCbor = toStrictByteString $ encodeTerm cborTerm + res = validateCBOR generatedCbor name (mapIndex resolvedCddl) + extraInfo = + unlines + [ "Term result:" + , LT.unpack $ pShow res + , "=====" + , "CBOR term:" + , LT.unpack $ pShow cborTerm + ] + counterexample extraInfo $ + res `shouldSatisfy` \case + CBORTermResult _ Valid {} -> True + _ -> False + +spec :: Spec +spec = + describe "Generate and validate from file" $ do + genAndValidateFromFile "example/cddl-files/basic_assign.cddl" + genAndValidateFromFile "example/cddl-files/conway.cddl" + genAndValidateFromFile "example/cddl-files/costmdls_min.cddl" + genAndValidateFromFile "example/cddl-files/issue80-min.cddl" + genAndValidateFromFile "example/cddl-files/pretty.cddl" + genAndValidateFromFile "example/cddl-files/shelley.cddl" + genAndValidateFromFile "example/cddl-files/validator.cddl" diff --git a/test/Test/Codec/CBOR/Cuddle/Huddle.hs b/test/Test/Codec/CBOR/Cuddle/Huddle.hs --- a/test/Test/Codec/CBOR/Cuddle/Huddle.hs +++ b/test/Test/Codec/CBOR/Cuddle/Huddle.hs @@ -1,20 +1,73 @@ {-# LANGUAGE OverloadedLists #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeData #-} +{-# LANGUAGE TypeFamilies #-} {- HLINT ignore "Redundant bracket" -} module Test.Codec.CBOR.Cuddle.Huddle where -import Codec.CBOR.Cuddle.CDDL (CDDL, sortCDDL) +import Codec.CBOR.Cuddle.CDDL (CDDL, fromRules, sortCDDL) +import Codec.CBOR.Cuddle.Comments (Comment) import Codec.CBOR.Cuddle.Huddle +import Codec.CBOR.Cuddle.IndexMappable (IndexMappable (..)) import Codec.CBOR.Cuddle.Parser import Data.Text qualified as T +import Data.Void (Void) +import GHC.Generics (Generic) import Test.Codec.CBOR.Cuddle.CDDL.Pretty qualified as Pretty import Test.Hspec import Test.Hspec.Megaparsec import Text.Megaparsec import Prelude hiding ((/)) +type data TestStage + +newtype instance XCddl TestStage = TestXCddl [Comment] + deriving (Generic, Show, Eq) + +instance IndexMappable XCddl ParserStage TestStage where + mapIndex (ParserXCddl x) = TestXCddl x + +instance IndexMappable XCddl HuddleStage TestStage where + mapIndex (HuddleXCddl x) = TestXCddl x + +newtype instance XTerm TestStage = TestXTerm Comment + deriving (Generic, Show, Eq) + +instance IndexMappable XTerm ParserStage TestStage where + mapIndex (ParserXTerm x) = TestXTerm x + +instance IndexMappable XTerm HuddleStage TestStage where + mapIndex (HuddleXTerm x) = TestXTerm x + +newtype instance XRule TestStage = TestXRule Comment + deriving (Generic, Show, Eq) + +instance IndexMappable XRule ParserStage TestStage where + mapIndex (ParserXRule x) = TestXRule x + +instance IndexMappable XRule HuddleStage TestStage where + mapIndex (HuddleXRule x _) = TestXRule x + +newtype instance XXTopLevel TestStage = TestXXTopLevel Comment + deriving (Generic, Show, Eq) + +instance IndexMappable XXTopLevel ParserStage TestStage where + mapIndex (ParserXXTopLevel x) = TestXXTopLevel x + +instance IndexMappable XXTopLevel HuddleStage TestStage where + mapIndex (HuddleXXTopLevel x) = TestXXTopLevel x + +newtype instance XXType2 TestStage = TestXXType2 Void + deriving (Generic, Show, Eq) + +instance IndexMappable XXType2 ParserStage TestStage where + mapIndex (ParserXXType2 x) = TestXXType2 x + +instance IndexMappable XXType2 HuddleStage TestStage where + mapIndex (HuddleXXType2 x) = TestXXType2 x + huddleSpec :: Spec huddleSpec = describe "huddle" $ do basicAssign @@ -37,6 +90,12 @@ -- it "Can assign a float" $ -- toSortedCDDL ["onepointone" =:= (1.1 :: Float)] -- `shouldMatchParseCDDL` "onepointone = 1.1" + it "Can assign `true` " $ + toSortedCDDL ["isValid" =:= (bool True)] + `shouldMatchParseCDDL` "isValid = true" + it "Can assign `false` " $ + toSortedCDDL ["isValid" =:= (bool False)] + `shouldMatchParseCDDL` "isValid = false" it "Can assign a text string" $ toSortedCDDL ["hello" =:= ("Hello World" :: T.Text)] `shouldMatchParseCDDL` "hello = \"Hello World\"" @@ -47,27 +106,27 @@ arraySpec :: Spec arraySpec = describe "Arrays" $ do it "Can assign a small array" $ - toSortedCDDL ["asl" =:= arr [a VUInt, a VBool, a VText]] - `shouldMatchParseCDDL` "asl = [ uint, bool, text ]" + toSortedCDDL ["asl" =:= arr [a VUInt, a VBool, a VText, a (bool True)]] + `shouldMatchParseCDDL` "asl = [ uint, bool, text, true ]" it "Can quantify an upper bound" $ toSortedCDDL ["age" =:= arr [a VUInt +> 64]] `shouldMatchParseCDDL` "age = [ *64 uint ]" it "Can quantify an optional" $ - toSortedCDDL ["age" =:= arr [0 <+ a VUInt +> 1]] - `shouldMatchParseCDDL` "age = [ ? uint ]" + toSortedCDDL ["age" =:= arr [0 <+ a VUInt +> 1, 0 <+ a (bool False) +> 1]] + `shouldMatchParseCDDL` "age = [ ? uint, ? false ]" it "Can handle a choice" $ toSortedCDDL ["ageOrSex" =:= arr [a VUInt] / arr [a VBool]] `shouldMatchParseCDDL` "ageOrSex = [ uint // bool ]" it "Can handle choices of groups" $ toSortedCDDL [ "asl" - =:= arr [a VUInt, a VBool, a VText] + =:= arr [a VUInt, a VBool, a VText, a (bool True)] / arr [ a (int 1) , a ("Hello" :: T.Text) ] ] - `shouldMatchParseCDDL` "asl = [ uint, bool, text // 1, \"Hello\" ]" + `shouldMatchParseCDDL` "asl = [ uint, bool, text, true // 1, \"Hello\" ]" mapSpec :: Spec mapSpec = describe "Maps" $ do @@ -90,9 +149,9 @@ grpSpec :: Spec grpSpec = describe "Groups" $ do it "Can handle a choice in a group entry" $ - let g1 = "g1" =:~ grp [a (VUInt / VBytes), a VUInt] + let g1 = "g1" =:~ grp [a (VUInt / VBytes), a VUInt, a (bool False)] in toSortedCDDL (collectFrom [HIRule $ "a1" =:= arr [a g1]]) - `shouldMatchParseCDDL` "a1 = [g1]\n g1 = ( uint / bytes, uint )" + `shouldMatchParseCDDL` "a1 = [g1]\n g1 = ( uint / bytes, uint, false)" it "Can handle keys in a group entry" $ let g1 = "g1" =:~ grp ["bytes" ==> VBytes] in toSortedCDDL (collectFrom [HIRule $ "a1" =:= arr [a g1]]) @@ -155,10 +214,10 @@ shouldMatchParse x parseFun input = parse parseFun "" (T.pack input) `shouldParse` x shouldMatchParseCDDL :: - CDDL -> + CDDL TestStage -> String -> Expectation -shouldMatchParseCDDL x = shouldMatchParse x pCDDL +shouldMatchParseCDDL x = shouldMatchParse x . fmap mapIndex $ pCDDL -toSortedCDDL :: Huddle -> CDDL -toSortedCDDL = sortCDDL . toCDDLNoRoot +toSortedCDDL :: Huddle -> CDDL TestStage +toSortedCDDL = mapIndex . fromRules . sortCDDL . toCDDLNoRoot