packages feed

cuddle (empty) → 0.5.0.0

raw patch · 30 files changed

+8269/−0 lines, 30 filesdep +HUnitdep +QuickCheckdep +base

Dependencies added: HUnit, QuickCheck, base, base16-bytestring, boxes, bytestring, capability, cborg, containers, cuddle, data-default-class, foldable1-classes-compat, generic-optics, hashable, hspec, hspec-megaparsec, megaparsec, mtl, mutable-containers, optics-core, optparse-applicative, ordered-containers, parser-combinators, prettyprinter, random, regex-tdfa, scientific, string-qq, text, tree-diff

Files

+ CHANGELOG.md view
@@ -0,0 +1,62 @@+# Revision history for cuddle++## 0.1.0.0 -- YYYY-mm-dd++* First version. Released on an unsuspecting world.++## 0.3.0.0 --2024-07-25++* Rationalise the choice operators. Drop (//) and provide detailed comments+  explaining the use of (/).++## 0.3.0.1 -- 2024-07-31++* Improvements in the pretty printer - various groups should be formatted more+  cleanly++## 0.3.1.0 -- 2024-08-15++* `collectFrom` now adds a first definition in the generated Huddle referencing+  the top level elements, to be compatible with the CDDL spec.++## 0.3.2.0 -- 2024-09-11++* Leading rather than trailing commas in the pretty printer.++## 0.3.3.0 -- 2024-11-13++* Introduce HuddleM, another way to define a Huddle spec. This allows total+  control over the order that items are presented in the CDDL, at the cost+  of making it somewhat harder to re-use items (they need to be returned from+  the monad).++## O.3.5.0 -- 2024-11-25++* Add support for constraints on references and generic references.+* Add support for using references as range bounds. Note that this breaks+  backwards compatibility - because the range arguments are now more generic,+  additional hints are required to type literal numerics correctly. Typically+  this is most easily fixed by adding a call `int` for any numeric literals in+  ranges. An example is shown in `example/Conway.hs`++## 0.3.6.0 -- 2024-12-02+* Support having keys in group entries. This is needed when using a group to+  define a map, or when wishing to include keys in for-use-in-array groups for+  documentation purposes. This may introduce problems with existing specifications+  where some type hints (using 'a') are needed to properly type entries in groups,+  where previously they were unambiguous.++  Note that it is not yet supported to use a group inside a map, where the+  issue of merging keys arises.++## 0.4.0.0 -- 2025-05-02+* Rewrote the prettyprinter to make the output more human-readable.+* Added `collectFromInit` to make it possible to specify the order of+  definitions manually. `collectFrom` and `collectFromInit` now expect+  `HuddleItem`s in their arguments+* More Huddle terms now accept comments (e.g. `ArrayEntry`, `ArrayChoice`)+* Parser now preserves most comments.++## 0.5.0.0 -- 2025-06-03++* Implement a validator for CBOR terms.
+ LICENSE view
@@ -0,0 +1,202 @@++                                 Apache License+                           Version 2.0, January 2004+                        http://www.apache.org/licenses/++   TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION++   1. Definitions.++      "License" shall mean the terms and conditions for use, reproduction,+      and distribution as defined by Sections 1 through 9 of this document.++      "Licensor" shall mean the copyright owner or entity authorized by+      the copyright owner that is granting the License.++      "Legal Entity" shall mean the union of the acting entity and all+      other entities that control, are controlled by, or are under common+      control with that entity. For the purposes of this definition,+      "control" means (i) the power, direct or indirect, to cause the+      direction or management of such entity, whether by contract or+      otherwise, or (ii) ownership of fifty percent (50%) or more of the+      outstanding shares, or (iii) beneficial ownership of such entity.++      "You" (or "Your") shall mean an individual or Legal Entity+      exercising permissions granted by this License.++      "Source" form shall mean the preferred form for making modifications,+      including but not limited to software source code, documentation+      source, and configuration files.++      "Object" form shall mean any form resulting from mechanical+      transformation or translation of a Source form, including but+      not limited to compiled object code, generated documentation,+      and conversions to other media types.++      "Work" shall mean the work of authorship, whether in Source or+      Object form, made available under the License, as indicated by a+      copyright notice that is included in or attached to the work+      (an example is provided in the Appendix below).++      "Derivative Works" shall mean any work, whether in Source or Object+      form, that is based on (or derived from) the Work and for which the+      editorial revisions, annotations, elaborations, or other modifications+      represent, as a whole, an original work of authorship. For the purposes+      of this License, Derivative Works shall not include works that remain+      separable from, or merely link (or bind by name) to the interfaces of,+      the Work and Derivative Works thereof.++      "Contribution" shall mean any work of authorship, including+      the original version of the Work and any modifications or additions+      to that Work or Derivative Works thereof, that is intentionally+      submitted to Licensor for inclusion in the Work by the copyright owner+      or by an individual or Legal Entity authorized to submit on behalf of+      the copyright owner. For the purposes of this definition, "submitted"+      means any form of electronic, verbal, or written communication sent+      to the Licensor or its representatives, including but not limited to+      communication on electronic mailing lists, source code control systems,+      and issue tracking systems that are managed by, or on behalf of, the+      Licensor for the purpose of discussing and improving the Work, but+      excluding communication that is conspicuously marked or otherwise+      designated in writing by the copyright owner as "Not a Contribution."++      "Contributor" shall mean Licensor and any individual or Legal Entity+      on behalf of whom a Contribution has been received by Licensor and+      subsequently incorporated within the Work.++   2. Grant of Copyright License. Subject to the terms and conditions of+      this License, each Contributor hereby grants to You a perpetual,+      worldwide, non-exclusive, no-charge, royalty-free, irrevocable+      copyright license to reproduce, prepare Derivative Works of,+      publicly display, publicly perform, sublicense, and distribute the+      Work and such Derivative Works in Source or Object form.++   3. Grant of Patent License. Subject to the terms and conditions of+      this License, each Contributor hereby grants to You a perpetual,+      worldwide, non-exclusive, no-charge, royalty-free, irrevocable+      (except as stated in this section) patent license to make, have made,+      use, offer to sell, sell, import, and otherwise transfer the Work,+      where such license applies only to those patent claims licensable+      by such Contributor that are necessarily infringed by their+      Contribution(s) alone or by combination of their Contribution(s)+      with the Work to which such Contribution(s) was submitted. If You+      institute patent litigation against any entity (including a+      cross-claim or counterclaim in a lawsuit) alleging that the Work+      or a Contribution incorporated within the Work constitutes direct+      or contributory patent infringement, then any patent licenses+      granted to You under this License for that Work shall terminate+      as of the date such litigation is filed.++   4. Redistribution. You may reproduce and distribute copies of the+      Work or Derivative Works thereof in any medium, with or without+      modifications, and in Source or Object form, provided that You+      meet the following conditions:++      (a) You must give any other recipients of the Work or+          Derivative Works a copy of this License; and++      (b) You must cause any modified files to carry prominent notices+          stating that You changed the files; and++      (c) You must retain, in the Source form of any Derivative Works+          that You distribute, all copyright, patent, trademark, and+          attribution notices from the Source form of the Work,+          excluding those notices that do not pertain to any part of+          the Derivative Works; and++      (d) If the Work includes a "NOTICE" text file as part of its+          distribution, then any Derivative Works that You distribute must+          include a readable copy of the attribution notices contained+          within such NOTICE file, excluding those notices that do not+          pertain to any part of the Derivative Works, in at least one+          of the following places: within a NOTICE text file distributed+          as part of the Derivative Works; within the Source form or+          documentation, if provided along with the Derivative Works; or,+          within a display generated by the Derivative Works, if and+          wherever such third-party notices normally appear. The contents+          of the NOTICE file are for informational purposes only and+          do not modify the License. You may add Your own attribution+          notices within Derivative Works that You distribute, alongside+          or as an addendum to the NOTICE text from the Work, provided+          that such additional attribution notices cannot be construed+          as modifying the License.++      You may add Your own copyright statement to Your modifications and+      may provide additional or different license terms and conditions+      for use, reproduction, or distribution of Your modifications, or+      for any such Derivative Works as a whole, provided Your use,+      reproduction, and distribution of the Work otherwise complies with+      the conditions stated in this License.++   5. Submission of Contributions. Unless You explicitly state otherwise,+      any Contribution intentionally submitted for inclusion in the Work+      by You to the Licensor shall be under the terms and conditions of+      this License, without any additional terms or conditions.+      Notwithstanding the above, nothing herein shall supersede or modify+      the terms of any separate license agreement you may have executed+      with Licensor regarding such Contributions.++   6. Trademarks. This License does not grant permission to use the trade+      names, trademarks, service marks, or product names of the Licensor,+      except as required for reasonable and customary use in describing the+      origin of the Work and reproducing the content of the NOTICE file.++   7. Disclaimer of Warranty. Unless required by applicable law or+      agreed to in writing, Licensor provides the Work (and each+      Contributor provides its Contributions) on an "AS IS" BASIS,+      WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or+      implied, including, without limitation, any warranties or conditions+      of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A+      PARTICULAR PURPOSE. You are solely responsible for determining the+      appropriateness of using or redistributing the Work and assume any+      risks associated with Your exercise of permissions under this License.++   8. Limitation of Liability. In no event and under no legal theory,+      whether in tort (including negligence), contract, or otherwise,+      unless required by applicable law (such as deliberate and grossly+      negligent acts) or agreed to in writing, shall any Contributor be+      liable to You for damages, including any direct, indirect, special,+      incidental, or consequential damages of any character arising as a+      result of this License or out of the use or inability to use the+      Work (including but not limited to damages for loss of goodwill,+      work stoppage, computer failure or malfunction, or any and all+      other commercial damages or losses), even if such Contributor+      has been advised of the possibility of such damages.++   9. Accepting Warranty or Additional Liability. While redistributing+      the Work or Derivative Works thereof, You may choose to offer,+      and charge a fee for, acceptance of support, warranty, indemnity,+      or other liability obligations and/or rights consistent with this+      License. However, in accepting such obligations, You may act only+      on Your own behalf and on Your sole responsibility, not on behalf+      of any other Contributor, and only if You agree to indemnify,+      defend, and hold each Contributor harmless for any liability+      incurred by, or claims asserted against, such Contributor by reason+      of your accepting any such warranty or additional liability.++   END OF TERMS AND CONDITIONS++   APPENDIX: How to apply the Apache License to your work.++      To apply the Apache License to your work, attach the following+      boilerplate notice, with the fields enclosed by brackets "[]"+      replaced with your own identifying information. (Don't include+      the brackets!)  The text should be enclosed in the appropriate+      comment syntax for the file format. We also recommend that a+      file or class name and description of purpose be included on the+      same "printed page" as the copyright notice for easier+      identification within third-party archives.++   Copyright [yyyy] [name of copyright owner]++   Licensed under the Apache License, Version 2.0 (the "License");+   you may not use this file except in compliance with the License.+   You may obtain a copy of the License at++       http://www.apache.org/licenses/LICENSE-2.0++   Unless required by applicable law or agreed to in writing, software+   distributed under the License is distributed on an "AS IS" BASIS,+   WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+   See the License for the specific language governing permissions and+   limitations under the License.
+ bin/Main.hs view
@@ -0,0 +1,238 @@+{-# LANGUAGE LambdaCase #-}++module Main (main) where++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.Resolve (+  fullResolveCDDL,+ )+import Codec.CBOR.Cuddle.Parser (pCDDL)+import Codec.CBOR.Cuddle.Pretty ()+import Codec.CBOR.FlatTerm (toFlatTerm)+import Codec.CBOR.Pretty (prettyHexEnc)+import Codec.CBOR.Term (encodeTerm)+import Codec.CBOR.Write (toStrictByteString)+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 System.Exit (exitFailure, exitSuccess)+import System.IO (hPutStrLn, stderr)+import System.Random (getStdGen)+import Text.Megaparsec (ParseErrorBundle, Parsec, errorBundlePretty, runParser)++data Opts = Opts Command String++data Command+  = Format FormatOpts+  | Validate ValidateOpts+  | GenerateCBOR GenOpts+  | ValidateCBOR ValidateCBOROpts++newtype ValidateOpts = ValidateOpts {vNoPrelude :: Bool}++pValidateOpts :: Parser ValidateOpts+pValidateOpts =+  ValidateOpts+    <$> switch+      ( long "no-prelude"+          <> help "Do not include the CDDL prelude."+      )++-- | Various formats for outputtting CBOR+data CBOROutputFormat+  = AsCBOR+  | AsPrettyCBOR+  | AsTerm+  | AsFlatTerm++pCBOROutputFormat :: ReadM CBOROutputFormat+pCBOROutputFormat = eitherReader $ \case+  "cbor" -> Right AsCBOR+  "pretty" -> Right AsPrettyCBOR+  "term" -> Right AsTerm+  "flat" -> Right AsFlatTerm+  s -> Left s++data GenOpts = GenOpts+  { itemName :: T.Text+  , outputFormat :: CBOROutputFormat+  , outputTo :: Maybe String+  , gNoPrelude :: Bool+  }++pGenOpts :: Parser GenOpts+pGenOpts =+  GenOpts+    <$> strOption+      ( long "rule"+          <> short 'r'+          <> metavar "RULE"+          <> help "Name of the CDDL rule to generate a CBOR term for"+      )+    <*> option+      pCBOROutputFormat+      ( long "format"+          <> short 'f'+          <> help "Output format"+          <> value AsCBOR+      )+    <*> optional+      ( strOption+          ( long "out-file"+              <> short 'o'+              <> help "Write to"+          )+      )+    <*> switch+      ( long "no-prelude"+          <> help "Do not include the CDDL prelude."+      )++newtype FormatOpts = FormatOpts+  {sort :: Bool}++pFormatOpts :: Parser FormatOpts+pFormatOpts =+  FormatOpts+    <$> switch+      ( long "sort-rules"+          <> help "Sort the CDDL rule definitions before printing."+      )++data ValidateCBOROpts = ValidateCBOROpts+  { vcItemName :: T.Text+  , vcInput :: FilePath+  , vcNoPrelude :: Bool+  }++pValidateCBOROpts :: Parser ValidateCBOROpts+pValidateCBOROpts =+  ValidateCBOROpts+    <$> strOption+      ( long "rule"+          <> short 'r'+          <> metavar "RULE"+          <> help "Name of the CDDL rule to validate this file with"+      )+    <*> strOption+      ( long "cbor"+          <> short 'c'+          <> help "CBOR file"+      )+    <*> switch+      ( long "no-prelude"+          <> help "Do not include the CDDL prelude."+      )++opts :: Parser Opts+opts =+  Opts+    <$> subparser+      ( command+          "format"+          ( info+              (Format <$> pFormatOpts <**> helper)+              (progDesc "Format the provided CDDL file")+          )+          <> command+            "validate"+            ( info+                (Validate <$> pValidateOpts <**> helper)+                (progDesc "Validate the provided CDDL file")+            )+          <> command+            "gen"+            ( info+                (GenerateCBOR <$> pGenOpts <**> helper)+                (progDesc "Generate a CBOR term matching the schema")+            )+          <> command+            "validate-cbor"+            ( info+                (ValidateCBOR <$> pValidateCBOROpts <**> helper)+                (progDesc "Validate a CBOR file against a schema")+            )+      )+    <*> argument str (metavar "CDDL_FILE")++main :: IO ()+main = do+  options <-+    execParser $+      info+        (opts <**> helper)+        ( fullDesc+            <> progDesc "Manipulate CDDL files"+            <> header "cuddle"+        )+  run options++run :: Opts -> IO ()+run (Opts cmd cddlFile) = do+  parseFromFile pCDDL cddlFile >>= \case+    Left err -> do+      putStrLnErr $ errorBundlePretty err+      exitFailure+    Right res ->+      case cmd of+        Format fOpts ->+          let+            defs+              | sort fOpts = sortCDDL res+              | otherwise = res+           in+            putDocW 80 $ pretty defs+        Validate vOpts ->+          let+            res'+              | vNoPrelude vOpts = res+              | otherwise = prependPrelude res+           in+            case fullResolveCDDL res' of+              Left err -> putStrLnErr (show err) >> exitFailure+              Right _ -> exitSuccess+        (GenerateCBOR gOpts) ->+          let+            res'+              | gNoPrelude gOpts = res+              | otherwise = prependPrelude res+           in+            case fullResolveCDDL res' of+              Left err -> putStrLnErr (show err) >> exitFailure+              Right mt -> do+                stdGen <- getStdGen+                let term = generateCBORTerm mt (Name (itemName gOpts) mempty) stdGen+                 in case outputFormat gOpts of+                      AsTerm -> print term+                      AsFlatTerm -> print $ toFlatTerm (encodeTerm term)+                      AsCBOR -> case outputTo gOpts of+                        Nothing -> BSC.putStrLn . Base16.encode . toStrictByteString $ encodeTerm term+                        Just out -> BSC.writeFile out $ toStrictByteString $ encodeTerm term+                      AsPrettyCBOR -> putStrLn . prettyHexEnc $ encodeTerm term+        ValidateCBOR vcOpts ->+          let+            res'+              | vcNoPrelude vcOpts = res+              | otherwise = prependPrelude res+           in+            case fullResolveCDDL res' of+              Left err -> putStrLnErr (show err) >> exitFailure+              Right mt -> do+                cbor <- BSC.readFile (vcInput vcOpts)+                validateCBOR cbor (Name (vcItemName vcOpts) mempty) mt++putStrLnErr :: String -> IO ()+putStrLnErr = hPutStrLn stderr++parseFromFile ::+  Parsec e T.Text a ->+  String ->+  IO (Either (ParseErrorBundle T.Text e) a)+parseFromFile p file = runParser p file <$> T.readFile file
+ cuddle.cabal view
@@ -0,0 +1,160 @@+cabal-version: 3.4+name: cuddle+version: 0.5.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).++  Included in this package is a command line tool for working with CDDL files. It+  currently supports four functions:++  - Formatting of CDDL files+  - Validating that a CDDL file is legal+  - Generating random CBOR terms matching CDDL productions+  - Testing compliance of a CBOR file against a CDDL spec.++license: Apache-2.0+license-file: LICENSE+author: IOG Ledger Team+maintainer: nicholas.clarke@iohk.io, hackage@iohk.io+copyright: 2025 Input Output Global Inc (IOG)+category: Codec+build-type: Simple+extra-doc-files: CHANGELOG.md+tested-with: ghc =={9.6, 9.8, 9.10, 9.12}++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++library+  import: warnings+  exposed-modules:+    Codec.CBOR.Cuddle.CBOR.Gen+    Codec.CBOR.Cuddle.CBOR.Validator+    Codec.CBOR.Cuddle.CDDL+    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.Parser+    Codec.CBOR.Cuddle.Parser.Lexer+    Codec.CBOR.Cuddle.Pretty+    Codec.CBOR.Cuddle.Pretty.Columnar+    Codec.CBOR.Cuddle.Pretty.Utils++  build-depends:+    base >=4.18 && <4.22,+    base16-bytestring ^>=1.0.2,+    boxes ^>=0.1.5,+    bytestring >=0.11.4 && <0.13,+    capability ^>=0.5,+    cborg ^>=0.2.10,+    containers >=0.6.7 && <0.8,+    data-default-class ^>=0.2,+    foldable1-classes-compat ^>=0.1.1,+    generic-optics ^>=2.2.1,+    hashable ^>=1.5,+    megaparsec ^>=9.7,+    mtl ^>=2.3.1,+    mutable-containers ^>=0.3.4,+    optics-core ^>=0.4.1,+    ordered-containers ^>=0.2.4,+    parser-combinators ^>=1.3,+    prettyprinter ^>=1.7.1,+    random <1.3,+    regex-tdfa ^>=1.3.2,+    scientific ^>=0.3.8,+    text >=2.0.2 && <2.2,+    tree-diff ^>=0.3.4,++  hs-source-dirs: src+  default-language: GHC2021++executable example+  import: warnings++  if flag(example)+    buildable: True+  else+    buildable: False++  default-language: GHC2021+  other-modules:+    Conway+    Monad++  hs-source-dirs: example+  main-is: Main.hs+  build-depends:+    base,+    cuddle,+    megaparsec,+    prettyprinter,+    random,+    text,++executable cuddle+  import: warnings+  default-language: GHC2021+  hs-source-dirs: ./bin/+  main-is: Main.hs+  build-depends:+    base,+    base16-bytestring,+    bytestring,+    cborg,+    cuddle,+    megaparsec,+    mtl,+    optparse-applicative ^>=0.19,+    prettyprinter,+    random,+    text,++test-suite cuddle-test+  import: warnings+  default-language: GHC2021+  other-modules:+    Test.Codec.CBOR.Cuddle.CDDL.Examples+    Test.Codec.CBOR.Cuddle.CDDL.Gen+    Test.Codec.CBOR.Cuddle.CDDL.Parser+    Test.Codec.CBOR.Cuddle.CDDL.Pretty+    Test.Codec.CBOR.Cuddle.Huddle++  type: exitcode-stdio-1.0+  hs-source-dirs: test+  main-is: Main.hs+  build-depends:+    HUnit ^>=1.6.2,+    QuickCheck ^>=2.15,+    base,+    bytestring,+    cuddle,+    data-default-class,+    hspec ^>=2.11,+    hspec-megaparsec ^>=2.2,+    megaparsec,+    prettyprinter,+    string-qq ^>=0.0.6,+    text,+    tree-diff,
+ example/Conway.hs view
@@ -0,0 +1,972 @@+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE NoImplicitPrelude #-}++{- HLINT ignore "Use camelCase" -}+{- HLINT ignore "Evaluate" -}++module Conway where++import Codec.CBOR.Cuddle.Huddle+import Data.Function (($))+import Data.Semigroup ((<>))+import Data.Text qualified as T+import Data.Word (Word64)+import GHC.Float (Double)+import GHC.Num (Integer)+import GHC.Show (Show (show))++default (Integer, Double)++conway :: Huddle+conway = collectFrom [HIRule block]++block :: Rule+block =+  "block"+    =:= arr+      [ a header+      , "transaction_bodies" ==> arr [0 <+ a transaction_body]+      , "transaction_witness_sets"+          ==> arr [0 <+ a transaction_witness_set]+      , "auxiliary_data_set"+          ==> mp [0 <+ asKey transaction_index ==> auxiliary_data]+      , "invalid_transactions" ==> arr [0 <+ a transaction_index]+      ]++transaction :: Rule+transaction =+  "transaction"+    =:= arr+      [ a transaction_body+      , a transaction_witness_set+      , a VBool+      , a (auxiliary_data / VNil)+      ]++transaction_index :: Rule+transaction_index = "transaction_index" =:= VUInt `sized` (2 :: Word64)++header :: Rule+header = "header" =:= arr [a header_body, "body_signature" ==> kes_signature]++header_body :: Rule+header_body =+  "header_body"+    =:= arr+      [ "block_number" ==> VUInt+      , "slot" ==> VUInt+      , "prev_hash" ==> hash32+      , "issuer_vkey" ==> vkey+      , "vrf_vkey" ==> vkey+      , "vrf_result" ==> vrf_cert+      , "block_body_size" ==> VUInt+      , "block_body_hash" ==> hash32+      , a operational_cert+      , a (arr [a protocol_version])+      ]++operational_cert :: Rule+operational_cert =+  "operational_cert"+    =:= arr+      [ "hot_vkey" ==> kes_vkey+      , "sequence_number" ==> VUInt+      , "kes_period" ==> VUInt+      , "sigma" ==> signature+      ]++protocol_version :: Named Group+protocol_version = "protocol_version" =:~ grp [a major_protocol_version, a VUInt]++next_major_protocol_version :: Rule+next_major_protocol_version = "next_major_protocol_version" =:= (10 :: Integer)++major_protocol_version :: Rule+major_protocol_version = "major_protocol_version" =:= (1 :: Integer)++transaction_body :: Rule+transaction_body =+  "transaction_body"+    =:= mp+      [ idx 0 ==> set transaction_index+      , idx 1 ==> arr [0 <+ a transaction_output]+      , idx 2 ==> coin+      , opt (idx 3 ==> VUInt)+      , opt (idx 4 ==> certificates)+      , opt (idx 5 ==> withdrawals)+      , opt (idx 7 ==> auxiliary_data_hash)+      , opt (idx 8 ==> VUInt)+      , opt (idx 9 ==> mint)+      , opt (idx 11 ==> script_data_hash)+      , opt (idx 13 ==> nonempty_set transaction_input)+      , opt (idx 14 ==> required_signers)+      , opt (idx 15 ==> network_id)+      , opt (idx 16 ==> transaction_output)+      , opt (idx 17 ==> coin)+      , opt (idx 18 ==> nonempty_set transaction_input)+      , opt (idx 19 ==> voting_procedures)+      , opt (idx 20 ==> proposal_procedures)+      , opt (idx 21 ==> coin)+      , opt (idx 22 ==> positive_coin)+      ]++voting_procedures :: Rule+voting_procedures =+  "voting_procedures"+    =:= mp [1 <+ "voter" ==> mp [1 <+ "gov_action_id" ==> voting_procedure]]++voting_procedure :: Rule+voting_procedure = "voting_procedure" =:= arr [a vote, a (anchor / VNil)]++proposal_procedure :: Rule+proposal_procedure =+  "proposal_procedure"+    =:= arr+      [ "deposit" ==> coin+      , a reward_account+      , a gov_action+      , a anchor+      ]++proposal_procedures :: Rule+proposal_procedures = "proposal_procedures" =:= nonempty_set proposal_procedure++certificates :: Rule+certificates = "certificates" =:= nonempty_set certificate++gov_action :: Rule+gov_action =+  "gov_action"+    =:= arr+      [ a+          ( parameter_change_action+              / hard_fork_initiation_action+              / treasury_withdrawals_action+              / no_confidence+              / update_committee+              / new_constitution+              / info_action+          )+      ]++policy_hash :: Rule+policy_hash = "policy_hash" =:= scripthash++parameter_change_action :: Named Group+parameter_change_action =+  "parameter_change_action"+    =:~ grp+      [ 0+      , a (gov_action_id / VNil)+      , a protocol_param_update+      , a (policy_hash / VNil)+      ]++hard_fork_initiation_action :: Named Group+hard_fork_initiation_action =+  "hard_fork_initiation_action"+    =:~ grp [1, a (gov_action_id / VNil), a (arr [a protocol_version])]++treasury_withdrawals_action :: Named Group+treasury_withdrawals_action =+  "treasury_withdrawals_action"+    =:~ grp [2, a (arr [asKey reward_account ==> coin / VInt]), a (policy_hash / VNil)]++no_confidence :: Named Group+no_confidence = "no_confidence" =:~ grp [3, a (gov_action_id / VNil)]++update_committee :: Named Group+update_committee =+  "update_committee"+    =:~ grp+      [ 4+      , a (gov_action_id / VNil)+      , a (set committee_cold_credential)+      , a (arr [asKey committee_cold_credential ==> epoch])+      , a unit_interval+      ]++new_constitution :: Named Group+new_constitution =+  "new_constitution"+    =:~ grp [5, a (gov_action_id / VNil), a constitution]++constitution :: Rule+constitution =+  "constitution"+    =:= arr+      [ a anchor+      , a (scripthash / VNil)+      ]++info_action :: Rule+info_action = "info_action" =:= int 6++voter :: Rule+voter =+  "voter"+    =:= arr [0, a addr_keyhash]+    / arr [1, a scripthash]+    / arr [2, a addr_keyhash]+    / arr [3, a scripthash]+    / arr [4, a addr_keyhash]++anchor :: Rule+anchor =+  "anchor"+    =:= arr+      [ "anchor_url" ==> url+      , "anchor_data_hash" ==> hash32+      ]++vote :: Rule+vote = "vote" =:= int 0 / int 1 / int 2++gov_action_id :: Rule+gov_action_id =+  "gov_action_id"+    =:= arr+      [ "transaction_id" ==> hash32+      , "gov_action_index" ==> VUInt+      ]++required_signers :: Rule+required_signers = "required_signers" =:= nonempty_set addr_keyhash++transaction_input :: Rule+transaction_input =+  "transaction_input"+    =:= arr+      [ "transaction_id" ==> hash32+      , "index" ==> VUInt+      ]++transaction_output :: Rule+transaction_output =+  "transaction_output"+    =:= legacy_transaction_output+    / post_alonzo_transaction_output++legacy_transaction_output :: Rule+legacy_transaction_output =+  "legacy_transaction_output"+    =:= arr+      [ a address+      , "amount" ==> value+      , opt ("datum_hash" ==> hash32)+      ]++post_alonzo_transaction_output :: Rule+post_alonzo_transaction_output =+  "post_alonzo_transaction_output"+    =:= arr+      [ idx 0 ==> address+      , idx 1 ==> value+      , opt (idx 2 ==> datum_option) -- datum option+      , opt (idx 3 ==> script_ref) -- script reference+      ]++script_data_hash :: Rule+script_data_hash = "script_data_hash" =:= hash32++certificate :: Rule+certificate =+  "certificate"+    =:= arr+      [ a+          ( 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 :: Named Group+stake_registration = "stake_registration" =:~ grp [0, a stake_credential]++stake_deregistration :: Named Group+stake_deregistration = "stake_deregistration" =:~ grp [0, a stake_credential]++stake_delegation :: Named Group+stake_delegation =+  "stake_delegation"+    =:~ grp [0, a stake_credential, a pool_keyhash]++-- POOL+pool_registration :: Named Group+pool_registration = "pool_registration" =:~ grp [3, a pool_params]++pool_retirement :: Named Group+pool_retirement = "pool_retirement" =:~ grp [4, a pool_keyhash, a epoch]++-- numbers 5 and 6 used to be the Genesis and MIR certificates respectively,+-- which were deprecated in Conway++-- DELEG+reg_cert :: Named Group+reg_cert = "reg_cert" =:~ grp [7, a stake_credential, a coin]++unreg_cert :: Named Group+unreg_cert = "unreg_cert" =:~ grp [8, a stake_credential, a coin]++vote_deleg_cert :: Named Group+vote_deleg_cert = "vote_deleg_cert" =:~ grp [9, a stake_credential, a drep]++stake_vote_deleg_cert :: Named Group+stake_vote_deleg_cert =+  "stake_vote_deleg_cert"+    =:~ grp [10, a stake_credential, a pool_keyhash, a drep]++stake_reg_deleg_cert :: Named Group+stake_reg_deleg_cert =+  "stake_reg_deleg_cert"+    =:~ grp [11, a stake_credential, a pool_keyhash, a coin]++vote_reg_deleg_cert :: Named Group+vote_reg_deleg_cert =+  "vote_reg_deleg_cert"+    =:~ grp [12, a stake_credential, a drep, a coin]++stake_vote_reg_deleg_cert :: Named Group+stake_vote_reg_deleg_cert =+  "stake_vote_reg_deleg_cert"+    =:~ grp [13, a stake_credential, a pool_keyhash, a drep, a coin]++-- GOVCERT+auth_committee_hot_cert :: Named Group+auth_committee_hot_cert =+  "auth_committee_hot_cert"+    =:~ grp [14, a committee_cold_credential, a committee_hot_credential]++resign_committee_cold_cert :: Named Group+resign_committee_cold_cert =+  "resign_committee_cold_cert"+    =:~ grp [15, a committee_cold_credential, a (anchor / VNil)]++reg_drep_cert :: Named Group+reg_drep_cert = "reg_drep_cert" =:~ grp [16, a drep_credential, a coin, a (anchor / VNil)]++unreg_drep_cert :: Named Group+unreg_drep_cert = "unreg_drep_cert" =:~ grp [17, a drep_credential, a coin]++update_drep_cert :: Named Group+update_drep_cert = "update_drep_cert" =:~ grp [18, a drep_credential, a (anchor / VNil)]++delta_coin :: Rule+delta_coin = "delta_coin" =:= VUInt++credential :: Rule+credential =+  "credential"+    =:= arr+      [0, a addr_keyhash]+    / arr [1, a scripthash]++drep :: Rule+drep =+  "drep"+    =:= sarr [0, a addr_keyhash]+    / sarr [1, a scripthash]+    / int 2 -- always abstain+    / int 3 -- always no confidence++stake_credential :: Rule+stake_credential = "stake_credential" =:= credential++drep_credential :: Rule+drep_credential = "drep_credential" =:= credential++committee_cold_credential :: Rule+committee_cold_credential = "committee_cold_credential" =:= credential++committee_hot_credential :: Rule+committee_hot_credential = "committee_hot_credential" =:= credential++pool_params :: Named Group+pool_params =+  "pool_params"+    =:~ grp+      [ "operator" ==> pool_keyhash+      , "vrf_keyhash" ==> vrf_keyhash+      , "pledge" ==> coin+      , "cost" ==> coin+      , "margin" ==> unit_interval+      , "reward_account" ==> reward_account+      , "pool_owners" ==> set addr_keyhash+      , "relays" ==> arr [0 <+ a relay]+      , "pool_metadata" ==> (pool_metadata / VNil)+      ]++port :: Rule+port = "port" =:= VUInt `le` 65535++ipv4 :: Rule+ipv4 = "ipv4" =:= VBytes `sized` (4 :: Word64)++ipv6 :: Rule+ipv6 = "ipv6" =:= VBytes `sized` (16 :: Word64)++dns_name :: Rule+dns_name = "dns_name" =:= VText `sized` (0 :: Word64, 128 :: Word64)++single_host_addr :: Named Group+single_host_addr =+  "single_host_addr"+    =:~ grp+      [ 0+      , a (port / VNil)+      , a (ipv4 / VNil)+      , a (ipv6 / VNil)+      ]++single_host_name :: Named Group+single_host_name =+  "single_host_name"+    =:~ grp+      [ 1+      , a (port / VNil)+      , a dns_name -- An A or AAAA DNS record+      ]++multi_host_name :: Named Group+multi_host_name =+  "multi_host_name"+    =:~ grp+      [ 2+      , a dns_name -- A SRV DNS record+      ]++relay :: Rule+relay =+  "relay"+    =:= arr+      [ a+          ( single_host_addr+              / single_host_name+              / multi_host_name+          )+      ]++pool_metadata :: Rule+pool_metadata = "pool_metadata" =:= arr [a url, a pool_metadata_hash]++url :: Rule+url = "url" =:= VText `sized` (0 :: Word64, 128 :: Word64)++withdrawals :: Rule+withdrawals = "withdrawals" =:= mp [1 <+ asKey reward_account ==> coin]++protocol_param_update :: Rule+protocol_param_update =+  "protocol_param_update"+    =:= mp+      [ opt (idx 0 ==> coin) -- minfee A+      , opt (idx 1 ==> coin) -- minfee B+      , opt (idx 2 ==> VUInt) -- max block body size+      , opt (idx 3 ==> VUInt) -- max transaction size+      , opt (idx 4 ==> VUInt) -- max block header size+      , opt (idx 5 ==> coin) -- key deposit+      , opt (idx 6 ==> coin) -- pool deposit+      , opt (idx 7 ==> epoch) -- maximum epoch+      , opt (idx 8 ==> VUInt) -- n_opt: desired number of stake pools+      , opt (idx 9 ==> nonnegative_interval) -- pool pledge influence+      , opt (idx 10 ==> unit_interval) -- expansion rate+      , opt (idx 11 ==> unit_interval) -- treasury growth rate+      , opt (idx 16 ==> coin) -- min pool cost+      , opt (idx 17 ==> coin) -- ada per utxo byte+      , opt (idx 18 ==> costmdls) -- cost models for script languages+      , opt (idx 19 ==> ex_unit_prices) -- execution costs+      , opt (idx 20 ==> ex_units) -- max tx ex units+      , opt (idx 21 ==> ex_units) -- max block ex units+      , opt (idx 22 ==> VUInt) -- max value size+      , opt (idx 23 ==> VUInt) -- collateral percentage+      , opt (idx 24 ==> VUInt) -- max collateral inputs+      , opt (idx 25 ==> pool_voting_thresholds) -- pool voting thresholds+      , opt (idx 26 ==> drep_voting_thresholds) -- DRep voting thresholds+      , opt (idx 27 ==> VUInt) -- min committee size+      , opt (idx 28 ==> epoch) -- committee term limit+      , opt (idx 29 ==> epoch) -- governance action validity period+      , opt (idx 30 ==> coin) -- governance action deposit+      , opt (idx 31 ==> coin) -- DRep deposit+      , opt (idx 32 ==> epoch) -- DRep inactivity period+      ]++pool_voting_thresholds :: Rule+pool_voting_thresholds =+  "pool_voting_thresholds"+    =:= arr+      [ a unit_interval -- motion no confidence+      , a unit_interval -- committee normal+      , a unit_interval -- committee no confidence+      , a unit_interval -- hard fork initiation+      , a unit_interval -- security relevant parameter voting threshold+      ]++drep_voting_thresholds :: Rule+drep_voting_thresholds =+  "drep_voting_thresholds"+    =:= arr+      [ a unit_interval -- motion no confidence+      , a unit_interval -- committee normal+      , a unit_interval -- committee no confidence+      , a unit_interval -- update constitution+      , a unit_interval -- hard fork initiation+      , a unit_interval -- PP network group+      , a unit_interval -- PP economic group+      , a unit_interval -- PP technical group+      , a unit_interval -- PP governance group+      , a unit_interval -- treasury withdrawal+      ]++transaction_witness_set :: Rule+transaction_witness_set =+  "transaction_witness_set"+    =:= mp+      [ opt $ idx 0 ==> nonempty_set vkeywitness+      , opt $ idx 1 ==> nonempty_set native_script+      , opt $ idx 2 ==> nonempty_set bootstrap_witness+      , opt $ idx 3 ==> nonempty_set plutus_v1_script+      , opt $ idx 4 ==> nonempty_set plutus_data+      , opt $ idx 5 ==> redeemers+      , opt $ idx 6 ==> nonempty_set plutus_v2_script+      , opt $ idx 7 ==> nonempty_set plutus_v3_script+      ]++-- The real type of  plutus_v1_script, plutus_v2_script and plutus_v3_script is bytes.+-- However, because we enforce uniqueness when many scripts are supplied,+-- we need to hack around for tests in order to avoid generating duplicates,+-- since the cddl tool we use for roundtrip testing doesn't generate distinct collections.+plutus_v1_script :: Rule+plutus_v1_script =+  comment+    ( "The real type of  plutus_v1_script, plutus_v2_script and plutus_v3_script is bytes.\n"+        <> "However, because we enforce uniqueness when many scripts are supplied,\n"+        <> "we need to hack around for tests in order to avoid generating duplicates,\n"+        <> "since the cddl tool we use for roundtrip testing doesn't generate distinct collections.\n"+    )+    $ "plutus_v1_script" =:= distinct VBytes++plutus_v2_script :: Rule+plutus_v2_script = "plutus_v2_script" =:= distinct VBytes++plutus_v3_script :: Rule+plutus_v3_script = "plutus_v3_script" =:= distinct VBytes++plutus_data :: Rule+plutus_data =+  "plutus_data"+    =:= constr plutus_data+    / smp [0 <+ asKey plutus_data ==> plutus_data]+    / sarr [0 <+ a plutus_data]+    / big_int+    / bounded_bytes++big_int :: Rule+big_int = "big_int" =:= VInt / big_VUInt / big_nint++big_VUInt :: Rule+big_VUInt = "big_VUInt" =:= tag 2 bounded_bytes++big_nint :: Rule+big_nint = "big_nint" =:= tag 3 bounded_bytes++constr :: IsType0 x => x -> GRuleCall+constr = binding $ \x ->+  "constr"+    =:= tag 1 (arr [0 <+ a x])+    / tag 2 (arr [0 <+ a x])+    / tag 3 (arr [0 <+ a x])+    / tag 4 (arr [0 <+ a x])+    / tag 5 (arr [0 <+ a x])+    / tag 6 (arr [0 <+ a x])+    / tag 7 (arr [0 <+ a x])+    -- similarly for tag range: 6.1280 .. 6.1400 inclusive+    / tag 2 (arr [a VUInt, a $ arr [0 <+ a x]])++redeemers :: Rule+redeemers =+  "redeemers"+    =:= sarr+      [ 1+          <+ a+            ( arr+                [ "tag" ==> redeemer_tag+                , "index" ==> VUInt+                , "data" ==> plutus_data+                , "ex_units" ==> ex_units+                ]+            )+      ]+    / smp+      [ 1+          <+ asKey (mp ["tag" ==> redeemer_tag, "index" ==> VUInt])+          ==> arr ["data" ==> plutus_data, "ex_units" ==> ex_units]+      ]++redeemer_tag :: Rule+redeemer_tag =+  "redeemer_tag"+    =:= int 0 -- Spending+    / int 1 -- Minting+    / int 2 -- Certifying+    / int 3 -- Rewarding+    / int 4 -- Voting+    / int 5 -- Proposing++ex_units :: Rule+ex_units = "ex_units" =:= arr ["mem" ==> VUInt, "steps" ==> VUInt]++ex_unit_prices :: Rule+ex_unit_prices =+  "ex_unit_prices"+    =:= arr+      [ "mem_price" ==> nonnegative_interval+      , "step_price" ==> nonnegative_interval+      ]++language :: Rule+language =+  "language"+    =:= int 0 -- Plutus v1+    / int 1 -- Plutus v2+    / int 2 -- Plutus v3++potential_languages :: Rule+potential_languages = "potential_languages" =:= int 0 ... int 255++-- The format for costmdls is flexible enough to allow adding Plutus built-ins and language+-- versions in the future.+--+costmdls :: Rule+costmdls =+  comment+    "The format for costmdls is flexible enough to allow adding Plutus\n built-ins and language versions in the future."+    $ "costmdls"+      =:= mp+        [ opt $ idx 0 ==> arr [166 <+ a VInt] -- Plutus v1, only 166 integers are used, but more are accepted (and ignored)+        , opt $ idx 1 ==> arr [175 <+ a VInt] -- Plutus v2, only 175 integers are used, but more are accepted (and ignored)+        , opt $ idx 2 ==> arr [223 <+ a VInt] -- Plutus v3, only 223 integers are used, but more are accepted (and ignored)+        , opt $ idx 3 ==> arr [a VInt] -- Any 8-bit unsigned number can be used as a key.+        ]++transaction_metadatum :: Rule+transaction_metadatum =+  "transaction_metadatum"+    =:= smp [0 <+ asKey transaction_metadatum ==> transaction_metadatum]+    / sarr [0 <+ a transaction_metadatum]+    / VInt+    / (VBytes `sized` (0 :: Word64, 64 :: Word64))+    / (VText `sized` (0 :: Word64, 64 :: Word64))++transaction_metadatum_label :: Rule+transaction_metadatum_label = "transaction_metadatum_label" =:= VUInt++metadata :: Rule+metadata =+  "metadata"+    =:= mp+      [ 0+          <+ asKey transaction_metadatum_label+          ==> transaction_metadatum+      ]++auxiliary_data :: Rule+auxiliary_data =+  "auxiliary_data"+    =:= metadata -- Shelley+    / sarr+      [ "transaction_metadata" ==> metadata -- Shelley-ma+      , "auxiliary_scripts" ==> arr [0 <+ a native_script]+      ]+    / smp+      [ opt (idx 0 ==> metadata) -- Alonzo and beyond+      , opt (idx 1 ==> arr [0 <+ a native_script])+      , opt (idx 2 ==> arr [0 <+ a plutus_v1_script])+      , opt (idx 3 ==> arr [0 <+ a plutus_v2_script])+      , opt (idx 4 ==> arr [0 <+ a plutus_v3_script])+      ]++vkeywitness :: Rule+vkeywitness = "vkeywitness" =:= arr [a vkey, a signature]++bootstrap_witness :: Rule+bootstrap_witness =+  "bootstrap_witness"+    =:= arr+      [ "public_key" ==> vkey+      , "signature" ==> signature+      , "chain_code" ==> (VBytes `sized` (32 :: Word64))+      , "attributes" ==> VBytes+      ]++native_script :: Rule+native_script =+  "native_script"+    =:= arr+      [ a+          ( 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 :: Named Group+script_pubkey = "script_pubkey" =:~ grp [0, a addr_keyhash]++script_all :: Named Group+script_all = "script_all" =:~ grp [1, a (arr [0 <+ a native_script])]++script_any :: Named Group+script_any = "script_any" =:~ grp [2, a (arr [0 <+ a native_script])]++script_n_of_k :: Named Group+script_n_of_k =+  "script_n_of_k"+    =:~ grp [3, "n" ==> VUInt, a (arr [0 <+ a native_script])]++invalid_before :: Named Group+invalid_before = "invalid_before" =:~ grp [4, a VUInt]++invalid_hereafter :: Named Group+invalid_hereafter = "invalid_hereafter" =:~ grp [5, a VUInt]++coin :: Rule+coin = "coin" =:= VUInt++multiasset :: (Show a, IsType0 a) => a -> Rule+multiasset x =+  "multiasset_"+    <> T.pack (show x)+      =:= mp [1 <+ asKey policy_id ==> mp [1 <+ asKey asset_name ==> x]]++policy_id :: Rule+policy_id = "policy_id" =:= scripthash++asset_name :: Rule+asset_name = "asset_name" =:= VBytes `sized` (0 :: Word64, 32 :: Word64)++negInt64 :: Rule+negInt64 = "negInt64" =:= int (-9223372036854775808) ... int (-1)++posInt64 :: Rule+posInt64 = "posInt64" =:= int 1 ... int 9223372036854775807++nonZeroInt64 :: Rule+nonZeroInt64 = "nonZeroInt64" =:= negInt64 / posInt64 -- this is the same as the current int64 definition but without zero++positive_coin :: Rule+positive_coin = "positive_coin" =:= int 1 ... int 18446744073709551615++value :: Rule+value = "value" =:= coin / sarr [a coin, a (multiasset positive_coin)]++mint :: Rule+mint = "mint" =:= multiasset nonZeroInt64++int64 :: Rule+int64 = "int64" =:= int (-9223372036854775808) ... int 9223372036854775807++network_id :: Rule+network_id = "network_id" =:= int 0 / int 1++epoch :: Rule+epoch = "epoch" =:= VUInt++addr_keyhash :: Rule+addr_keyhash = "addr_keyhash" =:= hash28++pool_keyhash :: Rule+pool_keyhash = "pool_keyhash" =:= hash28++vrf_keyhash :: Rule+vrf_keyhash = "vrf_keyhash" =:= hash32++auxiliary_data_hash :: Rule+auxiliary_data_hash = "auxiliary_data_hash" =:= hash32++pool_metadata_hash :: Rule+pool_metadata_hash = "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 :: Rule+scripthash =+  comment+    ( "To compute a script hash, note that you must prepend\n"+        <> "a tag to the bytes of the script before hashing.\n"+        <> "The tag is determined by the language.\n"+        <> "The tags in the Conway era are:\n"+        <> "\"\x00\" for multisig scripts\n"+        <> "\"\x01\" for Plutus V1 scripts\n"+        <> "\"\x02\" for Plutus V2 scripts\n"+        <> "\"\x03\" for Plutus V3 scripts\n"+    )+    $ "scripthash" =:= hash28++datum_hash :: Rule+datum_hash = "datum_hash" =:= hash32++data_a :: Rule+data_a = "data" =:= VBytes `cbor` plutus_data++datum_option :: Rule+datum_option = "datum_option" =:= arr [0, a hash32] / arr [1, a data_a]++script_ref :: Rule+script_ref = "script_ref" =:= VBytes `cbor` script++script :: Rule+script =+  "script"+    =:= arr [0, a native_script]+    / arr [1, a plutus_v1_script]+    / arr [2, a plutus_v2_script]+    / arr [3, a plutus_v3_script]++--------------------------------------------------------------------------------+-- Crypto+--------------------------------------------------------------------------------++hash28 :: Rule+hash28 = "hash28" =:= VBytes `sized` (28 :: Word64)++hash32 :: Rule+hash32 = "hash32" =:= VBytes `sized` (32 :: Word64)++vkey :: Rule+vkey = "vkey" =:= VBytes `sized` (32 :: Word64)++vrf_vkey :: Rule+vrf_vkey = "vrf_vkey" =:= VBytes `sized` (32 :: Word64)++vrf_cert :: Rule+vrf_cert = "vrf_cert" =:= arr [a VBytes, a (VBytes `sized` (80 :: Word64))]++kes_vkey :: Rule+kes_vkey = "kes_vkey" =:= VBytes `sized` (32 :: Word64)++kes_signature :: Rule+kes_signature = "kes_signature" =:= VBytes `sized` (448 :: Word64)++signkeyKES :: Rule+signkeyKES = "signkeyKES" =:= VBytes `sized` (64 :: Word64)++signature :: Rule+signature = "signature" =:= VBytes `sized` (64 :: Word64)++--------------------------------------------------------------------------------+-- Extras+--------------------------------------------------------------------------------++-- 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.++set :: IsType0 t0 => t0 -> GRuleCall+set = binding $ \x -> "set" =:= arr [0 <+ a x]++nonempty_set :: IsType0 t0 => t0 -> GRuleCall+nonempty_set = binding $ \x -> "nonempty_set" =:= set x++-- TODO Should we give this a name?+nonempty_oset :: IsType0 t0 => t0 -> GRuleCall+nonempty_oset = nonempty_set++positive_int :: Rule+positive_int = "positive_int" =:= int 1 ... int 18446744073709551615++unit_interval :: Rule+unit_interval = "unit_interval" =:= tag 30 (arr [1, 2])++-- unit_interval = tag 0 [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 = tag 0 [uint, positive_int]+nonnegative_interval :: Rule+nonnegative_interval = "nonnegative_interval" =:= tag 30 (arr [a VUInt, a positive_int])++address :: Rule+address =+  "address"+    =:= bstr+      "001000000000000000000000000000000000000000000000000000000011000000000000000000000000000000000000000000000000000000"+    / bstr+      "102000000000000000000000000000000000000000000000000000000022000000000000000000000000000000000000000000000000000000"+    / bstr+      "203000000000000000000000000000000000000000000000000000000033000000000000000000000000000000000000000000000000000000"+    / bstr+      "304000000000000000000000000000000000000000000000000000000044000000000000000000000000000000000000000000000000000000"+    / bstr "405000000000000000000000000000000000000000000000000000000087680203"+    / bstr "506000000000000000000000000000000000000000000000000000000087680203"+    / bstr "6070000000000000000000000000000000000000000000000000000000"+    / bstr "7080000000000000000000000000000000000000000000000000000000"++reward_account :: Rule+reward_account =+  "reward_account"+    =:= bstr "E090000000000000000000000000000000000000000000000000000000"+    / bstr "F0A0000000000000000000000000000000000000000000000000000000"++bounded_bytes :: Rule+bounded_bytes = "bounded_bytes" =:= VBytes `sized` (0 :: Word64, 64 :: Word64)++-- 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 :: (IsType0 a, IsConstrainable a b) => a -> GRuleCall+distinct = binding $ \x ->+  "distinct"+    =:= (x `sized` (8 :: Word64))+    / (x `sized` (16 :: Word64))+    / (x `sized` (20 :: Word64))+    / (x `sized` (24 :: Word64))+    / (x `sized` (30 :: Word64))+    / (x `sized` (32 :: Word64))
+ example/Main.hs view
@@ -0,0 +1,79 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}++module Main (main) where++import Codec.CBOR.Cuddle.CBOR.Gen (generateCBORTerm)+import Codec.CBOR.Cuddle.CDDL (Name (..))+import Codec.CBOR.Cuddle.CDDL.Resolve (+  asMap,+  buildMonoCTree,+  buildRefCTree,+  buildResolvedCTree,+ )+import Codec.CBOR.Cuddle.Huddle (toCDDL)+import Codec.CBOR.Cuddle.Parser (pCDDL)+import Codec.CBOR.Cuddle.Pretty ()+import Conway (conway)+import Data.Text qualified as T+import Data.Text.IO qualified as T+import Monad qualified+import Prettyprinter (Pretty (pretty))+import Prettyprinter.Util (putDocW)+import System.Environment (getArgs)+import System.Random (getStdGen)+import Text.Megaparsec (ParseErrorBundle, Parsec, errorBundlePretty, runParser)++main :: IO ()+main = do+  args <- getArgs+  case args of+    [fn] -> do+      parseFromFile pCDDL fn >>= \case+        Left err -> putStrLn $ errorBundlePretty err+        Right res -> do+          print res+          putDocW 80 $ pretty res+          putStrLn "\n"+          putStrLn "--------------------------------------------------------------------------------"+          putStrLn " As a CTree"+          putStrLn "--------------------------------------------------------------------------------"+          let refCTree = buildRefCTree (asMap res)+          print refCTree+          putStrLn "--------------------------------------------------------------------------------"+          putStrLn " After name resolution"+          putStrLn "--------------------------------------------------------------------------------"+          let resolvedCTree = buildResolvedCTree refCTree+          print resolvedCTree+          putStrLn "--------------------------------------------------------------------------------"+          putStrLn " After monomorphisation"+          putStrLn "--------------------------------------------------------------------------------"+          let monoCTree = buildMonoCTree <$> resolvedCTree+          print monoCTree+    [fn, name] -> do+      putStrLn "--------------------------------------------------------------------------------"+      putStrLn " Generating a term"+      putStrLn "--------------------------------------------------------------------------------"+      parseFromFile pCDDL fn >>= \case+        Left err -> putStrLn $ errorBundlePretty err+        Right res -> do+          stdGen <- getStdGen+          case buildMonoCTree =<< buildResolvedCTree (buildRefCTree (asMap res)) of+            Left nre -> error $ show nre+            Right mt ->+              let term = generateCBORTerm mt (Name (T.pack name) mempty) stdGen+               in print term+    [] -> do+      let cw = toCDDL conway+      putDocW 80 $ pretty cw+      putStrLn "--------------------------------------"+      putDocW 80 $ pretty (toCDDL Monad.spec)+      putStrLn "--------------------------------------"+      putDocW 80 $ pretty (toCDDL Monad.spec2)+    _ -> putStrLn "Expected filename"++parseFromFile ::+  Parsec e T.Text a ->+  String ->+  IO (Either (ParseErrorBundle T.Text e) a)+parseFromFile p file = runParser p file <$> T.readFile file
+ example/Monad.hs view
@@ -0,0 +1,53 @@+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecursiveDo #-}++{- HLINT ignore "Use camelCase" -}++module Monad where++import Codec.CBOR.Cuddle.Comments ((//-))+import Codec.CBOR.Cuddle.Huddle qualified as Huddle+import Codec.CBOR.Cuddle.Huddle.HuddleM+import Data.Word (Word64)++hdl_set :: IsType0 t0 => t0 -> GRuleCall+hdl_set = Huddle.binding $ \x -> "set" Huddle.=:= arr [0 <+ a x]++spec :: Huddle+spec = huddleDef $ mdo+  transaction <-+    "transaction"+      =:= mp+        [ idx 0 ==> set txIn+        , idx 1 ==> set txOut+        ]+  txIn <- "txIn" =:= arr ["transaction_id" ==> hash32, "index" ==> txId]+  txOut <- "txOut" =:= arr [idx 0 ==> address, idx 1 ==> value]+  txId <- "txId" =:= VUInt `sized` (2 :: Word64)+  address <- "address" =:= VBytes `sized` (32 :: Word64)+  hash32 <- "hash32" =:= VBytes `sized` (32 :: Word64)+  value <- "value" =:= VUInt+  set <- include hdl_set++  setRootRules [transaction]++spec2 :: Huddle+spec2 =+  spec+    <> huddleDef+      ( mdo+          set <- include hdl_set+          txIn <- unsafeIncludeFromHuddle spec "txIn"+          txOut <- unsafeIncludeFromHuddle spec "txOut"+          _transaction <-+            "transaction"+              =:= mp+                [ idx 0 ==> set txIn //- "Transaction inputs"+                , idx 1 ==> set txOut //- "Transaction outputs"+                , idx 2 ==> metadata //- "Metadata"+                ]+          metadata <- "metadata" =:= VBytes+          _value <- "value" =:= mp ["token" ==> VText, "quantity" ==> VUInt]+          pure ()+      )
+ src/Codec/CBOR/Cuddle/CBOR/Gen.hs view
@@ -0,0 +1,447 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE ViewPatterns #-}++-- | Generate example CBOR given a CDDL specification+module Codec.CBOR.Cuddle.CBOR.Gen (generateCBORTerm, generateCBORTerm') where++import Capability.Reader+import Capability.Sink (HasSink)+import Capability.Source (HasSource, MonadState (..))+import Capability.State (HasState, get, modify, state)+import Codec.CBOR.Cuddle.CDDL (+  Name (..),+  OccurrenceIndicator (..),+  Value (..),+  ValueVariant (..),+ )+import Codec.CBOR.Cuddle.CDDL.CTree (CTree, CTreeRoot' (..))+import Codec.CBOR.Cuddle.CDDL.CTree qualified as CTree+import Codec.CBOR.Cuddle.CDDL.CtlOp qualified as CtlOp+import Codec.CBOR.Cuddle.CDDL.Postlude (PTerm (..))+import Codec.CBOR.Cuddle.CDDL.Resolve (MonoRef (..))+import Codec.CBOR.Term (Term (..))+import Codec.CBOR.Term qualified as CBOR+import Codec.CBOR.Write qualified as CBOR+import Control.Monad (join, replicateM, (<=<))+import Control.Monad.Reader (Reader, runReader)+import Control.Monad.State.Strict (StateT, runStateT)+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 GHC.Generics (Generic)+import System.Random.Stateful (+  Random,+  RandomGen (genShortByteString, genWord32, genWord64),+  RandomGenM,+  StatefulGen (..),+  UniformRange (uniformRM),+  applyRandomGenM,+  randomM,+  uniformByteStringM,+ )++--------------------------------------------------------------------------------+-- Generator infrastructure+--------------------------------------------------------------------------------++-- | Generator context, parametrised over the type of the random seed+data GenEnv g = GenEnv+  { cddl :: CTreeRoot' Identity MonoRef+  , fakeSeed :: CapGenM g+  -- ^ Access the "fake" seed, necessary to recursively call generators+  }+  deriving (Generic)++data GenState g = GenState+  { randomSeed :: g+  -- ^ Actual seed+  , depth :: Int+  -- ^ Depth of the generator. This measures the number of references we+  -- follow. As we go deeper into the tree, we try to reduce the likelihood of+  -- following recursive paths, and generate shorter lists where allowed by+  -- the occurrence bounds.+  }+  deriving (Generic)++newtype M g a = M {runM :: StateT (GenState g) (Reader (GenEnv g)) a}+  deriving (Functor, Applicative, Monad)+  deriving+    (HasSource "randomSeed" g, HasSink "randomSeed" g, HasState "randomSeed" g)+    via Field+          "randomSeed"+          ()+          (MonadState (StateT (GenState g) (Reader (GenEnv g))))+  deriving+    (HasSource "depth" Int, HasSink "depth" Int, HasState "depth" Int)+    via Field+          "depth"+          ()+          (MonadState (StateT (GenState g) (Reader (GenEnv g))))+  deriving+    ( HasSource "cddl" (CTreeRoot' Identity MonoRef)+    , HasReader "cddl" (CTreeRoot' Identity MonoRef)+    )+    via Field+          "cddl"+          ()+          (Lift (StateT (GenState g) (MonadReader (Reader (GenEnv g)))))+  deriving+    (HasSource "fakeSeed" (CapGenM g), HasReader "fakeSeed" (CapGenM g))+    via Field+          "fakeSeed"+          ()+          (Lift (StateT (GenState g) (MonadReader (Reader (GenEnv g)))))++-- | Opaque type carrying the type of a pure PRNG inside a capability-style+-- state monad.+data CapGenM g = CapGenM++instance RandomGen g => StatefulGen (CapGenM g) (M g) where+  uniformWord64 _ = state @"randomSeed" genWord64+  uniformWord32 _ = state @"randomSeed" genWord32++  uniformShortByteString n _ = state @"randomSeed" (genShortByteString n)++instance RandomGen r => RandomGenM (CapGenM r) r (M r) where+  applyRandomGenM f _ = state @"randomSeed" f++runGen :: M g a -> GenEnv g -> GenState g -> (a, GenState g)+runGen m env st = runReader (runStateT (runM m) st) env++evalGen :: M g a -> GenEnv g -> GenState g -> a+evalGen m env = fst . runGen m env++asksM :: forall tag r m a. HasReader tag r m => (r -> m a) -> m a+asksM f = f =<< ask @tag++--------------------------------------------------------------------------------+-- Wrappers around some Random function in Gen+--------------------------------------------------------------------------------++genUniformRM :: forall a g. (UniformRange a, RandomGen g) => (a, a) -> M g a+genUniformRM = asksM @"fakeSeed" . uniformRM++-- | Generate a random number in a given range, biased increasingly towards the+-- lower end as the depth parameter increases.+genDepthBiasedRM ::+  forall a g.+  (Ord a, UniformRange a, RandomGen g) =>+  (a, a) ->+  M g a+genDepthBiasedRM bounds = do+  fs <- ask @"fakeSeed"+  d <- get @"depth"+  samples <- replicateM d (uniformRM bounds fs)+  pure $ minimum samples++-- | Generates a bool, increasingly likely to be 'False' as the depth increases.+genDepthBiasedBool :: forall g. RandomGen g => M g Bool+genDepthBiasedBool = do+  d <- get @"depth"+  and <$> replicateM d genRandomM++genRandomM :: forall g a. (Random a, RandomGen g) => M g a+genRandomM = asksM @"fakeSeed" randomM++genBytes :: forall g. RandomGen g => Int -> M g ByteString+genBytes n = asksM @"fakeSeed" $ uniformByteStringM n++genText :: forall g. RandomGen g => Int -> M g Text+genText n = pure $ T.pack . take n . join $ repeat ['a' .. 'z']++--------------------------------------------------------------------------------+-- Postlude+--------------------------------------------------------------------------------++-- | Primitive types defined by the CDDL specification, with their generators+genPostlude :: RandomGen g => PTerm -> M g Term+genPostlude pt = case pt of+  PTBool ->+    genRandomM+      <&> TBool+  PTUInt ->+    genUniformRM (minBound :: Word32, maxBound)+      <&> TInteger+        . fromIntegral+  PTNInt ->+    genUniformRM+      (minBound :: Int, 0)+      <&> TInteger+        . fromIntegral+  PTInt ->+    genUniformRM (minBound :: Int, maxBound)+      <&> TInteger+        . fromIntegral+  PTHalf ->+    genUniformRM (-65504, 65504)+      <&> THalf+  PTFloat ->+    genRandomM+      <&> TFloat+  PTDouble ->+    genRandomM+      <&> TDouble+  PTBytes -> TBytes <$> genBytes 30+  PTText -> TString <$> genText 30+  PTAny -> pure $ TString "Any"+  PTNil -> pure TNull+  PTUndefined -> pure $ TSimple 23++--------------------------------------------------------------------------------+-- Kinds of terms+--------------------------------------------------------------------------------++data WrappedTerm+  = SingleTerm Term+  | PairTerm Term Term+  | GroupTerm [WrappedTerm]+  deriving (Eq, Show)++-- | Recursively flatten wrapped list. That is, expand any groups out to their+-- individual entries.+flattenWrappedList :: [WrappedTerm] -> [WrappedTerm]+flattenWrappedList [] = []+flattenWrappedList (GroupTerm xxs : xs) =+  flattenWrappedList xxs <> flattenWrappedList xs+flattenWrappedList (y : xs) = y : flattenWrappedList xs++pattern S :: Term -> WrappedTerm+pattern S t = SingleTerm t++-- | Convert a list of wrapped terms to a list of terms. If any 'PairTerm's are+-- present, we just take their "value" part.+singleTermList :: [WrappedTerm] -> Maybe [Term]+singleTermList [] = Just []+singleTermList (S x : xs) = (x :) <$> singleTermList xs+singleTermList (P _ y : xs) = (y :) <$> singleTermList xs+singleTermList _ = Nothing++pattern P :: Term -> Term -> WrappedTerm+pattern P t1 t2 = PairTerm t1 t2++-- | Convert a list of wrapped terms to a list of pairs of terms, or fail if any+-- 'SingleTerm's are present.+pairTermList :: [WrappedTerm] -> Maybe [(Term, Term)]+pairTermList [] = Just []+pairTermList (P x y : xs) = ((x, y) :) <$> pairTermList xs+pairTermList _ = Nothing++pattern G :: [WrappedTerm] -> WrappedTerm+pattern G xs = GroupTerm xs++--------------------------------------------------------------------------------+-- Generator functions+--------------------------------------------------------------------------------++genForCTree :: RandomGen g => CTree MonoRef -> M g WrappedTerm+genForCTree (CTree.Literal v) = S <$> genValue v+genForCTree (CTree.Postlude pt) = S <$> genPostlude pt+genForCTree (CTree.Map nodes) = do+  items <- pairTermList . flattenWrappedList <$> traverse genForNode nodes+  case items of+    Just ts ->+      let+        -- De-duplicate keys in the map.+        -- Per RFC7049:+        -- >> A map that has duplicate keys may be well-formed, but it is not+        -- >> valid, and thus it causes indeterminate decoding+        tsNodup = Map.toList $ Map.fromList ts+       in+        pure . S $ TMap tsNodup+    Nothing -> error "Single terms in map context"+genForCTree (CTree.Array nodes) = do+  items <- singleTermList . flattenWrappedList <$> traverse genForNode 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 (CTree.KV key value _cut) = do+  kg <- genForNode key+  vg <- genForNode value+  case (kg, vg) of+    (S k, S v) -> pure $ P k v+    _ ->+      error $+        "Non single-term generated outside of group context: "+          <> show key+          <> " => "+          <> show value+genForCTree (CTree.Occur item occurs) =+  applyOccurenceIndicator occurs (genForNode item)+genForCTree (CTree.Range from to _bounds) = do+  -- TODO Handle bounds correctly+  term1 <- genForNode from+  term2 <- genForNode 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+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+      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+      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+      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+          CTree.Postlude PTText ->+            genUniformRM (fromIntegral f1, fromIntegral t1)+              >>= (fmap (S . TString) . genText)+          CTree.Postlude PTBytes ->+            genUniformRM (fromIntegral f1, fromIntegral t1)+              >>= (fmap (S . TBytes) . genBytes)+          CTree.Postlude PTUInt ->+            S . TInteger+              <$> genUniformRM (fromIntegral f1, fromIntegral t1)+          _ -> error $ "Cannot apply size operator to target: " <> show tt+        _ ->+          error $+            "Invalid controller for .size operator: "+              <> show controller+    (CtlOp.Size, _) ->+      error $+        "Invalid controller for .size operator: "+          <> show controller+    (CtlOp.Cbor, _) -> do+      enc <- genForCTree ct+      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+  case tree of+    CTree.Group nodes -> do+      ix <- genUniformRM (0, length nodes)+      genForNode $ nodes !! ix+    _ -> error "Attempt to form an enum from something other than a group"+genForCTree (CTree.Unwrap node) = genForCTree =<< resolveIfRef node+genForCTree (CTree.Tag tag node) = do+  enc <- genForNode node+  case enc of+    S x -> pure $ S $ TTagged tag x+    _ -> error "Tag controller does not correspond to a single term"++genForNode :: RandomGen g => CTree.Node MonoRef -> M g WrappedTerm+genForNode = genForCTree <=< resolveIfRef++-- | 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+  (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++-- | Generate a CBOR Term corresponding to a top-level name.+--+-- Since we apply this to a monomorphised CTree, the names must be monomorphic+-- terms in the original CDDL.+--+-- 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 n = do+  (CTreeRoot cddl) <- ask @"cddl"+  case Map.lookup n cddl of+    Nothing -> error $ "Unbound reference: " <> show n+    Just val ->+      genForNode (runIdentity val) >>= \case+        S x -> pure x+        _ ->+          error $+            "Tried to generate a top-level term for "+              <> show n+              <> ", but it does not correspond to a single term."++-- | Apply an occurence indicator to a group entry+applyOccurenceIndicator ::+  RandomGen g =>+  OccurrenceIndicator ->+  M g WrappedTerm ->+  M g WrappedTerm+applyOccurenceIndicator OIOptional oldGen =+  genDepthBiasedBool >>= \case+    False -> pure $ G mempty+    True -> oldGen+applyOccurenceIndicator OIZeroOrMore oldGen =+  genDepthBiasedRM (0 :: Int, 10) >>= \i ->+    G <$> replicateM i oldGen+applyOccurenceIndicator OIOneOrMore oldGen =+  genDepthBiasedRM (1 :: Int, 10) >>= \i ->+    G <$> replicateM i oldGen+applyOccurenceIndicator (OIBounded mlb mub) oldGen =+  genDepthBiasedRM (fromMaybe 0 mlb :: Word64, fromMaybe 10 mub)+    >>= \i -> G <$> replicateM (fromIntegral i) oldGen++genValue :: RandomGen g => Value -> M g Term+genValue (Value x _) = genValueVariant x++genValueVariant :: RandomGen g => ValueVariant -> M g Term+genValueVariant (VUInt i) = pure . TInt $ fromIntegral i+genValueVariant (VNInt i) = pure . TInt $ fromIntegral (-i)+genValueVariant (VBignum i) = pure $ TInteger i+genValueVariant (VFloat16 i) = pure . THalf $ i+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 (VBool b) = pure $ TBool b++--------------------------------------------------------------------------------+-- Generator functions+--------------------------------------------------------------------------------++generateCBORTerm :: RandomGen g => CTreeRoot' Identity MonoRef -> Name -> g -> Term+generateCBORTerm cddl n stdGen =+  let genEnv = GenEnv {cddl, fakeSeed = CapGenM}+      genState = GenState {randomSeed = stdGen, depth = 1}+   in evalGen (genForName n) genEnv genState++generateCBORTerm' :: RandomGen g => CTreeRoot' Identity MonoRef -> Name -> g -> (Term, g)+generateCBORTerm' cddl n stdGen =+  let genEnv = GenEnv {cddl, fakeSeed = CapGenM}+      genState = GenState {randomSeed = stdGen, depth = 1}+   in second randomSeed $ runGen (genForName n) genEnv genState
+ src/Codec/CBOR/Cuddle/CBOR/Validator.hs view
@@ -0,0 +1,1013 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ViewPatterns #-}+{-# OPTIONS_GHC -Wno-incomplete-patterns #-}++module Codec.CBOR.Cuddle.CBOR.Validator where++import Codec.CBOR.Cuddle.CDDL hiding (CDDL, Group, Rule)+import Codec.CBOR.Cuddle.CDDL.CTree+import Codec.CBOR.Cuddle.CDDL.CtlOp+import Codec.CBOR.Cuddle.CDDL.Postlude+import Codec.CBOR.Cuddle.CDDL.Resolve+import Codec.CBOR.Read+import Codec.CBOR.Term+import Control.Exception+import Control.Monad ((>=>))+import Control.Monad.Reader+import Data.Bifunctor+import Data.Bits hiding (And)+import Data.ByteString qualified as BS+import Data.ByteString.Lazy qualified as BSL+import Data.Function ((&))+import Data.Functor ((<&>))+import Data.Functor.Identity+import Data.IntSet qualified as IS+import Data.List.NonEmpty qualified as NE+import Data.Map.Strict qualified as Map+import Data.Maybe+import Data.Text qualified as T+import Data.Text.Lazy qualified as TL+import Data.Word+import GHC.Float+import System.Exit+import System.IO+import Text.Regex.TDFA++type CDDL = CTreeRoot' Identity MonoRef+type Rule = Node MonoRef+type ResolvedRule = CTree MonoRef++data CBORTermResult = CBORTermResult Term CDDLResult+  deriving (Show)++data CDDLResult+  = -- | The rule was valid+    Valid Rule+  | -- | All alternatives failed+    ChoiceFail+      -- | Rule we are trying+      Rule+      -- | The alternatives that arise from said rule+      (NE.NonEmpty Rule)+      -- | For each alternative, the result+      (NE.NonEmpty (Rule, CDDLResult))+  | -- | All expansions failed+    --+    -- An expansion is: Given a CBOR @TList@ of @N@ elements, we will expand the+    -- rules in a list spec to match the number of items in the list.+    ListExpansionFail+      -- | Rule we are trying+      Rule+      -- | List of expansions of rules+      [[Rule]]+      -- | For each expansion, for each of the rules in the expansion, the result+      [[(Rule, CBORTermResult)]]+  | -- | All expansions failed+    --+    -- An expansion is: Given a CBOR @TMap@ of @N@ elements, we will expand the+    -- rules in a map spec to match the number of items in the map.+    MapExpansionFail+      -- | Rule we are trying+      Rule+      -- | List of expansions+      [[Rule]]+      -- | A list of matched items @(key, value, rule)@ and the unmatched item+      [([AMatchedItem], ANonMatchedItem)]+  | -- | The rule was valid but the control failed+    InvalidControl+      -- | Control we are trying+      Rule+      -- | If it is a .cbor, the result of the underlying validation+      (Maybe CBORTermResult)+  | InvalidRule Rule+  | -- | A tagged was invalid+    InvalidTagged+      -- | Rule we are trying+      Rule+      -- | Either the tag is wrong, or the contents are wrong+      (Either Word64 CBORTermResult)+  | -- | The rule we are trying is not applicable to the CBOR term+    UnapplicableRule+      -- | Rule we are trying+      Rule+  deriving (Show)++data ANonMatchedItem = ANonMatchedItem+  { anmiKey :: Term+  , anmiValue :: Term+  , anmiResults :: [Either (Rule, CDDLResult) (Rule, CDDLResult, CDDLResult)]+  -- ^ For all the tried rules, either the key failed or the key succeeded and+  -- the value failed+  }+  deriving (Show)++data AMatchedItem = AMatchedItem+  { amiKey :: Term+  , amiValue :: Term+  , amiRule :: Rule+  }+  deriving (Show)++--------------------------------------------------------------------------------+-- Main entry point++validateCBOR :: BS.ByteString -> Name -> CDDL -> IO ()+validateCBOR bs rule cddl =+  ( case validateCBOR' bs rule cddl of+      ok@(CBORTermResult _ (Valid _)) -> do+        putStrLn $ "Valid " ++ show ok+        exitSuccess+      err -> do+        hPutStrLn stderr $ "Invalid " ++ show err+        exitFailure+  )+    `catch` ( \(e :: PatternMatchFail) ->+                putStrLn $+                  "You uncovered a path we thought was impossible! Please submit your CDDL and CBOR to `https://github.com/input-output-hk/cuddle/issues` for us to investigate\n"+                    <> displayException e+            )++validateCBOR' ::+  BS.ByteString -> Name -> CDDL -> CBORTermResult+validateCBOR' bs rule cddl@(CTreeRoot tree) =+  case deserialiseFromBytes decodeTerm (BSL.fromStrict bs) of+    Left e -> error $ show e+    Right (rest, term) ->+      if BSL.null rest+        then runReader (validateTerm term (runIdentity $ tree Map.! rule)) cddl+        else runReader (validateTerm (TBytes bs) (runIdentity $ tree Map.! rule)) cddl++--------------------------------------------------------------------------------+-- Terms++-- | Core function that validates a CBOR term to a particular rule of the CDDL+-- spec+validateTerm ::+  MonadReader CDDL m =>+  Term -> Rule -> m CBORTermResult+validateTerm term rule =+  let f = case term of+        TInt i -> validateInteger (fromIntegral i)+        TInteger i -> validateInteger i+        TBytes b -> validateBytes b+        TBytesI b -> validateBytes (BSL.toStrict b)+        TString s -> validateText s+        TStringI s -> validateText (TL.toStrict s)+        TList ts -> validateList ts+        TListI ts -> validateList ts+        TMap ts -> validateMap ts+        TMapI ts -> validateMap ts+        TTagged w t -> validateTagged w t+        TBool b -> validateBool b+        TNull -> validateNull+        TSimple s -> validateSimple s+        THalf h -> validateHalf h+        TFloat h -> validateFloat h+        TDouble d -> validateDouble d+   in CBORTermResult term <$> f rule++--------------------------------------------------------------------------------+-- Ints and integers++-- | Validation of an Int or Integer. CBOR categorizes every integral in `TInt`+-- or `TInteger` but it can be the case that we are decoding something that is+-- expected to be a `Word64` even if we get a `TInt`.+--+-- > ghci> encodeWord64 15+-- > [TkInt 15]+-- > ghci> encodeWord64 maxBound+-- > [TkInteger 18446744073709551615]+--+-- For this reason, we cannot assume that bounds or literals are going to be+-- Ints, so we convert everything to Integer.+validateInteger ::+  MonadReader CDDL m =>+  Integer -> Rule -> m CDDLResult+validateInteger i rule =+  ($ rule) <$> do+    getRule rule >>= \case+      -- echo "C24101" | xxd -r -p - example.cbor+      -- echo "foo = int" > a.cddl+      -- cddl a.cddl validate example.cbor+      --+      -- but+      --+      -- echo "C249010000000000000000"| xxd -r -p - example.cbor+      -- echo "foo = int" > a.cddl+      -- cddl a.cddl validate example.cbor+      --+      -- and they are both bigints?++      -- a = any+      Postlude PTAny -> pure Valid+      -- a = int+      Postlude PTInt -> pure Valid+      -- a = uint+      Postlude PTUInt -> pure $ check (i >= 0)+      -- a = nint+      Postlude PTNInt -> pure $ check (i <= 0)+      -- a = x+      Literal (Value (VUInt i') _) -> pure $ check $ i == fromIntegral i'+      -- a = -x+      Literal (Value (VNInt i') _) -> pure $ check $ -i == fromIntegral i'+      -- a = <big number>+      Literal (Value (VBignum i') _) -> pure $ check $ i == i'+      -- a = foo .ctrl bar+      Control op tgt ctrl -> ctrlDispatch (validateInteger i) op tgt ctrl (controlInteger i)+      -- a = foo / bar+      Choice opts -> validateChoice (validateInteger i) opts+      -- a = x..y+      Range low high bound ->+        ((,) <$> getRule low <*> getRule high)+          <&> check . \case+            (Literal (Value (VUInt (fromIntegral -> n)) _), Literal (Value (VUInt (fromIntegral -> m)) _)) -> n <= i && range bound i m+            (Literal (Value (VNInt (fromIntegral -> n)) _), Literal (Value (VUInt (fromIntegral -> m)) _)) -> -n <= i && range bound i m+            (Literal (Value (VNInt (fromIntegral -> n)) _), Literal (Value (VNInt (fromIntegral -> m)) _)) -> -n <= i && range bound i (-m)+            (Literal (Value VUInt {} _), Literal (Value VNInt {} _)) -> False+            (Literal (Value (VBignum n) _), Literal (Value (VUInt (fromIntegral -> m)) _)) -> n <= i && range bound i m+            (Literal (Value (VBignum n) _), Literal (Value (VNInt (fromIntegral -> m)) _)) -> n <= i && range bound i (-m)+            (Literal (Value (VUInt (fromIntegral -> n)) _), Literal (Value (VBignum m) _)) -> n <= i && range bound i m+            (Literal (Value (VNInt (fromIntegral -> n)) _), Literal (Value (VBignum m) _)) -> (-n) <= i && range bound i m+      -- a = &(x, y, z)+      Enum g ->+        getRule g >>= \case+          Group g' -> validateInteger i (MIt (Choice (NE.fromList g'))) <&> replaceRule+      -- a = x: y+      -- Note KV cannot appear on its own, but we will use this when validating+      -- lists.+      KV _ v _ -> validateInteger i v <&> replaceRule+      Tag 2 (MIt (Postlude PTBytes)) -> pure Valid+      Tag 3 (MIt (Postlude PTBytes)) -> pure Valid+      _ -> pure UnapplicableRule++-- | Controls for an Integer+controlInteger ::+  forall m. MonadReader CDDL m => Integer -> CtlOp -> Rule -> m (Either (Maybe CBORTermResult) ())+controlInteger i Size ctrl =+  getRule ctrl <&> \case+    Literal (Value (VUInt sz) _) ->+      boolCtrl $ 0 <= i && i < 256 ^ sz+controlInteger i Bits ctrl = do+  indices <-+    getRule ctrl >>= \case+      Literal (Value (VUInt i') _) -> pure [i']+      Choice nodes -> getIndicesOfChoice nodes+      Range ff tt incl -> getIndicesOfRange ff tt incl+      Enum g -> getIndicesOfEnum g+  pure $ boolCtrl $ go (IS.fromList (map fromIntegral indices)) i 0+  where+    go _ 0 _ = True+    go indices n idx =+      let bitSet = testBit n 0+          allowed = not bitSet || IS.member idx indices+       in (allowed && go indices (shiftR n 1) (idx + 1))+controlInteger i Lt ctrl =+  getRule ctrl+    <&> boolCtrl . \case+      Literal (Value (VUInt i') _) -> i < fromIntegral i'+      Literal (Value (VNInt i') _) -> i < -fromIntegral i'+      Literal (Value (VBignum i') _) -> i < i'+controlInteger i Gt ctrl =+  getRule ctrl+    <&> boolCtrl . \case+      Literal (Value (VUInt i') _) -> i > fromIntegral i'+      Literal (Value (VNInt i') _) -> i > -fromIntegral i'+      Literal (Value (VBignum i') _) -> i > i'+controlInteger i Le ctrl =+  getRule ctrl+    <&> boolCtrl . \case+      Literal (Value (VUInt i') _) -> i <= fromIntegral i'+      Literal (Value (VNInt i') _) -> i <= -fromIntegral i'+      Literal (Value (VBignum i') _) -> i <= i'+controlInteger i Ge ctrl =+  getRule ctrl+    <&> boolCtrl . \case+      Literal (Value (VUInt i') _) -> i >= fromIntegral i'+      Literal (Value (VNInt i') _) -> i >= -fromIntegral i'+      Literal (Value (VBignum i') _) -> i >= i'+controlInteger i Eq ctrl =+  getRule ctrl+    <&> boolCtrl . \case+      Literal (Value (VUInt i') _) -> i == fromIntegral i'+      Literal (Value (VNInt i') _) -> i == -fromIntegral i'+      Literal (Value (VBignum i') _) -> i == i'+controlInteger i Ne ctrl =+  getRule ctrl+    <&> boolCtrl . \case+      Literal (Value (VUInt i') _) -> i /= fromIntegral i'+      Literal (Value (VNInt i') _) -> i /= -fromIntegral i'+      Literal (Value (VBignum i') _) -> i /= i'++--------------------------------------------------------------------------------+-- Floating point (Float16, Float32, Float64)+--+-- As opposed to Integral types, there seems to be no ambiguity when encoding+-- and decoding floating-point numbers.++-- | Validating a `Float16`+validateHalf ::+  MonadReader CDDL m =>+  Float -> Rule -> m CDDLResult+validateHalf f rule =+  ($ rule) <$> do+    getRule rule >>= \case+      -- a = any+      Postlude PTAny -> pure Valid+      -- a = float16+      Postlude PTHalf -> pure Valid+      -- a = 0.5+      Literal (Value (VFloat16 f') _) -> pure $ check $ f == f'+      -- a = foo / bar+      Choice opts -> validateChoice (validateHalf f) opts+      -- a = foo .ctrl bar+      Control op tgt ctrl -> ctrlDispatch (validateHalf f) op tgt ctrl (controlHalf f)+      -- a = x..y+      Range low high bound ->+        ((,) <$> getRule low <*> getRule high)+          <&> check . \case+            (Literal (Value (VFloat16 n) _), Literal (Value (VFloat16 m) _)) -> n <= f && range bound f m+      _ -> pure UnapplicableRule++-- | Controls for `Float16`+controlHalf :: MonadReader CDDL m => Float -> CtlOp -> Rule -> m (Either (Maybe CBORTermResult) ())+controlHalf f Eq ctrl =+  getRule ctrl+    <&> boolCtrl . \case+      Literal (Value (VFloat16 f') _) -> f == f'+controlHalf f Ne ctrl =+  getRule ctrl+    <&> boolCtrl . \case+      Literal (Value (VFloat16 f') _) -> f /= f'++-- | Validating a `Float32`+validateFloat ::+  MonadReader CDDL m =>+  Float -> Rule -> m CDDLResult+validateFloat f rule =+  ($ rule) <$> do+    getRule rule >>= \case+      -- a = any+      Postlude PTAny -> pure Valid+      -- a = float32+      Postlude PTFloat -> pure Valid+      -- a = 0.000000005+      -- TODO: it is unclear if smaller floats should also validate+      Literal (Value (VFloat32 f') _) -> pure $ check $ f == f'+      -- a = foo / bar+      Choice opts -> validateChoice (validateFloat f) opts+      -- a = foo .ctrl bar+      Control op tgt ctrl -> ctrlDispatch (validateFloat f) op tgt ctrl (controlFloat f)+      -- a = x..y+      -- TODO it is unclear if this should mix floating point types too+      Range low high bound ->+        ((,) <$> getRule low <*> getRule high)+          <&> check . \case+            (Literal (Value (VFloat16 n) _), Literal (Value (VFloat16 m) _)) -> n <= f && range bound f m+            (Literal (Value (VFloat32 n) _), Literal (Value (VFloat32 m) _)) -> n <= f && range bound f m+      _ -> pure UnapplicableRule++-- | Controls for `Float32`+controlFloat :: MonadReader CDDL m => Float -> CtlOp -> Rule -> m (Either (Maybe CBORTermResult) ())+controlFloat f Eq ctrl =+  getRule ctrl+    <&> boolCtrl . \case+      Literal (Value (VFloat16 f') _) -> f == f'+      Literal (Value (VFloat32 f') _) -> f == f'+controlFloat f Ne ctrl =+  getRule ctrl+    <&> boolCtrl . \case+      Literal (Value (VFloat16 f') _) -> f /= f'+      Literal (Value (VFloat32 f') _) -> f /= f'++-- | Validating a `Float64`+validateDouble ::+  MonadReader CDDL m =>+  Double -> Rule -> m CDDLResult+validateDouble f rule =+  ($ rule) <$> do+    getRule rule >>= \case+      -- a = any+      Postlude PTAny -> pure Valid+      -- a = float64+      Postlude PTDouble -> pure Valid+      -- a = 0.0000000000000000000000000000000000000000000005+      -- TODO: it is unclear if smaller floats should also validate+      Literal (Value (VFloat64 f') _) -> pure $ check $ f == f'+      -- a = foo / bar+      Choice opts -> validateChoice (validateDouble f) opts+      -- a = foo .ctrl bar+      Control op tgt ctrl -> ctrlDispatch (validateDouble f) op tgt ctrl (controlDouble f)+      -- a = x..y+      -- TODO it is unclear if this should mix floating point types too+      Range low high bound ->+        ((,) <$> getRule low <*> getRule high)+          <&> check . \case+            (Literal (Value (VFloat16 (float2Double -> n)) _), Literal (Value (VFloat16 (float2Double -> m)) _)) -> n <= f && range bound f m+            (Literal (Value (VFloat32 (float2Double -> n)) _), Literal (Value (VFloat32 (float2Double -> m)) _)) -> n <= f && range bound f m+            (Literal (Value (VFloat64 n) _), Literal (Value (VFloat64 m) _)) -> n <= f && range bound f m+      _ -> pure UnapplicableRule++-- | Controls for `Float64`+controlDouble ::+  MonadReader CDDL m => Double -> CtlOp -> Rule -> m (Either (Maybe CBORTermResult) ())+controlDouble f Eq ctrl =+  getRule ctrl+    <&> boolCtrl . \case+      Literal (Value (VFloat16 f') _) -> f == float2Double f'+      Literal (Value (VFloat32 f') _) -> f == float2Double f'+      Literal (Value (VFloat64 f') _) -> f == f'+controlDouble f Ne ctrl =+  getRule ctrl+    <&> boolCtrl . \case+      Literal (Value (VFloat16 f') _) -> f /= float2Double f'+      Literal (Value (VFloat32 f') _) -> f /= float2Double f'+      Literal (Value (VFloat64 f') _) -> f /= f'++--------------------------------------------------------------------------------+-- Bool++-- | Validating a boolean+validateBool ::+  MonadReader CDDL m =>+  Bool -> Rule -> m CDDLResult+validateBool b rule =+  ($ rule) <$> do+    getRule rule >>= \case+      -- a = any+      Postlude PTAny -> pure Valid+      -- a = bool+      Postlude PTBool -> pure Valid+      -- a = true+      Literal (Value (VBool b') _) -> pure $ check $ b == b'+      -- a = foo .ctrl bar+      Control op tgt ctrl -> ctrlDispatch (validateBool b) op tgt ctrl (controlBool b)+      -- a = foo / bar+      Choice opts -> validateChoice (validateBool b) opts+      _ -> pure UnapplicableRule++-- | Controls for `Bool`+controlBool :: MonadReader CDDL m => Bool -> CtlOp -> Rule -> m (Either (Maybe CBORTermResult) ())+controlBool b Eq ctrl =+  getRule ctrl+    <&> boolCtrl . \case+      Literal (Value (VBool b') _) -> b == b'+controlBool b Ne ctrl =+  getRule ctrl+    <&> boolCtrl . \case+      Literal (Value (VBool b') _) -> b /= b'++--------------------------------------------------------------------------------+-- Simple++-- | Validating a `TSimple`. It is unclear if this is used for anything else than undefined.+validateSimple ::+  MonadReader CDDL m =>+  Word8 -> Rule -> m CDDLResult+validateSimple 23 rule =+  ($ rule) <$> do+    getRule rule >>= \case+      -- a = any+      Postlude PTAny -> pure Valid+      -- a = undefined+      Postlude PTUndefined -> pure Valid+      -- a = foo / bar+      Choice opts -> validateChoice (validateSimple 23) opts+      _ -> pure UnapplicableRule+validateSimple n _ = error $ "Found simple different to 23! please report this somewhere! Found: " <> show n++--------------------------------------------------------------------------------+-- Null/nil++-- | Validating nil+validateNull ::+  MonadReader CDDL m => Rule -> m CDDLResult+validateNull rule =+  ($ rule) <$> do+    getRule rule >>= \case+      -- a = any+      Postlude PTAny -> pure Valid+      -- a = nil+      Postlude PTNil -> pure Valid+      Choice opts -> validateChoice validateNull opts+      _ -> pure UnapplicableRule++--------------------------------------------------------------------------------+-- Bytes++-- | Validating a byte sequence+validateBytes ::+  MonadReader CDDL m =>+  BS.ByteString -> Rule -> m CDDLResult+validateBytes bs rule =+  ($ rule) <$> do+    getRule rule >>= \case+      -- a = any+      Postlude PTAny -> pure Valid+      -- a = bytes+      Postlude PTBytes -> pure Valid+      -- a = h'123456'+      Literal (Value (VBytes bs') _) -> pure $ check $ bs == bs'+      -- a = foo .ctrl bar+      Control op tgt ctrl -> ctrlDispatch (validateBytes bs) op tgt ctrl (controlBytes bs)+      -- a = foo / bar+      Choice opts -> validateChoice (validateBytes bs) opts+      _ -> pure UnapplicableRule++-- | Controls for byte strings+controlBytes ::+  forall m.+  MonadReader CDDL m => BS.ByteString -> CtlOp -> Rule -> m (Either (Maybe CBORTermResult) ())+controlBytes bs Size ctrl =+  getRule ctrl >>= \case+    Literal (Value (VUInt (fromIntegral -> sz)) _) -> pure $ boolCtrl $ BS.length bs == sz+    Range low high bound ->+      let i = BS.length bs+       in ((,) <$> getRule low <*> getRule high)+            <&> boolCtrl . \case+              (Literal (Value (VUInt (fromIntegral -> n)) _), Literal (Value (VUInt (fromIntegral -> m)) _)) -> n <= i && range bound i m+              (Literal (Value (VNInt (fromIntegral -> n)) _), Literal (Value (VUInt (fromIntegral -> m)) _)) -> -n <= i && range bound i m+              (Literal (Value (VNInt (fromIntegral -> n)) _), Literal (Value (VNInt (fromIntegral -> m)) _)) -> -n <= i && range bound i (-m)+              (Literal (Value VUInt {} _), Literal (Value VNInt {} _)) -> False+controlBytes bs Bits ctrl = do+  indices <-+    getRule ctrl >>= \case+      Literal (Value (VUInt i') _) -> pure [i']+      Choice nodes -> getIndicesOfChoice nodes+      Range ff tt incl -> getIndicesOfRange ff tt incl+      Enum g -> getIndicesOfEnum g+  pure $ boolCtrl $ bitsControlCheck (map fromIntegral indices)+  where+    bitsControlCheck :: [Int] -> Bool+    bitsControlCheck allowedBits =+      let allowedSet = IS.fromList allowedBits+          totalBits = BS.length bs * 8+          isAllowedBit n =+            let byteIndex = n `shiftR` 3+                bitIndex = n .&. 7+             in case BS.indexMaybe bs byteIndex of+                  Just byte -> not (testBit byte bitIndex) || IS.member n allowedSet+                  Nothing -> True+       in all isAllowedBit [0 .. totalBits - 1]+controlBytes bs Cbor ctrl =+  case deserialiseFromBytes decodeTerm (BSL.fromStrict bs) of+    Right (BSL.null -> True, term) ->+      validateTerm term ctrl >>= \case+        CBORTermResult _ (Valid _) -> pure $ Right ()+        err -> pure $ Left $ Just err+controlBytes bs Cborseq ctrl =+  case deserialiseFromBytes decodeTerm (BSL.fromStrict (BS.snoc (BS.cons 0x9f bs) 0xff)) of+    Right (BSL.null -> True, TListI terms) ->+      validateTerm (TList terms) (MIt (Array [MIt (Occur ctrl OIZeroOrMore)])) >>= \case+        CBORTermResult _ (Valid _) -> pure $ Right ()+        CBORTermResult _ err -> error $ show err++--------------------------------------------------------------------------------+-- Text++-- | Validating text strings+validateText ::+  MonadReader CDDL m =>+  T.Text -> Rule -> m CDDLResult+validateText txt rule =+  ($ rule) <$> do+    getRule rule >>= \case+      -- a = any+      Postlude PTAny -> pure Valid+      -- a = text+      Postlude PTText -> pure Valid+      -- a = "foo"+      Literal (Value (VText txt') _) -> pure $ check $ txt == txt'+      -- a = foo .ctrl bar+      Control op tgt ctrl -> ctrlDispatch (validateText txt) op tgt ctrl (controlText txt)+      -- a = foo / bar+      Choice opts -> validateChoice (validateText txt) opts+      _ -> pure UnapplicableRule++-- | Controls for text strings+controlText :: MonadReader CDDL m => T.Text -> CtlOp -> Rule -> m (Either (Maybe CBORTermResult) ())+controlText bs Size ctrl =+  getRule ctrl >>= \case+    Literal (Value (VUInt (fromIntegral -> sz)) _) -> pure $ boolCtrl $ T.length bs == sz+    Range ff tt bound ->+      ((,) <$> getRule ff <*> getRule tt)+        <&> boolCtrl . \case+          (Literal (Value (VUInt (fromIntegral -> n)) _), Literal (Value (VUInt (fromIntegral -> m)) _)) -> n <= T.length bs && range bound (T.length bs) m+          (Literal (Value (VNInt (fromIntegral -> n)) _), Literal (Value (VUInt (fromIntegral -> m)) _)) -> -n <= T.length bs && range bound (T.length bs) m+          (Literal (Value (VNInt (fromIntegral -> n)) _), Literal (Value (VNInt (fromIntegral -> m)) _)) -> -n <= T.length bs && range bound (T.length bs) (-m)+controlText s Regexp ctrl =+  getRule ctrl+    <&> boolCtrl . \case+      Literal (Value (VText rxp) _) -> case s =~ rxp :: (T.Text, T.Text, T.Text) of+        ("", s', "") -> s == s'++--------------------------------------------------------------------------------+-- Tagged values++-- | Validating a `TTagged`+validateTagged ::+  MonadReader CDDL m =>+  Word64 -> Term -> Rule -> m CDDLResult+validateTagged tag term rule =+  ($ rule) <$> do+    getRule rule >>= \case+      Postlude PTAny -> pure Valid+      Tag tag' rule' ->+        -- If the tag does not match, this is a direct fail+        if tag == tag'+          then+            ask >>= \cddl ->+              case runReader (validateTerm term rule') cddl of+                CBORTermResult _ (Valid _) -> pure Valid+                err -> pure $ \r -> InvalidTagged r (Right err)+          else pure $ \r -> InvalidTagged r (Left tag)+      Choice opts -> validateChoice (validateTagged tag term) opts+      _ -> pure UnapplicableRule++--------------------------------------------------------------------------------+-- Collection helpers++-- | Groups might contain enums, or unwraps inside. This resolves all those to+-- the top level of the group.+flattenGroup :: CDDL -> [Rule] -> [Rule]+flattenGroup cddl nodes =+  mconcat+    [ case resolveIfRef cddl rule of+        Literal {} -> [rule]+        Postlude {} -> [rule]+        Map {} -> [rule]+        Array {} -> [rule]+        Choice {} -> [rule]+        KV {} -> [rule]+        Occur {} -> [rule]+        Range {} -> [rule]+        Control {} -> [rule]+        Enum e -> case resolveIfRef cddl e of+          Group g -> flattenGroup cddl g+          _ -> error "Malformed cddl"+        Unwrap g -> case resolveIfRef cddl g of+          Map n -> flattenGroup cddl n+          Array n -> flattenGroup cddl n+          Tag _ n -> [n]+          _ -> error "Malformed cddl"+        Tag {} -> [rule]+        Group g -> flattenGroup cddl g+    | rule <- nodes+    ]++-- | Expand rules to reach exactly the wanted length, which must be the number+-- of items in the container. For example, if we want to validate 3 elements,+-- and we have the following CDDL:+--+-- > a = [* int, * bool]+--+-- this will be expanded to `[int, int, int], [int, int, bool], [int, bool,+-- bool], [bool, bool, bool]`.+--+-- Essentially the rules we will parse is the choice among the expansions of the+-- original rules.+expandRules :: Int -> [Rule] -> Reader CDDL [[Rule]]+expandRules remainingLen []+  | remainingLen /= 0 = pure []+expandRules _ [] = pure [[]]+expandRules remainingLen _+  | remainingLen < 0 = pure []+  | remainingLen == 0 = pure [[]]+expandRules remainingLen (x : xs) = do+  y <- expandRule remainingLen x+  concat+    <$> mapM+      ( \y' -> do+          suffixes <- expandRules (remainingLen - length y') xs+          pure [y' ++ ys' | ys' <- suffixes]+      )+      y++expandRule :: Int -> Rule -> Reader CDDL [[Rule]]+expandRule maxLen _+  | maxLen < 0 = pure []+expandRule maxLen rule =+  getRule rule >>= \case+    Occur o OIOptional -> pure $ [] : [[o] | maxLen > 0]+    Occur o OIZeroOrMore -> ([] :) <$> expandRule maxLen (MIt (Occur o OIOneOrMore))+    Occur o OIOneOrMore ->+      if maxLen > 0+        then ([o] :) . map (o :) <$> expandRule (maxLen - 1) (MIt (Occur o OIOneOrMore))+        else pure []+    Occur o (OIBounded low high) -> case (low, high) of+      (Nothing, Nothing) -> expandRule maxLen (MIt (Occur o OIZeroOrMore))+      (Just (fromIntegral -> low'), Nothing) ->+        if maxLen >= low'+          then map (replicate low' o ++) <$> expandRule (maxLen - low') (MIt (Occur o OIZeroOrMore))+          else pure []+      (Nothing, Just (fromIntegral -> high')) ->+        pure [replicate n o | n <- [0 .. min maxLen high']]+      (Just (fromIntegral -> low'), Just (fromIntegral -> high')) ->+        if maxLen >= low'+          then pure [replicate n o | n <- [low' .. min maxLen high']]+          else pure []+    _ -> pure [[rule | maxLen > 0]]++-- | Which rules are optional?+isOptional :: MonadReader CDDL m => Rule -> m Bool+isOptional rule =+  getRule rule+    <&> \case+      Occur _ OIOptional -> True+      Occur _ OIZeroOrMore -> True+      Occur _ (OIBounded Nothing _) -> True+      Occur _ (OIBounded (Just 0) _) -> True+      _ -> False++-- --------------------------------------------------------------------------------+-- -- Lists++validateListWithExpandedRules ::+  forall m.+  MonadReader CDDL m =>+  [Term] -> [Rule] -> m [(Rule, CBORTermResult)]+validateListWithExpandedRules terms rules =+  go (zip terms rules)+  where+    go ::+      [(Term, Rule)] -> m [(Rule, CBORTermResult)]+    go [] = pure []+    go ((t, r) : ts) =+      getRule r >>= \case+        -- Should the rule be a KV, then we validate the rule for the value+        KV _ v _ ->+          -- We need to do this juggling because validateTerm has a different+          -- error type+          ask >>= \cddl ->+            case runReader (validateTerm t v) cddl of+              ok@(CBORTermResult _ (Valid _)) -> ((r, ok) :) <$> go ts+              err -> pure [(r, err)]+        _ ->+          ask >>= \cddl ->+            case runReader (validateTerm t r) cddl of+              ok@(CBORTermResult _ (Valid _)) -> ((r, ok) :) <$> go ts+              err -> pure [(r, err)]++validateExpandedList ::+  forall m.+  MonadReader CDDL m =>+  [Term] ->+  [[Rule]] ->+  m (Rule -> CDDLResult)+validateExpandedList terms rules = go rules+  where+    go :: [[Rule]] -> m (Rule -> CDDLResult)+    go [] = pure $ \r -> ListExpansionFail r rules []+    go (choice : choices) = do+      res <- validateListWithExpandedRules terms choice+      case res of+        [] -> pure Valid+        _ -> case last res of+          (_, CBORTermResult _ (Valid _)) -> pure Valid+          _ ->+            go choices+              >>= ( \case+                      Valid _ -> pure Valid+                      ListExpansionFail _ _ errors -> pure $ \r -> ListExpansionFail r rules (res : errors)+                  )+                . ($ dummyRule)++validateList ::+  MonadReader CDDL m => [Term] -> Rule -> m CDDLResult+validateList terms rule =+  ($ rule) <$> do+    getRule rule >>= \case+      Postlude PTAny -> pure Valid+      Array rules ->+        case terms of+          [] -> ifM (and <$> mapM isOptional rules) (pure Valid) (pure InvalidRule)+          _ ->+            ask >>= \cddl ->+              let sequencesOfRules =+                    runReader (expandRules (length terms) $ flattenGroup cddl rules) cddl+               in validateExpandedList terms sequencesOfRules+      Choice opts -> validateChoice (validateList terms) opts+      _ -> pure UnapplicableRule++--------------------------------------------------------------------------------+-- Maps++validateMapWithExpandedRules ::+  forall m.+  MonadReader CDDL m =>+  [(Term, Term)] -> [Rule] -> m ([AMatchedItem], Maybe ANonMatchedItem)+validateMapWithExpandedRules =+  go+  where+    go ::+      [(Term, Term)] ->+      [Rule] ->+      m ([AMatchedItem], Maybe ANonMatchedItem)+    go [] [] = pure ([], Nothing)+    go ((tk, tv) : ts) rs = do+      go' tk tv rs >>= \case+        Left tt -> pure ([], Just tt)+        Right (res, rs') ->+          first (res :) <$> go ts rs'++    -- For each pair of terms, try to find some rule that can be applied here,+    -- and returns the others if there is a succesful match.+    go' :: Term -> Term -> [Rule] -> m (Either ANonMatchedItem (AMatchedItem, [Rule]))+    go' tk tv [] = pure $ Left $ ANonMatchedItem tk tv []+    go' tk tv (r : rs) =+      getRule r >>= \case+        KV k v _ ->+          ask >>= \cddl ->+            case runReader (validateTerm tk k) cddl of+              CBORTermResult _ r1@(Valid _) -> case runReader (validateTerm tv v) cddl of+                CBORTermResult _ (Valid _) -> pure (Right (AMatchedItem tk tv r, rs))+                CBORTermResult _ r2 ->+                  bimap (\anmi -> anmi {anmiResults = Right (r, r1, r2) : anmiResults anmi}) (second (r :))+                    <$> go' tk tv rs+              CBORTermResult _ r1 ->+                bimap (\anmi -> anmi {anmiResults = Left (r, r1) : anmiResults anmi}) (second (r :))+                  <$> go' tk tv rs++validateExpandedMap ::+  forall m.+  MonadReader CDDL m =>+  [(Term, Term)] ->+  [[Rule]] ->+  m (Rule -> CDDLResult)+validateExpandedMap terms rules = go rules+  where+    go :: [[Rule]] -> m (Rule -> CDDLResult)+    go [] = pure $ \r -> MapExpansionFail r rules []+    go (choice : choices) = do+      res <- validateMapWithExpandedRules terms choice+      case res of+        (_, Nothing) -> pure Valid+        (matches, Just notMatched) ->+          go choices+            >>= ( \case+                    Valid _ -> pure Valid+                    MapExpansionFail _ _ errors ->+                      pure $ \r -> MapExpansionFail r rules ((matches, notMatched) : errors)+                )+              . ($ dummyRule)++validateMap ::+  MonadReader CDDL m =>+  [(Term, Term)] -> Rule -> m CDDLResult+validateMap terms rule =+  ($ rule) <$> do+    getRule rule >>= \case+      Postlude PTAny -> pure Valid+      Map rules ->+        case terms of+          [] -> ifM (and <$> mapM isOptional rules) (pure Valid) (pure InvalidRule)+          _ ->+            ask >>= \cddl ->+              let sequencesOfRules =+                    runReader (expandRules (length terms) $ flattenGroup cddl rules) cddl+               in validateExpandedMap terms sequencesOfRules+      Choice opts -> validateChoice (validateMap terms) opts+      _ -> pure UnapplicableRule++--------------------------------------------------------------------------------+-- Choices++validateChoice ::+  forall m. Monad m => (Rule -> m CDDLResult) -> NE.NonEmpty Rule -> m (Rule -> CDDLResult)+validateChoice v rules = go rules+  where+    go :: NE.NonEmpty Rule -> m (Rule -> CDDLResult)+    go (choice NE.:| xs) = do+      v choice >>= \case+        Valid _ -> pure Valid+        err -> case NE.nonEmpty xs of+          Nothing -> pure $ \r -> ChoiceFail r rules ((choice, err) NE.:| [])+          Just choices ->+            go choices+              >>= ( \case+                      Valid _ -> pure Valid+                      ChoiceFail _ _ errors -> pure $ \r -> ChoiceFail r rules ((choice, err) NE.<| errors)+                  )+                . ($ dummyRule)++dummyRule :: Rule+dummyRule = MRuleRef (Name "dummy" mempty)++--------------------------------------------------------------------------------+-- Control helpers++-- | Validate both rules+ctrlAnd ::+  Monad m =>+  (Rule -> m CDDLResult) -> Rule -> Rule -> m (Rule -> CDDLResult)+ctrlAnd v tgt ctrl =+  v tgt >>= \case+    Valid _ ->+      v ctrl <&> \case+        Valid _ -> Valid+        _ -> flip InvalidControl Nothing+    _ -> pure InvalidRule++-- | Dispatch to the appropriate control+ctrlDispatch ::+  Monad m =>+  (Rule -> m CDDLResult) ->+  CtlOp ->+  Rule ->+  Rule ->+  (CtlOp -> Rule -> m (Either (Maybe CBORTermResult) ())) ->+  m (Rule -> CDDLResult)+ctrlDispatch v And tgt ctrl _ = ctrlAnd v tgt ctrl+ctrlDispatch v Within tgt ctrl _ = ctrlAnd v tgt ctrl+ctrlDispatch v op tgt ctrl vctrl =+  v tgt >>= \case+    Valid _ ->+      vctrl op ctrl <&> \case+        Left err -> flip InvalidControl err+        Right () -> Valid+    _ -> pure InvalidRule++-- | A boolean control+boolCtrl :: Bool -> Either (Maybe CBORTermResult) ()+boolCtrl c = if c then Right () else Left Nothing++--------------------------------------------------------------------------------+-- Bits control++getIndicesOfChoice :: MonadReader CDDL m => NE.NonEmpty Rule -> m [Word64]+getIndicesOfChoice nodes =+  mconcat+    . NE.toList+    <$> mapM+      ( getRule+          >=> ( \case+                  Literal (Value (VUInt v) _) -> pure [fromIntegral v]+                  KV _ v _ ->+                    getRule v+                      >>= \case+                        Literal (Value (VUInt v') _) -> pure [fromIntegral v']+                        somethingElse ->+                          error $+                            "Malformed value in KV in choice in .bits: "+                              <> show somethingElse+                  Range ff tt incl -> getIndicesOfRange ff tt incl+                  Enum g -> getIndicesOfEnum g+                  somethingElse ->+                    error $+                      "Malformed alternative in choice in .bits: "+                        <> show somethingElse+              )+      )+      nodes++getIndicesOfRange :: MonadReader CDDL m => Rule -> Rule -> RangeBound -> m [Word64]+getIndicesOfRange ff tt incl =+  ((,) <$> getRule ff <*> getRule tt) >>= \case+    (Literal (Value (VUInt ff') _), Literal (Value (VUInt tt') _)) ->+      pure $+        [ff' .. tt'] & case incl of+          ClOpen -> init+          Closed -> id+    somethingElse -> error $ "Malformed range in .bits: " <> show somethingElse++getIndicesOfEnum :: MonadReader CDDL m => Rule -> m [Word64]+getIndicesOfEnum g =+  getRule g >>= \case+    Group g' -> getIndicesOfChoice (fromJust $ NE.nonEmpty g')+    somethingElse -> error $ "Malformed enum in .bits: " <> show somethingElse++--------------------------------------------------------------------------------+-- Resolving rules from the CDDL spec++resolveIfRef :: CDDL -> Rule -> ResolvedRule+resolveIfRef _ (MIt aa) = aa+resolveIfRef ct@(CTreeRoot cddl) (MRuleRef n) = do+  case Map.lookup n cddl of+    Nothing -> error $ "Unbound reference: " <> show n+    Just val -> resolveIfRef ct $ runIdentity val++getRule :: MonadReader CDDL m => Rule -> m ResolvedRule+getRule rule = asks (`resolveIfRef` rule)++--------------------------------------------------------------------------------+-- Utils++replaceRule :: CDDLResult -> Rule -> CDDLResult+replaceRule (ChoiceFail _ a b) r = ChoiceFail r a b+replaceRule (ListExpansionFail _ a b) r = ListExpansionFail r a b+replaceRule (MapExpansionFail _ a b) r = MapExpansionFail r a b+replaceRule (InvalidTagged _ a) r = InvalidTagged r a+replaceRule InvalidRule {} r = InvalidRule r+replaceRule (InvalidControl _ a) r = InvalidControl r a+replaceRule UnapplicableRule {} r = UnapplicableRule r+replaceRule Valid {} r = Valid r++ifM :: Monad m => m Bool -> m a -> m a -> m a+ifM b t f = do b' <- b; if b' then t else f++check :: Bool -> Rule -> CDDLResult+check c = if c then Valid else InvalidRule++range :: Ord a => RangeBound -> a -> a -> Bool+range Closed = (<=)+range ClOpen = (<)
+ src/Codec/CBOR/Cuddle/CDDL.hs view
@@ -0,0 +1,484 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DerivingStrategies #-}++-- | This module defined the data structure of CDDL as specified in+--   https://datatracker.ietf.org/doc/rfc8610/+module Codec.CBOR.Cuddle.CDDL (+  CDDL (..),+  sortCDDL,+  cddlTopLevel,+  cddlRules,+  fromRules,+  fromRule,+  TopLevel (..),+  Name (..),+  Rule (..),+  TypeOrGroup (..),+  Assign (..),+  GenericArg (..),+  GenericParam (..),+  Type0 (..),+  Type1 (..),+  Type2 (..),+  TyOp (..),+  RangeBound (..),+  OccurrenceIndicator (..),+  Group (..),+  GroupEntry (..),+  GroupEntryVariant (..),+  MemberKey (..),+  Value (..),+  value,+  ValueVariant (..),+  GrpChoice (..),+  unwrap,+  compareRuleName,+) 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.Hashable (Hashable)+import Data.List.NonEmpty (NonEmpty (..))+import Data.List.NonEmpty qualified as NE+import Data.String (IsString (..))+import Data.Text qualified as T+import Data.TreeDiff (ToExpr)+import Data.Word (Word64, Word8)+import GHC.Generics (Generic)+import Optics.Core ((%), (.~))+import Optics.Getter (view)+import Optics.Lens (lens)++-- | 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)++-- | 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++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)++cddlRules :: CDDL -> NonEmpty Rule+cddlRules (CDDL _ x tls) = x :| concatMap getRule tls+  where+    getRule (TopLevelRule r) = [r]+    getRule _ = mempty++fromRules :: NonEmpty Rule -> CDDL+fromRules (x :| xs) = CDDL [] x $ TopLevelRule <$> xs++fromRule :: Rule -> CDDL+fromRule x = CDDL [] x []++instance Semigroup CDDL where+  CDDL aComments aHead aTail <> CDDL bComments bHead bTail =+    CDDL aComments aHead $+      aTail <> fmap TopLevelComment bComments <> (TopLevelRule bHead : bTail)++data TopLevel+  = TopLevelRule Rule+  | TopLevelComment Comment+  deriving (Eq, Generic, Show, ToExpr)++-- |+--  A name can consist of any of the characters from the set {"A" to+--  "Z", "a" to "z", "0" to "9", "_", "-", "@", ".", "$"}, starting+--  with an alphabetic character (including "@", "_", "$") and ending+--  in such a character or a digit.+--+--  *  Names are case sensitive.+--+--  *  It is preferred style to start a name with a lowercase letter.+--+--  *  The hyphen is preferred over the underscore (except in a+--      "bareword" (Section 3.5.1), where the semantics may actually+--      require an underscore).+--+--  *  The period may be useful for larger specifications, to express+--      some module structure (as in "tcp.throughput" vs.+--      "udp.throughput").+--+--  *  A number of names are predefined in the CDDL prelude, as listed+--      in Appendix D.+--+--  *  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)++instance IsString Name where+  fromString x = Name (T.pack x) mempty++instance HasComment Name where+  commentL = lens nameComment (\x y -> x {nameComment = y})++instance CollectComments Name where+  collectComments (Name _ c) = [c]++instance Hashable Name++-- |+--   assignt = "=" / "/="+--   assigng = "=" / "//="+--+--   A plain equals sign defines the rule name as the equivalent of the+--   expression to the right; it is an error if the name was already+--   defined with a different expression.  A "/=" or "//=" extends a named+--   type or a group by additional choices; a number of these could be+--   replaced by collecting all the right-hand sides and creating a single+--   rule with a type choice or a group choice built from the right-hand+--   sides in the order of the rules given.  (It is not an error to extend+--   a rule name that has not yet been defined; this makes the right-hand+--   side the first entry in the choice being created.)+data Assign = AssignEq | AssignExt+  deriving (Eq, Generic, Show)+  deriving anyclass (ToExpr)++-- |+--  Generics+--+--   Using angle brackets, the left-hand side of a rule can add formal+--   parameters after the name being defined, as in:+--+--      messages = message<"reboot", "now"> / message<"sleep", 1..100>+--      message<t, v> = {type: t, value: v}+--+--   When using a generic rule, the formal parameters are bound to the+--   actual arguments supplied (also using angle brackets), within the+--   scope of the generic rule (as if there were a rule of the form+--   parameter = argument).+--+--   Generic rules can be used for establishing names for both types and+--   groups.+newtype GenericParam = GenericParam (NE.NonEmpty Name)+  deriving (Eq, Generic, Show)+  deriving newtype (Semigroup)+  deriving anyclass (ToExpr)++newtype GenericArg = GenericArg (NE.NonEmpty Type1)+  deriving (Eq, Generic, Show)+  deriving newtype (Semigroup)+  deriving anyclass (ToExpr)++instance CollectComments GenericArg++-- |+--  rule = typename [genericparm] S assignt S type+--        / groupname [genericparm] S assigng S grpent+--+--   typename = id+--   groupname = id+--+--   A rule defines a name for a type expression (production "type") or+--   for a group expression (production "grpent"), with the intention that+--   the semantics does not change when the name is replaced by its+--   (parenthesized if needed) definition.  Note that whether the name+--   defined by a rule stands for a type or a group isn't always+--   determined by syntax alone: e.g., "a = b" can make "a" a type if "b"+--   is a type, or a group if "b" is a group.  More subtly, in "a = (b)",+--   "a" may be used as a type if "b" is a type, or as a group both when+--   "b" is a group and when "b" is a type (a good convention to make the+--   latter case stand out to the human reader is to write "a = (b,)").+--   (Note that the same dual meaning of parentheses applies within an+--   expression but often can be resolved by the context of the+--   parenthesized expression.  On the more general point, it may not be+--   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+  { ruleName :: Name+  , ruleGenParam :: Maybe GenericParam+  , ruleAssign :: Assign+  , ruleTerm :: TypeOrGroup+  , ruleComment :: Comment+  }+  deriving (Eq, Generic, Show)+  deriving anyclass (ToExpr)++instance HasComment Rule where+  commentL = lens ruleComment (\x y -> x {ruleComment = y})++compareRuleName :: Rule -> Rule -> Ordering+compareRuleName = compare `on` ruleName++-- |+--   A range operator can be used to join two type expressions that stand+--   for either two integer values or two floating-point values; it+--   matches any value that is between the two values, where the first+--   value is always included in the matching set and the second value is+--   included for ".." and excluded for "...".+data RangeBound = ClOpen | Closed+  deriving (Eq, Generic, Show)+  deriving anyclass (ToExpr)++instance Hashable RangeBound++data TyOp = RangeOp RangeBound | CtrlOp CtlOp+  deriving (Eq, Generic, Show)+  deriving anyclass (ToExpr)++data TypeOrGroup = TOGType Type0 | TOGGroup GroupEntry+  deriving (Eq, Generic, Show)+  deriving anyclass (ToExpr)++instance CollectComments TypeOrGroup++{-- |+   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+   carries an internal data item that one would like to refer to.  In these+   cases, it is expedient to simply use the name of the map, array, or tag type+   as a handle for the group or type defined inside it.++   The "unwrap" operator (written by preceding a name by a tilde character "~")+   can be used to strip the type defined for a name by one layer, exposing the+   underlying group (for maps and arrays) or type (for tags).++   For example, an application might want to define a basic header and an+   advanced header.  Without unwrapping, this might be done as follows:++             basic-header-group = (+               field1: int,+               field2: text,+             )++             basic-header = [ basic-header-group ]++             advanced-header = [+               basic-header-group,+               field3: bytes,+               field4: number, ; as in the tagged type "time"+             ]++   Unwrapping simplifies this to:++                            basic-header = [+                              field1: int,+                              field2: text,+                            ]++                            advanced-header = [+                              ~basic-header,+                              field3: bytes,+                              field4: ~time,+                            ]++   (Note that leaving out the first unwrap operator in the latter example would+   lead to nesting the basic-header in its own array inside the advanced-header,+   while, with the unwrapped basic-header, the definition of the group inside+   basic-header is essentially repeated inside advanced-header, leading to a+   single array.  This can be used for various applications often solved by+   inheritance in programming languages.  The effect of unwrapping can also be+   described as "threading in" the group or type inside the referenced type,+   which suggested the thread-like "~" character.)+-}+unwrap :: TypeOrGroup -> Maybe Group+unwrap (TOGType (Type0 (Type1 t2 Nothing _ NE.:| []))) = case t2 of+  T2Map g -> Just g+  T2Array g -> Just g+  _ -> Nothing+unwrap _ = Nothing++-- |+-- 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)+  deriving newtype (Semigroup)+  deriving anyclass (ToExpr)++instance HasComment Type0 where+  commentL = lens (view commentL . t0Type1) (\(Type0 x) y -> Type0 $ x & commentL .~ y)++instance CollectComments Type0++-- |+-- Two types can be combined with a range operator (see below)+data Type1 = Type1+  { t1Main :: Type2+  , t1TyOp :: Maybe (TyOp, Type2)+  , t1Comment :: Comment+  }+  deriving (Eq, Generic, Show)+  deriving anyclass (ToExpr, Default)++instance HasComment Type1 where+  commentL = lens t1Comment (\x y -> x {t1Comment = y})++instance CollectComments Type1 where+  collectComments (Type1 m tyOp c) = c : collectComments m <> collectComments (fmap snd tyOp)++data Type2+  = -- | 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)+  | -- | or be defined in a parenthesized type expression (parentheses may be+    --   necessary to override some operator precedence),+    T2Group Type0+  | -- | 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+  | -- | 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+  | -- | 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)+  | -- | 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)+  | -- | a tagged data item, tagged with the "uint" given and containing the+    --  type given as the tagged value, or+    T2Tag (Maybe Word64) Type0+  | -- | 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)++instance CollectComments Type2++-- |+--  An optional _occurrence_ indicator can be given in front of a group+--  entry.  It is either (1) one of the characters "?" (optional), "*"+--  (zero or more), or "+" (one or more) or (2) of the form n*m, where n+--  and m are optional unsigned integers and n is the lower limit+--  (default 0) and m is the upper limit (default no limit) of+--  occurrences.+--+--  If no occurrence indicator is specified, the group entry is to occur+--  exactly once (as if 1*1 were specified).  A group entry with an+--  occurrence indicator matches sequences of name/value pairs that are+--  composed by concatenating a number of sequences that the basic group+--  entry matches, where the number needs to be allowed by the occurrence+--  indicator.+data OccurrenceIndicator+  = OIOptional+  | OIZeroOrMore+  | OIOneOrMore+  | OIBounded (Maybe Word64) (Maybe Word64)+  deriving (Eq, Generic, Show)+  deriving anyclass (ToExpr)++instance Hashable OccurrenceIndicator++-- |+--   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)+  deriving newtype (Semigroup)+  deriving anyclass (ToExpr)++instance HasComment Group where+  commentL = lens unGroup (\x y -> x {unGroup = y}) % commentL++instance CollectComments Group where+  collectComments (Group xs) = concatMap collectComments xs++data GrpChoice = GrpChoice+  { gcGroupEntries :: [GroupEntry]+  , gcComment :: Comment+  }+  deriving (Eq, Generic, Show)+  deriving anyclass (ToExpr)++instance HasComment GrpChoice where+  commentL = lens gcComment (\x y -> x {gcComment = y})++instance CollectComments GrpChoice where+  collectComments (GrpChoice ges c) = 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+--  type, which needs to be matched by the key part of the element, if+--  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+  { geOccurrenceIndicator :: Maybe OccurrenceIndicator+  , geComment :: Comment+  , geVariant :: GroupEntryVariant+  }+  deriving (Eq, Show, Generic, ToExpr)++instance CollectComments GroupEntry where+  collectComments (GroupEntry _ c x) = c : collectComments x++data GroupEntryVariant+  = GEType (Maybe MemberKey) Type0+  | GERef Name (Maybe GenericArg)+  | GEGroup Group+  deriving (Eq, Show, Generic, ToExpr)++instance HasComment GroupEntry where+  commentL = lens geComment (\x y -> x {geComment = y})++instance CollectComments GroupEntryVariant where+  collectComments (GEType _ t0) = collectComments t0+  collectComments (GERef n mga) = collectComments n <> collectComments mga+  collectComments (GEGroup g) = collectComments g++-- |+--  Key types can be given by a type expression, a bareword (which stands+--  for a type that just contains a string value created from this+--  bareword), or a value (which stands for a type that just contains+--  this value).  A key value matches its key type if the key value is a+--  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+  | MKBareword Name+  | MKValue Value+  deriving (Eq, Generic, Show)+  deriving anyclass (ToExpr)++data Value = Value ValueVariant Comment+  deriving (Eq, Generic, Show, Default)+  deriving anyclass (ToExpr, Hashable, CollectComments)++value :: ValueVariant -> Value+value x = Value x mempty++data ValueVariant+  = VUInt Word64+  | VNInt Word64+  | VBignum Integer+  | VFloat16 Float+  | VFloat32 Float+  | VFloat64 Double+  | VText T.Text+  | VBytes B.ByteString+  | VBool Bool+  deriving (Eq, Generic, Show, Default)+  deriving anyclass (ToExpr, Hashable, CollectComments)
+ src/Codec/CBOR/Cuddle/CDDL/CTree.hs view
@@ -0,0 +1,91 @@+{-# LANGUAGE DataKinds #-}++module Codec.CBOR.Cuddle.CDDL.CTree where++import Codec.CBOR.Cuddle.CDDL (+  Name,+  OccurrenceIndicator,+  RangeBound,+  Value,+ )+import Codec.CBOR.Cuddle.CDDL.CtlOp+import Codec.CBOR.Cuddle.CDDL.Postlude (PTerm)+import Data.Hashable (Hashable)+import Data.List.NonEmpty qualified as NE+import Data.Map.Strict qualified as Map+import Data.Word (Word64)+import GHC.Generics (Generic)++--------------------------------------------------------------------------------++-- * Resolved CDDL Tree++--+-- This is a simplified representation of CDDL. It is technically more general -+-- that is, the structure can represent invalid CDDL - but is in that way easier+-- 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+  = 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)+  deriving (Generic)++-- | 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+  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+  f' <- atNode f+  t' <- atNode t+  pure $ Range f' t' inc+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++type Node f = f (CTree f)++newtype CTreeRoot' poly f+  = CTreeRoot+      (Map.Map Name (poly (Node f)))+  deriving (Generic)++type CTreeRoot f = CTreeRoot' (ParametrisedWith [Name]) f++data ParametrisedWith w a+  = Unparametrised {underlying :: a}+  | Parametrised+      { underlying :: a+      , params :: w+      }+  deriving (Eq, Functor, Generic, Foldable, Traversable, Show)++instance (Hashable w, Hashable a) => Hashable (ParametrisedWith w a)
+ src/Codec/CBOR/Cuddle/CDDL/CtlOp.hs view
@@ -0,0 +1,40 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DerivingStrategies #-}++module Codec.CBOR.Cuddle.CDDL.CtlOp where++import Data.Hashable (Hashable)+import Data.TreeDiff (ToExpr)+import GHC.Generics (Generic)++-- | A _control_ allows relating a _target_ type with a _controller_ type+--  via a _control operator_.++--  The syntax for a control type is "target .control-operator+--  controller", where control operators are special identifiers prefixed+--  by a dot.  (Note that _target_ or _controller_ might need to be+--  parenthesized.)++--  A number of control operators are defined at this point.  Further+--  control operators may be defined by new versions of this+--  specification or by registering them according to the procedures in+--  Section 6.1.+data CtlOp+  = Size+  | Bits+  | Regexp+  | Cbor+  | Cborseq+  | Within+  | And+  | Lt+  | Le+  | Gt+  | Ge+  | Eq+  | Ne+  | Default+  deriving (Eq, Generic, Show)+  deriving anyclass (ToExpr)++instance Hashable CtlOp
+ src/Codec/CBOR/Cuddle/CDDL/Postlude.hs view
@@ -0,0 +1,55 @@+module Codec.CBOR.Cuddle.CDDL.Postlude where++import Data.Hashable (Hashable)+import GHC.Generics (Generic)++-- |+--+--  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 PTerm
+ src/Codec/CBOR/Cuddle/CDDL/Prelude.hs view
@@ -0,0 +1,61 @@+{-# LANGUAGE OverloadedStrings #-}++module Codec.CBOR.Cuddle.CDDL.Prelude (prependPrelude) where++import Codec.CBOR.Cuddle.CDDL (CDDL (..))+import Codec.CBOR.Cuddle.Parser (pCDDL)+import Text.Megaparsec (errorBundlePretty, parse)++-- TODO switch to quasiquotes+cddlPrelude :: CDDL+cddlPrelude =+  either (error . errorBundlePretty) id $+    parse+      pCDDL+      "<HARDCODED>"+      " any = # \+      \ uint = #0 \+      \ nint = #1 \+      \ int = uint / nint \+      \ \+      \ bstr = #2 \+      \ bytes = bstr \+      \ tstr = #3 \+      \ text = tstr \+      \ \+      \ tdate = #6.0(tstr) \+      \ time = #6.1(number) \+      \ number = int / float \+      \ biguint = #6.2(bstr) \+      \ bignint = #6.3(bstr) \+      \ bigint = biguint / bignint \+      \ integer = int / bigint \+      \ unsigned = uint / biguint \+      \ decfrac = #6.4([e10: int, m: integer]) \+      \ bigfloat = #6.5([e2: int, m: integer]) \+      \ eb64url = #6.21(any) \+      \ eb64legacy = #6.22(any) \+      \ eb16 = #6.23(any) \+      \ encoded-cbor = #6.24(bstr) \+      \ uri = #6.32(tstr) \+      \ b64url = #6.33(tstr) \+      \ b64legacy = #6.34(tstr) \+      \ regexp = #6.35(tstr) \+      \ mime-message = #6.36(tstr) \+      \ cbor-any = #6.55799(any) \+      \ float16 = #7.25 \+      \ float32 = #7.26 \+      \ float64 = #7.27 \+      \ float16-32 = float16 / float32 \+      \ float32-64 = float32 / float64 \+      \ float = float16-32 / float64 \+      \  \+      \ false = #7.20 \+      \ true = #7.21 \+      \ bool = false / true \+      \ nil = #7.22 \+      \ null = nil \+      \ undefined = #7.23"++prependPrelude :: CDDL -> CDDL+prependPrelude = (cddlPrelude <>)
+ src/Codec/CBOR/Cuddle/CDDL/Resolve.hs view
@@ -0,0 +1,563 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE ViewPatterns #-}++-- | Module containing tools for 'resolving' CDDL+--+-- Resolving the CDDL is a process of simplifying the representation to make+-- further operations, such as CBOR generation or validation, easier. We operate+-- with a number of passes:+--+-- 1. First, we deal with any rule extensions and create a single map from+--    identifiers to (potentially parametrised) entities.+-- 2. Second, we flatten the structure to a 'CTree', which discards a lot of the+--    extrenuous information.+-- 3. Then we resolve identifiers. Specifically, we do three things:+--    - Resolve identifiers that map to the postlude.+--    - Differentiate between generic args and references to top-level rules.+--    - Validate that all references exist. Note that we cannot resolve all+--    references since they may be circular.+-- 4. Finally, we monomorphise, synthesizing instances of rules with their+--    generic arguments bound.+module Codec.CBOR.Cuddle.CDDL.Resolve (+  buildResolvedCTree,+  buildRefCTree,+  asMap,+  buildMonoCTree,+  fullResolveCDDL,+  MonoRef (..),+  NameResolutionFailure (..),+)+where++import Capability.Accessors (Field (..), Lift (..))+import Capability.Error (HasThrow, MonadError (..), throw)+import Capability.Reader (HasReader, MonadReader (..), ask)+import Capability.Reader qualified as Reader (local)+import Capability.Sink (HasSink)+import Capability.Source (HasSource)+import Capability.State (HasState, MonadState (..), modify)+import Codec.CBOR.Cuddle.CDDL+import Codec.CBOR.Cuddle.CDDL.CTree (+  CTree,+  CTreeRoot,+  CTreeRoot' (CTreeRoot),+  ParametrisedWith (..),+ )+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 Data.List.NonEmpty qualified as NE+import Data.Map.Strict qualified as Map+import Data.Text qualified as T+import GHC.Generics (Generic)+import Optics.Core++--------------------------------------------------------------------------------+-- 1. Rule extensions+--------------------------------------------------------------------------------++type CDDLMap = Map.Map Name (Parametrised TypeOrGroup)++type Parametrised a = ParametrisedWith [Name] a++toParametrised :: a -> Maybe GenericParam -> Parametrised a+toParametrised a Nothing = Unparametrised a+toParametrised a (Just (GenericParam gps)) = Parametrised a (NE.toList gps)++parameters :: Parametrised a -> [Name]+parameters (Unparametrised _) = mempty+parameters (Parametrised _ ps) = ps++asMap :: CDDL -> CDDLMap+asMap cddl = foldl' go Map.empty rules+  where+    rules = cddlTopLevel cddl+    go x (TopLevelComment _) = x+    go x (TopLevelRule r) = assignOrExtend x r++    assignOrExtend :: CDDLMap -> Rule -> CDDLMap+    assignOrExtend m (Rule n gps assign tog _) = case assign of+      -- Equals assignment+      AssignEq -> Map.insert n (toParametrised tog gps) m+      AssignExt -> Map.alter (extend tog gps) n m++    extend ::+      TypeOrGroup ->+      Maybe GenericParam ->+      Maybe (Parametrised TypeOrGroup) ->+      Maybe (Parametrised TypeOrGroup)+    extend tog _gps (Just existing) = case (underlying existing, tog) of+      (TOGType _, TOGType (Type0 new)) ->+        Just $+          existing+            & field @"underlying"+            % _Ctor @"TOGType"+            % _Ctor @"Type0"+            %~ (<> new)+      -- 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+      (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++--------------------------------------------------------------------------------+-- 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 RefCTree = CTreeRoot OrRef++deriving instance Show (CTree OrRef)++deriving instance Show (CTreeRoot OrRef)++-- | Build a CTree incorporating references.+--+-- This translation cannot fail.+buildRefCTree :: CDDLMap -> RefCTree+buildRefCTree rules = CTreeRoot $ fmap toCTreeRule rules+  where+    toCTreeRule ::+      Parametrised TypeOrGroup ->+      ParametrisedWith [Name] (CTree.Node OrRef)+    toCTreeRule = fmap toCTreeTOG++    toCTreeTOG :: TypeOrGroup -> CTree.Node OrRef+    toCTreeTOG (TOGType t0) = toCTreeT0 t0+    toCTreeTOG (TOGGroup ge) = toCTreeGroupEntry ge++    toCTreeT0 :: Type0 -> CTree.Node OrRef+    toCTreeT0 (Type0 (t1 NE.:| [])) = toCTreeT1 t1+    toCTreeT0 (Type0 xs) = It . CTree.Choice $ toCTreeT1 <$> xs++    toCTreeT1 :: Type1 -> CTree.Node OrRef+    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+            }+      CtrlOp ctlop ->+        It $+          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 (T2Group t0) =+      -- This behaviour seems questionable, but I don't really see how better to+      -- interpret the spec here.+      toCTreeT0 t0+    toCTreeT2 (T2Map g) = toCTreeMap g+    toCTreeT2 (T2Array g) = toCTreeArray g+    toCTreeT2 (T2Unwrapped n margs) =+      It . CTree.Unwrap $+        Ref n (fromGenArgs margs)+    toCTreeT2 (T2Enum g) = toCTreeEnum g+    toCTreeT2 (T2EnumRef n margs) = Ref n $ fromGenArgs margs+    toCTreeT2 (T2Tag Nothing t0) =+      -- Currently not validating tags+      toCTreeT0 t0+    toCTreeT2 (T2Tag (Just tag) t0) =+      It . 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++    toCTreeDataItem 20 =+      It . CTree.Literal $ Value (VBool False) mempty+    toCTreeDataItem 21 =+      It . CTree.Literal $ Value (VBool True) mempty+    toCTreeDataItem 25 =+      It $ CTree.Postlude PTHalf+    toCTreeDataItem 26 =+      It $ CTree.Postlude PTFloat+    toCTreeDataItem 27 =+      It $ CTree.Postlude PTDouble+    toCTreeDataItem 23 =+      It $ CTree.Postlude PTUndefined+    toCTreeDataItem _ =+      It $ 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++    fromGenArgs :: Maybe GenericArg -> [CTree.Node OrRef]+    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+      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)++    toKVPair :: Maybe MemberKey -> Type0 -> CTree.Node OrRef+    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+          }++    -- 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)++    -- 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)++    toCTreeMemberKey :: MemberKey -> CTree.Node OrRef+    toCTreeMemberKey (MKValue v) = It $ CTree.Literal v+    toCTreeMemberKey (MKBareword (Name n _)) = It $ CTree.Literal (Value (VText n) mempty)+    toCTreeMemberKey (MKType t1) = toCTreeT1 t1++--------------------------------------------------------------------------------+-- 3. Name resolution+--------------------------------------------------------------------------------++data NameResolutionFailure+  = UnboundReference Name+  | MismatchingArgs Name [Name]+  | ArgsToPostlude PTerm [CTree.Node OrRef]+  deriving (Show)++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)+    ]++data BindingEnv poly f g = BindingEnv+  { global :: Map.Map Name (poly (CTree.Node f))+  -- ^ Global name bindings via 'RuleDef'+  , local :: Map.Map Name (CTree.Node g)+  -- ^ 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)++instance Hashable a => Hashable (DistRef a)++deriving instance Show (CTree DistRef)++deriving instance Eq (CTree DistRef)++instance Hashable (CTree DistRef)++deriving instance Show (CTreeRoot DistRef)++deriving instance Eq (CTreeRoot DistRef)++instance Hashable (CTreeRoot DistRef)++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+  Just pterm -> case args of+    [] -> Right . DIt $ CTree.Postlude pterm+    xs -> Left $ ArgsToPostlude pterm 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+        else Left $ MismatchingArgs n params'+    Nothing -> case Map.lookup n (local env) of+      Just _ -> Right $ GenericRef n+      Nothing -> Left $ UnboundReference n++resolveCTree ::+  BindingEnv (ParametrisedWith [Name]) OrRef OrRef ->+  CTree OrRef ->+  Either NameResolutionFailure (CTree DistRef)+resolveCTree e = CTree.traverseCTree (resolveRef e)++buildResolvedCTree ::+  CTreeRoot OrRef ->+  Either NameResolutionFailure (CTreeRoot DistRef)+buildResolvedCTree (CTreeRoot ct) = CTreeRoot <$> 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++--------------------------------------------------------------------------------+-- 4. Monomorphisation+--------------------------------------------------------------------------------++data MonoRef a+  = MIt a+  | MRuleRef Name+  deriving (Functor, Show)++deriving instance Show (CTree MonoRef)++deriving instance+  Show (poly (CTree.Node MonoRef)) =>+  Show (CTreeRoot' poly MonoRef)++type MonoEnv = BindingEnv (ParametrisedWith [Name]) DistRef MonoRef++-- | We introduce additional bindings in the state+type MonoState = Map.Map Name (CTree.Node MonoRef)++-- | Monad to run the monomorphisation process. We need some additional+-- capabilities for this, so 'Either' doesn't fully cut it anymore.+newtype MonoM a = MonoM+  { runMonoM ::+      ExceptT+        NameResolutionFailure+        (StateT MonoState (Reader MonoEnv))+        a+  }+  deriving (Functor, Applicative, Monad)+  deriving+    (HasThrow "nameResolution" NameResolutionFailure)+    via MonadError+          ( ExceptT+              NameResolutionFailure+              (StateT MonoState (Reader MonoEnv))+          )+  deriving+    ( HasSource+        "local"+        (Map.Map Name (CTree.Node MonoRef))+    , HasReader+        "local"+        (Map.Map Name (CTree.Node MonoRef))+    )+    via Field+          "local"+          ()+          ( Lift+              ( ExceptT+                  NameResolutionFailure+                  (Lift (StateT MonoState (MonadReader (Reader MonoEnv))))+              )+          )+  deriving+    ( HasSource+        "global"+        (Map.Map Name (ParametrisedWith [Name] (CTree.Node DistRef)))+    , HasReader+        "global"+        (Map.Map Name (ParametrisedWith [Name] (CTree.Node DistRef)))+    )+    via Field+          "global"+          ()+          ( Lift+              ( ExceptT+                  NameResolutionFailure+                  (Lift (StateT MonoState (MonadReader (Reader MonoEnv))))+              )+          )+  deriving+    ( HasSource "synth" MonoState+    , HasSink "synth" MonoState+    , HasState "synth" MonoState+    )+    via Lift+          ( ExceptT+              NameResolutionFailure+              (MonadState (StateT MonoState (Reader MonoEnv)))+          )++throwNR :: NameResolutionFailure -> MonoM a+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 =+        -- % is not a valid CBOR name, so this should avoid conflict+        Name (origName <> "%" <> T.pack (show $ hash args)) mempty+   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') ->+            if length params' == length args+              then do+                rargs <- traverse resolveGenericRef args+                let localBinds = Map.fromList $ zip params' rargs+                Reader.local @"local" (Map.union localBinds) $ do+                  foo <- resolveGenericRef r+                  modify @"synth" $ Map.insert fresh foo+              else throwNR $ MismatchingArgs n params'+          Nothing -> throwNR $ UnboundReference n+        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+  localBinds <- ask @"local"+  case Map.lookup n localBinds of+    Just node -> pure node+    Nothing -> throwNR $ UnboundReference n++resolveGenericCTree ::+  CTree DistRef ->+  MonoM (CTree MonoRef)+resolveGenericCTree = CTree.traverseCTree resolveGenericRef++-- | 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)+      a2 = runStateT a1 mempty+      (er, newBindings) = runReader a2 initBindingEnv+  CTreeRoot r <- er+  pure . CTreeRoot $ Map.union r $ fmap Identity newBindings+  where+    initBindingEnv = BindingEnv ct mempty+    monoC =+      CTreeRoot $+        Map.mapMaybe+          ( \case+              Unparametrised f -> Just $ Identity f+              Parametrised _ _ -> Nothing+          )+          ct++--------------------------------------------------------------------------------+-- Combined resolution+--------------------------------------------------------------------------------++fullResolveCDDL :: CDDL -> Either NameResolutionFailure (CTreeRoot' Identity MonoRef)+fullResolveCDDL cddl = do+  let refCTree = buildRefCTree (asMap cddl)+  rCTree <- buildResolvedCTree refCTree+  buildMonoCTree rCTree
+ src/Codec/CBOR/Cuddle/Comments.hs view
@@ -0,0 +1,180 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}++module Codec.CBOR.Cuddle.Comments (+  HasComment (..),+  CollectComments (..),+  hasComment,+  (//-),+  (<*!),+  (!*>),+  WithComment (..),+  (!$>),+  Comment (..),+  unComment,+  withComment,+) where++import Data.ByteString (ByteString)+import Data.Default.Class (Default (..))+import Data.Hashable (Hashable)+import Data.List.NonEmpty (NonEmpty (..))+import Data.String (IsString (..))+import Data.Text qualified as T+import Data.TreeDiff (ToExpr)+import Data.Word (Word16, Word32, Word64, Word8)+import GHC.Generics (Generic (..), K1 (..), M1 (..), U1 (..), V1, (:*:) (..), (:+:) (..))+import Optics.Core (Lens', lens, view, (%~), (&), (.~), (^.))++newtype Comment = Comment T.Text+  deriving (Eq, Ord, Generic, Show)+  deriving newtype (Monoid)+  deriving anyclass (ToExpr, Hashable)++instance Semigroup Comment where+  Comment "" <> x = x+  x <> Comment "" = x+  Comment x <> Comment y = Comment $ x <> "\n" <> y++unComment :: Comment -> [T.Text]+unComment (Comment c) = T.lines c++instance Default Comment where def = mempty++class HasComment a where+  commentL :: Lens' a Comment++class GCollectComments f where+  collectCommentsG :: f a -> [Comment]++instance GCollectComments V1 where+  collectCommentsG = \case {}++instance GCollectComments U1 where+  collectCommentsG U1 = []++instance+  ( GCollectComments a+  , GCollectComments b+  ) =>+  GCollectComments (a :+: b)+  where+  collectCommentsG (L1 x) = collectCommentsG x+  collectCommentsG (R1 x) = collectCommentsG x++instance+  ( GCollectComments a+  , GCollectComments b+  ) =>+  GCollectComments (a :*: b)+  where+  collectCommentsG (a :*: b) = collectCommentsG a <> collectCommentsG b++instance CollectComments a => GCollectComments (K1 s a) where+  collectCommentsG (K1 x) = collectComments x++instance GCollectComments a => GCollectComments (M1 i c a) where+  collectCommentsG (M1 x) = collectCommentsG x++class CollectComments a where+  collectComments :: a -> [Comment]+  default collectComments :: (Generic a, GCollectComments (Rep a)) => a -> [Comment]+  collectComments = collectCommentsG . from++instance CollectComments a => CollectComments (Maybe a) where+  collectComments Nothing = []+  collectComments (Just x) = collectComments x++instance CollectComments a => CollectComments [a]++instance CollectComments a => CollectComments (NonEmpty a)++instance CollectComments Word8 where collectComments = mempty++instance CollectComments Word16 where collectComments = mempty++instance CollectComments Word32 where collectComments = mempty++instance CollectComments Word64 where collectComments = mempty++instance CollectComments Integer where collectComments = mempty++instance CollectComments Float where collectComments = mempty++instance CollectComments Double where collectComments = mempty++instance CollectComments T.Text where collectComments = mempty++instance CollectComments ByteString where collectComments = mempty++instance CollectComments Bool where collectComments = mempty++instance CollectComments Comment where+  collectComments x = [x]++hasComment :: HasComment a => a -> Bool+hasComment = (/= mempty) . view commentL++-- | This operator is used to attach comments to terms. It will not overwrite+-- any comments that are already present, but will add the new comments on a+-- new line+-- ```+-- arr [0, 1] //- "This is an array with two values"+-- ```+(//-) :: HasComment a => a -> Comment -> a+x //- c = x & commentL %~ (<> c)++infixr 0 //-++-- | This operator will parse the values from left to right and then append the+-- parsed comment on the right to the parsed value on the left.+(<*!) :: (HasComment a, Applicative m) => m a -> m Comment -> m a+(<*!) x c = (//-) <$> x <*> c++-- | This operator will parse the values from left to right and then append the+-- parsed comment on the left to the parsed value on the right.+(!*>) :: (HasComment a, Applicative m) => m Comment -> m a -> m a+(!*>) c x = flip (//-) <$> c <*> x++data WithComment a = WithComment+  { unWithComment :: Comment+  , stripComment :: a+  }+  deriving (Functor)++instance Applicative WithComment where+  pure = withComment+  WithComment cmt f <*> WithComment cmt' x = WithComment (cmt <> cmt') $ f x++instance Monad WithComment where+  WithComment cmt x >>= f = let WithComment cmt' y = f x in WithComment (cmt <> cmt') y++instance HasComment (WithComment a) where+  commentL = lens (\(WithComment x _) -> x) (\(WithComment _ b) x -> WithComment x b)++instance CollectComments a => CollectComments (WithComment a) where+  collectComments (WithComment c x) = c : collectComments x++withComment :: a -> WithComment a+withComment = WithComment mempty++-- | This operator maps a function over a functor containing a `WithComment` and+-- applies the comment within to the output of the applied function.+-- ```+-- (\x -> LInt x "a") !$> WithComment "b" (1 :: Integer) == Literal (LInt 1) "a\nb"+-- ```+(!$>) :: (HasComment b, Functor f) => (a -> b) -> f (WithComment a) -> f b+f !$> wc = fmap (\(WithComment c x) -> f x //- c) wc++instance HasComment a => HasComment (NonEmpty a) where+  commentL = lens (\(x :| _) -> x ^. commentL) (\(x :| xs) y -> (x & commentL .~ y) :| xs)++instance HasComment Comment where+  commentL = lens id const++instance IsString Comment where+  fromString s = Comment $ T.pack s
+ src/Codec/CBOR/Cuddle/Huddle.hs view
@@ -0,0 +1,1234 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeFamilies #-}++-- | Module for building CDDL in Haskell+--+-- Compared to the builders, this is less about creating a DSL for CDDL in+-- Haskell as about using Haskell's higher-level capabilities to express CDDL+-- constraints. So we ditch a bunch of CDDL concepts where we can instead use+-- Haskell's capabilities there.+module Codec.CBOR.Cuddle.Huddle (+  -- * Core Types+  Huddle,+  HuddleItem (..),+  huddleAugment,+  Rule,+  Named,+  IsType0 (..),+  Value (..),++  -- * Rules and assignment+  (=:=),+  (=:~),+  comment,++  -- * Maps+  (==>),+  mp,+  asKey,+  idx,++  -- * Arrays+  a,+  arr,++  -- * Groups+  Group,+  grp,++  -- * Quantification+  CanQuantify (..),+  opt,++  -- * Choices+  (/),+  seal,+  sarr,+  smp,++  -- * Literals+  Literal,+  bstr,+  int,+  text,++  -- * Ctl operators+  IsConstrainable,+  IsSizeable,+  sized,+  cbor,+  le,++  -- * Ranged+  (...),++  -- * Tagging+  tag,++  -- * Generics+  GRef,+  GRuleDef,+  GRuleCall,+  binding,+  binding2,+  callToDef,++  -- * Conversion to CDDL+  collectFrom,+  collectFromInit,+  toCDDL,+  toCDDLNoRoot,+)+where++import Codec.CBOR.Cuddle.CDDL (CDDL)+import Codec.CBOR.Cuddle.CDDL qualified as C+import Codec.CBOR.Cuddle.CDDL.CtlOp qualified as CtlOp+import Codec.CBOR.Cuddle.Comments qualified as C+import Control.Monad (when)+import Control.Monad.State (MonadState (get), execState, modify)+import Data.ByteString (ByteString)+import Data.Default.Class (Default (..))+import Data.Function (on)+import Data.Generics.Product (HasField' (field'), 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.String (IsString (fromString))+import Data.Text qualified as T+import Data.Tuple.Optics (Field2 (..))+import Data.Void (Void)+import Data.Word (Word64)+import GHC.Exts (IsList (Item, fromList, toList))+import GHC.Generics (Generic)+import Optics.Core (lens, view, (%~), (&), (.~), (^.))+import Prelude hiding ((/))++data Named a = Named+  { name :: T.Text+  , value :: a+  , description :: Maybe T.Text+  }+  deriving (Functor, Generic)++-- | 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++instance Show (Named a) where+  show (Named n _ _) = T.unpack n++type Rule = Named Type0++data HuddleItem+  = HIRule Rule+  | HIGRule GRuleDef+  | HIGroup (Named Group)+  deriving (Generic, Show)++-- | Top-level Huddle type is a list of rules.+data Huddle = Huddle+  { roots :: [Rule]+  -- ^ Root elements+  , items :: OMap T.Text HuddleItem+  }+  deriving (Generic, Show)++-- | 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)++-- | This semigroup instance:+--   - Takes takes the roots from the RHS unless they are empty, in which case+--     it takes the roots from the LHS+--   - Uses the RHS to override items on the LHS where they share a name.+--     The value from the RHS is taken, but the index from the LHS is used.+--+--   Note that this allows replacing items in the middle of a tree without+--   updating higher-level items which make use of them - that is, we do not+--   need to "close over" higher-level terms, since by the time they have been+--   built into a huddle structure, the references have been converted to keys.+instance Semigroup Huddle where+  h1 <> h2 =+    Huddle+      { roots = case roots h2 of+          [] -> roots h1+          xs -> xs+      , items = OMap.unionWithL (\_ _ v2 -> v2) (items h1) (items h2)+      }++-- | This instance is mostly used for testing+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++  toList = const []++instance Default Huddle where+  def = Huddle [] OMap.empty++data Choice a+  = NoChoice a+  | ChoiceOf a (Choice a)+  deriving (Eq, Show, Functor, Foldable, Traversable)++choiceToList :: Choice a -> [a]+choiceToList (NoChoice x) = [x]+choiceToList (ChoiceOf x xs) = x : choiceToList xs++choiceToNE :: Choice a -> NE.NonEmpty a+choiceToNE (NoChoice c) = c NE.:| []+choiceToNE (ChoiceOf c cs) = c NE.:| choiceToList cs++data Key+  = LiteralKey Literal+  | TypeKey Type2+  deriving (Show)++-- | Instance for the very general case where we use text keys+instance IsString Key where+  fromString x = LiteralKey $ Literal (LText $ T.pack x) mempty++-- | Use a number as a key+idx :: Word64 -> Key+idx x = LiteralKey $ Literal (LInt x) mempty++asKey :: IsType0 r => r -> Key+asKey r = case toType0 r of+  NoChoice x -> TypeKey x+  ChoiceOf _ _ -> error "Cannot use a choice of types as a map key"++data MapEntry = MapEntry+  { key :: Key+  , value :: Type0+  , quantifier :: Occurs+  , meDescription :: C.Comment+  }+  deriving (Generic, Show)++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++  fromList = MapChoice+  toList (MapChoice m) = m++type Map = Choice MapChoice++data ArrayEntry = ArrayEntry+  { key :: Maybe Key+  -- ^ Arrays can have keys, but they have no semantic meaning. We add them+  -- here because they can be illustrative in the generated CDDL.+  , value :: Type0+  , quantifier :: Occurs+  , aeDescription :: C.Comment+  }+  deriving (Generic, Show)++instance C.HasComment ArrayEntry where+  commentL = lens aeDescription (\x y -> x {aeDescription = y})++instance Num ArrayEntry where+  fromInteger i =+    ArrayEntry+      Nothing+      (NoChoice . T2Range . Unranged $ Literal (LInt (fromIntegral i)) mempty)+      def+      mempty+  (+) = error "Cannot treat ArrayEntry as a number"+  (*) = error "Cannot treat ArrayEntry as a number"+  abs = error "Cannot treat ArrayEntry as a number"+  signum = error "Cannot treat ArrayEntry as a number"+  negate = error "Cannot treat ArrayEntry as a number"++data ArrayChoice = ArrayChoice+  { unArrayChoice :: [ArrayEntry]+  , acComment :: C.Comment+  }+  deriving (Show)++instance Semigroup ArrayChoice where+  ArrayChoice x xc <> ArrayChoice y yc = ArrayChoice (x <> y) (xc <> yc)++instance Monoid ArrayChoice where+  mempty = ArrayChoice mempty mempty++instance C.HasComment ArrayChoice where+  commentL = lens acComment (\x y -> x {acComment = y})++instance IsList ArrayChoice where+  type Item ArrayChoice = ArrayEntry++  fromList = (`ArrayChoice` mempty)+  toList (ArrayChoice l _) = l++type Array = Choice ArrayChoice++newtype Group = Group {unGroup :: [ArrayEntry]}+  deriving (Show, Monoid, Semigroup)++instance IsList Group where+  type Item Group = ArrayEntry++  fromList = Group+  toList (Group l) = l++data Type2+  = T2Constrained Constrained+  | T2Range Ranged+  | T2Map Map+  | T2Array Array+  | T2Tagged (Tagged Type0)+  | T2Ref (Named Type0)+  | T2Group (Named Group)+  | -- | 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++instance Num Type0 where+  fromInteger i = NoChoice . T2Range . Unranged $ Literal (LInt (fromIntegral i)) mempty+  (+) = error "Cannot treat Type0 as a number"+  (*) = error "Cannot treat Type0 as a number"+  abs = error "Cannot treat Type0 as a number"+  signum = error "Cannot treat Type0 as a number"+  negate = error "Cannot treat Type0 as a number"++-- | Occurrence bounds.+data Occurs = Occurs+  { lb :: Maybe Word64+  , ub :: Maybe Word64+  }+  deriving (Eq, Generic, Show)++instance Default Occurs where+  def = Occurs Nothing Nothing++-- | Type-parametrised value type handling CBOR primitives. This is used to+-- constrain the set of constraints which can apply to a given postlude type.+data Value a where+  VBool :: Value Bool+  VUInt :: Value Int+  VNInt :: Value Int+  VInt :: Value Int+  VHalf :: Value Float+  VFloat :: Value Float+  VDouble :: Value Double+  VBytes :: Value ByteString+  VText :: Value T.Text+  VAny :: Value Void+  VNil :: Value Void++deriving instance Show (Value a)++--------------------------------------------------------------------------------+-- Literals+--------------------------------------------------------------------------------++data Literal = Literal+  { litVariant :: LiteralVariant+  , litComment :: C.Comment+  }+  deriving (Show)++instance C.HasComment Literal where+  commentL = lens litComment (\x y -> x {litComment = y})++data LiteralVariant where+  -- | We store both int and nint as a Word64, since the sign is indicated in+  -- the type.+  LInt :: Word64 -> LiteralVariant+  LNInt :: Word64 -> LiteralVariant+  LBignum :: Integer -> LiteralVariant+  LText :: T.Text -> LiteralVariant+  LFloat :: Float -> LiteralVariant+  LDouble :: Double -> LiteralVariant+  LBytes :: ByteString -> LiteralVariant+  deriving (Show)++int :: Integer -> Literal+int = inferInteger++bstr :: ByteString -> Literal+bstr x = Literal (LBytes x) mempty++text :: T.Text -> Literal+text x = Literal (LText x) mempty++inferInteger :: Integer -> Literal+inferInteger i+  | i >= 0 && i < fromIntegral (maxBound @Word64) = Literal (LInt (fromInteger i)) mempty+  | i < 0 && (-i) < fromIntegral (maxBound @Word64) = Literal (LNInt (fromInteger (-i))) mempty+  | otherwise = Literal (LBignum i) mempty++--------------------------------------------------------------------------------+-- Constraints and Ranges+--------------------------------------------------------------------------------++-- | A reference can be to any type, so we allow it to inhabit all+type AnyRef a = Named Type0++data Constrainable a+  = 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++-- | Uninhabited type used as marker for the type of thing a CGRef sizes+data CGRefType++-- | We only allow constraining basic values, or references. Of course, we+--   can't check what the references refer to.+data Constrained where+  Constrained ::+    forall a.+    { 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++instance IsConstrainable (AnyRef a) CRefType where+  toConstrainable = CRef++instance IsConstrainable (Value a) a where+  toConstrainable = CValue++instance IsConstrainable GRef CGRefType where+  toConstrainable = CGRef++unconstrained :: Value a -> Constrained+unconstrained v = Constrained (CValue v) def []++-- | 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+  , showConstraint :: String+  }++instance Show (ValueConstraint a) where+  show = showConstraint++instance Default (ValueConstraint a) where+  def =+    ValueConstraint+      { applyConstraint = \x -> C.Type1 x Nothing mempty+      , showConstraint = ""+      }++-- | Marker that we can apply the size CtlOp to something. Not intended for+-- export.+class IsSizeable a++instance IsSizeable Int++instance IsSizeable ByteString++instance IsSizeable T.Text++instance IsSizeable CRefType++instance IsSizeable CGRefType++-- | Things which can be used on the RHS of the '.size' operator.+class IsSize a where+  sizeAsCDDL :: a -> C.Type2+  sizeAsString :: a -> String++instance IsSize Word where+  sizeAsCDDL x = C.T2Value $ C.Value (C.VUInt $ fromIntegral x) mempty+  sizeAsString = show++instance IsSize Word64 where+  sizeAsCDDL x = C.T2Value $ C.Value (C.VUInt x) mempty+  sizeAsString = show++instance IsSize (Word64, Word64) where+  sizeAsCDDL (x, y) =+    C.T2Group+      ( C.Type0+          ( C.Type1+              (C.T2Value (C.Value (C.VUInt x) mempty))+              (Just (C.RangeOp C.Closed, C.T2Value (C.Value (C.VUInt y) mempty)))+              mempty+              NE.:| []+          )+      )+  sizeAsString (x, y) = show x <> ".." <> show y++-- | Declare a size constraint on an int-style type or reference.+--   Since 0.3.4 this has worked for reference types as well as values.+sized ::+  forall c a s.+  ( IsSizeable a+  , IsSize s+  , IsConstrainable c a+  ) =>+  c ->+  s ->+  Constrained+sized v sz =+  Constrained+    (toConstrainable @c @a v)+    ValueConstraint+      { applyConstraint = \t2 ->+          C.Type1+            t2+            (Just (C.CtrlOp CtlOp.Size, sizeAsCDDL sz))+            mempty+      , showConstraint = ".size " <> sizeAsString sz+      }+    []++class IsCborable a+instance IsCborable ByteString+instance IsCborable (AnyRef a)+instance IsCborable GRef++cbor :: (IsCborable b, IsConstrainable c b) => c -> Rule -> Constrained+cbor v r@(Named n _ _) =+  Constrained+    (toConstrainable v)+    ValueConstraint+      { applyConstraint = \t2 ->+          C.Type1+            t2+            (Just (C.CtrlOp CtlOp.Cbor, C.T2Name (C.Name n mempty) Nothing))+            mempty+      , showConstraint = ".cbor " <> T.unpack n+      }+    [r]++class IsComparable a+instance IsComparable Int+instance IsComparable (AnyRef a)+instance IsComparable GRef++le :: (IsComparable a, IsConstrainable c a) => c -> Word64 -> Constrained+le v bound =+  Constrained+    (toConstrainable v)+    ValueConstraint+      { applyConstraint = \t2 ->+          C.Type1+            t2+            (Just (C.CtrlOp CtlOp.Le, C.T2Value (C.Value (C.VUInt $ fromIntegral bound) mempty)))+            mempty+      , showConstraint = ".le " <> show bound+      }+    []++-- Ranges++data RangeBound+  = RangeBoundLiteral Literal+  | RangeBoundRef (Named Type0)+  deriving (Show)++class IsRangeBound a where+  toRangeBound :: a -> RangeBound++instance IsRangeBound Literal where+  toRangeBound = RangeBoundLiteral++instance IsRangeBound Integer where+  toRangeBound = RangeBoundLiteral . inferInteger++instance IsRangeBound (Named Type0) where+  toRangeBound = RangeBoundRef++data Ranged where+  Ranged ::+    { 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+l ... u = Ranged (toRangeBound l) (toRangeBound u) C.Closed++infixl 9 ...++--------------------------------------------------------------------------------+-- Syntax+--------------------------------------------------------------------------------++class IsType0 a where+  toType0 :: a -> Type0++instance IsType0 Rule where+  toType0 = NoChoice . T2Ref++instance IsType0 (Choice Type2) where+  toType0 = id++instance IsType0 Constrained where+  toType0 = NoChoice . T2Constrained++instance IsType0 Map where+  toType0 = NoChoice . T2Map++instance IsType0 MapChoice where+  toType0 = NoChoice . T2Map . NoChoice++instance IsType0 Array where+  toType0 = NoChoice . T2Array++instance IsType0 ArrayChoice where+  toType0 = NoChoice . T2Array . NoChoice++instance IsType0 Ranged where+  toType0 = NoChoice . T2Range++instance IsType0 Literal where+  toType0 = NoChoice . T2Range . Unranged++-- We also allow going directly from primitive types to Type2+instance IsType0 Integer where+  toType0 = NoChoice . T2Range . Unranged . inferInteger++instance IsType0 T.Text where+  toType0 :: T.Text -> Type0+  toType0 x = NoChoice . T2Range . Unranged $ Literal (LText x) mempty++instance IsType0 ByteString where+  toType0 x = NoChoice . T2Range . Unranged $ Literal (LBytes x) mempty++instance IsType0 Float where+  toType0 x = NoChoice . T2Range . Unranged $ Literal (LFloat x) mempty++instance IsType0 Double where+  toType0 x = NoChoice . T2Range . Unranged $ Literal (LDouble x) mempty++instance IsType0 (Value a) where+  toType0 = NoChoice . T2Constrained . unconstrained++instance IsType0 (Named Group) where+  toType0 = NoChoice . T2Group++instance IsType0 GRuleCall where+  toType0 = NoChoice . T2Generic++instance IsType0 GRef where+  toType0 = NoChoice . T2GenericRef++instance IsType0 a => IsType0 (Tagged a) where+  toType0 = NoChoice . T2Tagged . fmap toType0++instance IsType0 HuddleItem where+  toType0 (HIRule r) = toType0 r+  toType0 (HIGroup g) = toType0 g+  toType0 (HIGRule g) =+    error $+      "Attempt to reference generic rule from HuddleItem not supported: " <> show g++class CanQuantify a where+  -- | Apply a lower bound+  (<+) :: Word64 -> a -> a++  -- | Apply an upper bound+  (+>) :: a -> Word64 -> a++infixl 7 <+++infixr 6 +>++opt :: CanQuantify a => a -> a+opt r = 0 <+ r +> 1++instance CanQuantify Occurs where+  lb <+ (Occurs _ ub) = Occurs (Just lb) ub+  (Occurs lb _) +> ub = Occurs lb (Just ub)++instance CanQuantify ArrayEntry where+  lb <+ ae = ae & field @"quantifier" %~ (lb <+)+  ae +> ub = ae & field @"quantifier" %~ (+> ub)++instance CanQuantify MapEntry where+  lb <+ ae = ae & field @"quantifier" %~ (lb <+)+  ae +> ub = ae & field @"quantifier" %~ (+> ub)++-- | A quantifier on a choice can be rewritten as a choice of quantifiers+instance CanQuantify a => CanQuantify (Choice a) where+  lb <+ c = fmap (lb <+) c+  c +> ub = fmap (+> ub) c++class IsEntryLike a where+  fromMapEntry :: MapEntry -> a++instance IsEntryLike MapEntry where+  fromMapEntry = id++instance IsEntryLike ArrayEntry where+  fromMapEntry me =+    ArrayEntry+      { key = Just $ getField @"key" me+      , value =+          getField @"value" me+      , quantifier = getField @"quantifier" me+      , aeDescription = mempty+      }++instance IsEntryLike Type0 where+  fromMapEntry = getField @"value"++(==>) :: (IsType0 a, IsEntryLike me) => Key -> a -> me+k ==> gc =+  fromMapEntry+    MapEntry+      { key = k+      , value = toType0 gc+      , quantifier = def+      , meDescription = mempty+      }++infixl 8 ==>++-- | Assign a rule+(=:=) :: IsType0 a => T.Text -> a -> Rule+n =:= b = Named n (toType0 b) Nothing++infixl 1 =:=++(=:~) :: T.Text -> Group -> Named Group+n =:~ b = Named n b Nothing++infixl 1 =:~++class IsGroupOrArrayEntry a where+  toGroupOrArrayEntry :: IsType0 x => x -> a++instance IsGroupOrArrayEntry ArrayEntry where+  toGroupOrArrayEntry x =+    ArrayEntry+      { key = Nothing+      , value = toType0 x+      , quantifier = def+      , aeDescription = mempty+      }++instance IsGroupOrArrayEntry Type0 where+  toGroupOrArrayEntry = toType0++-- | Explicitly cast an item in an Array as an ArrayEntry.+a :: (IsType0 a, IsGroupOrArrayEntry e) => a -> e+a = toGroupOrArrayEntry++--------------------------------------------------------------------------------+-- Choices+--------------------------------------------------------------------------------+class IsChoosable a b | a -> b where+  toChoice :: a -> Choice b++instance IsChoosable (Choice a) a where+  toChoice = id++instance IsChoosable ArrayChoice ArrayChoice where+  toChoice = NoChoice++instance IsChoosable MapChoice MapChoice where+  toChoice = NoChoice++instance IsChoosable Type2 Type2 where+  toChoice = NoChoice++instance IsChoosable Rule Type2 where+  toChoice = toChoice . T2Ref++instance IsChoosable GRuleCall Type2 where+  toChoice = toChoice . T2Generic++instance IsChoosable GRef Type2 where+  toChoice = toChoice . T2GenericRef++instance IsChoosable ByteString Type2 where+  toChoice x = toChoice . T2Range . Unranged $ Literal (LBytes x) mempty++instance IsChoosable Constrained Type2 where+  toChoice = toChoice . T2Constrained++instance IsType0 a => IsChoosable (Tagged a) Type2 where+  toChoice = toChoice . T2Tagged . fmap toType0++instance IsChoosable Literal Type2 where+  toChoice = toChoice . T2Range . Unranged++instance IsChoosable (Value a) Type2 where+  toChoice = toChoice . T2Constrained . unconstrained++instance IsChoosable (Named Group) Type2 where+  toChoice = toChoice . T2Group++instance IsChoosable (Seal Array) Type2 where+  toChoice (Seal x) = NoChoice $ T2Array x++instance IsChoosable (Seal Map) Type2 where+  toChoice (Seal m) = NoChoice $ T2Map m++instance IsChoosable (Seal ArrayChoice) Type2 where+  toChoice (Seal m) = NoChoice . T2Array $ NoChoice m++instance IsChoosable (Seal MapChoice) Type2 where+  toChoice (Seal m) = NoChoice . T2Map $ NoChoice m++-- | Allow choices between constructions+--+-- in CDDL, '/'  a choice between types (concretely, between Type1 values, to+-- make a Type0). '//' allows choice between groups. We can illustrate the+-- difference with the following snippet:+--+-- @ foo = [ 0 / 1, uint // 2 /3, tstr ] @+--+-- This construction would match either of the following:+--+-- @ [0, 3] [2, "Hello World"] @+--+-- In other words, the '//' binds less strongly than comma (',') in CDDL.+--+-- In Haskell, of course, we cannot have syntax inside an array which binds+-- stronger than the comma. so we have to do things a little differently. The+-- way this is handled at the moment is that '/' has special treatment for+-- arrays/groups, where it will, instead of creating a type-level choice, merge+-- the two arrays/groups/maps into a single one containing a group choice.+--+-- If one instead wants the behaviour corresponding to the CDDL '/' for arrays,+-- maps or groups, one can "seal" the array or group using the 'seal', 'sarr' or+-- 'smp' functions. For example:+--+-- @ "foo" =:= sarr [0, a VUInt] / sarr [1, a VText] @+--+-- Generates a choice (at the 'Type0') level between two arrays, whereas+--+-- @ "foo" =:= arr [0, a VUInt] / arr [1, a VUInt] @+--+-- will generate a single array containing a group choice between two groups.+--+-- As such, there is no `//` operator in Huddle.+(/) :: (IsChoosable a c, IsChoosable b c) => a -> b -> Choice c+x / b = go (toChoice x) (toChoice b)+  where+    go (NoChoice x') b' = ChoiceOf x' b'+    go (ChoiceOf x' b') c = ChoiceOf x' (go b' c)++infixl 9 /++-- Choices within maps or arrays+--+-- Maps and arrays allow an "internal" choice - as per [1, 'a' // 2, 'b']. This+-- means that the array can be either [1, 'a'] or [2, 'b']. Since this would not+-- work within Haskell's array syntax, we instead pull the option outside of the+-- array, as with [1, 'a'] // [2, 'b'].+--+-- This, however, leaves us with a problem. When we write [1, 'a'] // [2, 'b']+-- we have two possible interpretations - as a top-level choice (in CDDL terms,+-- a choice in the 'Type0'. In Huddle terms, as a Choice Array) or as a choice+-- inside the array (in CDDL terms, a choice inside the Group. In Huddle terms,+-- as a Choice ArrayChoice (itself an Array!)).+--+-- To resolve this, we allow "sealing" an array or map. A sealed array or map+-- will no longer absorb (//).++newtype Seal a = Seal a++-- | Seal an array or map, indicating that it will no longer absorb (//). This+-- is needed if you wish to include an array or map inside a top-level choice.+seal :: a -> Seal a+seal = Seal++-- | This function is used solely to resolve type inference by explicitly+-- identifying something as an array.+arr :: ArrayChoice -> ArrayChoice+arr = id++-- | Create and seal an array, marking it as accepting no additional choices+sarr :: ArrayChoice -> Seal Array+sarr = seal . NoChoice++mp :: MapChoice -> MapChoice+mp = id++-- | Create and seal a map, marking it as accepting no additional choices.+smp :: MapChoice -> Seal Map+smp = seal . NoChoice++grp :: Group -> Group+grp = id++--------------------------------------------------------------------------------+-- Tagged types+--------------------------------------------------------------------------------++-- | A tagged type carries an optional tag+data Tagged a = Tagged (Maybe Word64) a+  deriving (Show, Functor)++-- | Tag a CBOR item with a CDDL minor type. Thus, `tag n x` is equivalent to+-- `#6.n(x)` in CDDL.+tag :: Word64 -> a -> Tagged a+tag mi = Tagged (Just mi)++--------------------------------------------------------------------------------+-- Generics+--------------------------------------------------------------------------------++newtype GRef = GRef T.Text+  deriving (Show)++freshName :: Int -> GRef+freshName ix =+  GRef $+    T.singleton (['a' .. 'z'] !! (ix `rem` 26))+      <> T.pack (show $ ix `quot` 26)++data GRule a = GRule+  { args :: NE.NonEmpty a+  , body :: Type0+  }+  deriving (Show)++type GRuleCall = Named (GRule Type2)++type GRuleDef = Named (GRule GRef)++callToDef :: GRule Type2 -> GRule GRef+callToDef gr = gr {args = refs}+  where+    refs =+      NE.unfoldr+        ( \ix ->+            ( freshName ix+            , if ix < NE.length (args gr) - 1 then Just (ix + 1) else Nothing+            )+        )+        0++-- | 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+  where+    rule = fRule (freshName 0)+    t2 = case toType0 t0 of+      NoChoice x -> x+      _ -> error "Cannot use a choice of types as a generic argument"++-- | 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+  where+    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"+    t12 = case toType0 t1 of+      NoChoice x -> x+      _ -> error "Cannot use a choice of types as a generic argument"++--------------------------------------------------------------------------------+-- Collecting all top-level rules+--------------------------------------------------------------------------------++hiRule :: HuddleItem -> [Rule]+hiRule (HIRule r) = [r]+hiRule _ = []++hiName :: HuddleItem -> T.Text+hiName (HIRule (Named n _ _)) = n+hiName (HIGroup (Named n _ _)) = n+hiName (HIGRule (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+--   top-level rules.+collectFrom :: [HuddleItem] -> Huddle+collectFrom topRs =+  toHuddle $+    execState+      (traverse goHuddleItem topRs)+      OMap.empty+  where+    toHuddle items =+      Huddle+        { roots = concatMap hiRule topRs+        , items = items+        }+    goHuddleItem (HIRule r) = goRule r+    goHuddleItem (HIGroup g) = goNamedGroup g+    goHuddleItem (HIGRule (Named _ (GRule _ t0) _)) = goT0 t0+    goRule r@(Named n t0 _) = do+      items <- get+      when (OMap.notMember n items) $ do+        modify (OMap.|> (n, HIRule r))+        goT0 t0+    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+      items <- get+      when (OMap.notMember n items) $ do+        modify (OMap.|> (n, HIGroup r))+        goGroup g+    goGRule r@(Named n g _) = do+      items <- get+      when (OMap.notMember n items) $ do+        modify (OMap.|> (n, HIGRule $ fmap callToDef r))+        goT0 (body g)+      -- Note that the parameters here may be different, so this doesn't live+      -- under the guard+      mapM_ goT2 $ args g+    goT2 (T2Range r) = goRanged r+    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 (T2Group r) = goNamedGroup r+    goT2 (T2Generic x) = goGRule x+    goT2 (T2Constrained (Constrained c _ refs)) =+      ( case c of+          CValue _ -> pure ()+          CRef r -> goRule r+          CGRef _ -> pure ()+      )+        >> mapM_ goRule refs+    goT2 _ = pure ()+    goArrayEntry (ArrayEntry (Just k) t0 _ _) = goKey k >> goT0 t0+    goArrayEntry (ArrayEntry Nothing t0 _ _) = goT0 t0+    goMapEntry (MapEntry k t0 _ _) = goKey k >> goT0 t0+    goKey (TypeKey k) = goT2 k+    goKey _ = pure ()+    goGroup (Group g) = mapM_ goArrayEntry g+    goRanged (Unranged _) = pure ()+    goRanged (Ranged lb ub _) = goRangeBound lb >> goRangeBound ub+    goRangeBound (RangeBoundLiteral _) = pure ()+    goRangeBound (RangeBoundRef r) = goRule r++-- | 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)+    `huddleAugment` collectFrom rules++--------------------------------------------------------------------------------+-- Conversion to CDDL+--------------------------------------------------------------------------------++-- | Convert from Huddle to CDDL, generating a top level root element.+toCDDL :: Huddle -> CDDL+toCDDL = toCDDL' True++-- | Convert from Huddle to CDDL, skipping a root element.+toCDDLNoRoot :: Huddle -> CDDL+toCDDLNoRoot = toCDDL' False++-- | Convert from Huddle to CDDL for the purpose of pretty-printing.+toCDDL' :: Bool -> Huddle -> CDDL+toCDDL' mkPseudoRoot hdl =+  C.fromRules+    $ ( if mkPseudoRoot+          then (toTopLevelPseudoRoot (roots hdl) NE.<|)+          else id+      )+    $ fmap toCDDLItem (NE.fromList $ fmap (view _2) $ toList $ items hdl)+  where+    toCDDLItem (HIRule r) = toCDDLRule r+    toCDDLItem (HIGroup g) = toCDDLGroup g+    toCDDLItem (HIGRule g) = toGenRuleDef g+    toTopLevelPseudoRoot :: [Rule] -> C.Rule+    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))+        . C.TOGType+        . C.Type0+        $ toCDDLType1 <$> choiceToNE t0+    toCDDLValue :: Literal -> C.Value+    toCDDLValue (Literal x cmt) = C.Value (toCDDLValue' x) cmt+    toCDDLValue' (LInt i) = C.VUInt i+    toCDDLValue' (LNInt i) = C.VNInt i+    toCDDLValue' (LBignum i) = C.VBignum i+    toCDDLValue' (LFloat i) = C.VFloat32 i+    toCDDLValue' (LDouble d) = C.VFloat64 d+    toCDDLValue' (LText t) = C.VText t+    toCDDLValue' (LBytes b) = C.VBytes b++    mapToCDDLGroup :: Map -> C.Group+    mapToCDDLGroup xs = C.Group $ mapChoiceToCDDL <$> choiceToNE xs++    mapChoiceToCDDL :: MapChoice -> C.GrpChoice+    mapChoiceToCDDL (MapChoice entries) = C.GrpChoice (fmap mapEntryToCDDL entries) mempty++    mapEntryToCDDL :: MapEntry -> C.GroupEntry+    mapEntryToCDDL (MapEntry k v occ cmnt) =+      C.GroupEntry+        (toOccurrenceIndicator occ)+        cmnt+        (C.GEType (Just $ toMemberKey k) (toCDDLType0 v))++    toOccurrenceIndicator :: Occurs -> Maybe C.OccurrenceIndicator+    toOccurrenceIndicator (Occurs Nothing Nothing) = Nothing+    toOccurrenceIndicator (Occurs (Just 0) (Just 1)) = Just C.OIOptional+    toOccurrenceIndicator (Occurs (Just 0) Nothing) = Just C.OIZeroOrMore+    toOccurrenceIndicator (Occurs (Just 1) Nothing) = Just C.OIOneOrMore+    toOccurrenceIndicator (Occurs lb ub) = Just $ C.OIBounded lb ub++    toCDDLType1 :: Type2 -> C.Type1+    toCDDLType1 = \case+      T2Constrained (Constrained x constr _) ->+        -- TODO Need to handle choices at the top level+        applyConstraint constr (C.T2Name (toCDDLConstrainable x) Nothing)+      T2Range l -> toCDDLRanged l+      T2Map m ->+        C.Type1+          (C.T2Map $ mapToCDDLGroup m)+          Nothing+          mempty+      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+      T2Generic g -> C.Type1 (toGenericCall g) Nothing mempty+      T2GenericRef (GRef n) -> C.Type1 (C.T2Name (C.Name n mempty) Nothing) Nothing mempty++    toMemberKey :: Key -> C.MemberKey+    toMemberKey (LiteralKey (Literal (LText t) _)) = C.MKBareword (C.Name t mempty)+    toMemberKey (LiteralKey v) = C.MKValue $ toCDDLValue v+    toMemberKey (TypeKey t) = C.MKType (toCDDLType1 t)++    toCDDLType0 :: Type0 -> C.Type0+    toCDDLType0 = C.Type0 . fmap toCDDLType1 . choiceToNE++    arrayToCDDLGroup :: Array -> C.Group+    arrayToCDDLGroup xs = C.Group $ arrayChoiceToCDDL <$> choiceToNE xs++    arrayChoiceToCDDL :: ArrayChoice -> C.GrpChoice+    arrayChoiceToCDDL (ArrayChoice entries cmt) = C.GrpChoice (fmap arrayEntryToCDDL entries) cmt++    arrayEntryToCDDL :: ArrayEntry -> C.GroupEntry+    arrayEntryToCDDL (ArrayEntry k v occ cmnt) =+      C.GroupEntry+        (toOccurrenceIndicator occ)+        cmnt+        (C.GEType (fmap toMemberKey k) (toCDDLType0 v))++    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++    toCDDLConstrainable c = case c of+      CValue v -> toCDDLPostlude v+      CRef r -> C.Name (name r) mempty+      CGRef (GRef n) -> C.Name n mempty++    toCDDLRanged :: Ranged -> C.Type1+    toCDDLRanged (Unranged x) =+      C.Type1 (C.T2Value $ toCDDLValue x) Nothing mempty+    toCDDLRanged (Ranged lb ub rop) =+      C.Type1+        (toCDDLRangeBound lb)+        (Just (C.RangeOp rop, toCDDLRangeBound ub))+        mempty++    toCDDLRangeBound :: RangeBound -> C.Type2+    toCDDLRangeBound (RangeBoundLiteral l) = C.T2Value $ toCDDLValue l+    toCDDLRangeBound (RangeBoundRef (Named n _ _)) = C.T2Name (C.Name n mempty) Nothing++    toCDDLGroup :: Named Group -> C.Rule+    toCDDLGroup (Named n (Group t0s) c) =+      C.Rule+        (C.Name n mempty)+        Nothing+        C.AssignEq+        ( C.TOGGroup+            . C.GroupEntry Nothing mempty+            . C.GEGroup+            . C.Group+            . (NE.:| [])+            . (`C.GrpChoice` mempty)+            $ fmap+              arrayEntryToCDDL+              t0s+        )+        (foldMap C.Comment c)++    toGenericCall :: GRuleCall -> C.Type2+    toGenericCall (Named n gr _) =+      C.T2Name+        (C.Name n mempty)+        (Just . C.GenericArg $ fmap toCDDLType1 (args gr))++    toGenRuleDef :: GRuleDef -> C.Rule+    toGenRuleDef (Named n gr c) =+      C.Rule+        (C.Name n mempty)+        (Just gps)+        C.AssignEq+        ( C.TOGType+            . C.Type0+            $ toCDDLType1 <$> choiceToNE (body gr)+        )+        (foldMap C.Comment c)+      where+        gps =+          C.GenericParam $ fmap (\(GRef t) -> C.Name t mempty) (args gr)
+ src/Codec/CBOR/Cuddle/Huddle/HuddleM.hs view
@@ -0,0 +1,106 @@+{-# LANGUAGE DataKinds #-}++-- | Monad for declaring Huddle constructs+module Codec.CBOR.Cuddle.Huddle.HuddleM (+  module Huddle,+  (=:=),+  (=:~),+  (=::=),+  binding,+  setRootRules,+  huddleDef,+  huddleDef',+  include,+  unsafeIncludeFromHuddle,+)+where++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+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)+n =:~ b = let r = n Huddle.=:~ b in include r++infixl 1 =:~++binding ::+  forall t0.+  IsType0 t0 =>+  (GRef -> Rule) ->+  HuddleM (t0 -> GRuleCall)+binding fRule = include (Huddle.binding fRule)++-- | Renamed version of Huddle's underlying '=:=' for use in generic bindings+(=::=) :: IsType0 a => T.Text -> a -> Rule+n =::= b = n Huddle.=:= b++infixl 1 =::=++setRootRules :: [Rule] -> HuddleM ()+setRootRules = modify . set (field @"roots")++huddleDef :: HuddleM a -> Huddle+huddleDef = snd . huddleDef'++huddleDef' :: HuddleM a -> (a, Huddle)+huddleDef' mh = runState mh def++class Includable a where+  -- | Include a rule, group, or generic rule defined elsewhere+  include :: a -> HuddleM a++instance Includable Rule where+  include r =+    modify (field @"items" %~ (OMap.|> (r ^. field @"name", HIRule r)))+      >> pure r++instance Includable (Named Group) where+  include r =+    modify+      ( (field @"items")+          %~ (OMap.|> (r ^. field @"name", 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"+     in do+          modify (field @"items" %~ (OMap.|> (n, HIGRule grDef)))+          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++unsafeIncludeFromHuddle ::+  Huddle ->+  T.Text ->+  HuddleM HuddleItem+unsafeIncludeFromHuddle h name =+  let items = h ^. field @"items"+   in case OMap.lookup name items of+        Just v -> include v+        Nothing -> error $ show name <> " was not found in Huddle spec"
+ src/Codec/CBOR/Cuddle/Huddle/Optics.hs view
@@ -0,0 +1,26 @@+{-# 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"
+ src/Codec/CBOR/Cuddle/Parser.hs view
@@ -0,0 +1,418 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}++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.Parser.Lexer (+  Parser,+  charInRange,+  pCommentBlock,+  space,+ )+import Control.Applicative.Combinators.NonEmpty qualified as NE+import Data.Foldable (Foldable (..))+import Data.Functor (void, ($>))+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 GHC.Word (Word64, Word8)+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+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++pTopLevel :: Parser TopLevel+pTopLevel = try tlRule <|> tlComment+  where+    tlRule = do+      mCmt <- optional pCommentBlock+      rule <- pRule+      pure . TopLevelRule $ rule //- fold mCmt+    tlComment = TopLevelComment <$> pCommentBlock++pRule :: Parser Rule+pRule = do+  name <- pName+  genericParam <- optcomp pGenericParam+  cmt <- space+  (assign, typeOrGrp) <-+    choice+      [ try $+          (,)+            <$> pAssignT+            <* space+            <*> (TOGType <$> pType0 <* notFollowedBy (space >> (":" <|> "=>")))+      , (,) <$> pAssignG <* space <*> (TOGGroup <$> pGrpEntry)+      ]+  pure $ Rule name genericParam assign typeOrGrp cmt++pName :: Parser Name+pName = label "name" $ do+  fc <- firstChar+  rest <- many midChar+  pure $ (`Name` mempty) . T.pack $ (fc : rest)+  where+    firstChar = letterChar <|> char '@' <|> char '_' <|> char '$'+    midChar =+      alphaNumChar+        <|> char '@'+        <|> char '_'+        <|> char '$'+        <|> ((char '.' <|> char '-') <* notFollowedBy (space1 <|> eof <|> void eol))++pAssignT :: Parser Assign+pAssignT =+  choice+    [ AssignEq <$ "="+    , AssignExt <$ "/="+    ]++pAssignG :: Parser Assign+pAssignG =+  choice+    [ AssignEq <$ "="+    , AssignExt <$ "//="+    ]++pGenericParam :: Parser GenericParam+pGenericParam =+  GenericParam+    <$> between "<" ">" (NE.sepBy1 (space !*> pName <*! space) ",")++pGenericArg :: Parser GenericArg+pGenericArg =+  GenericArg+    <$> between "<" ">" (NE.sepBy1 (space !*> pType1 <*! space) ",")++pType0 :: Parser Type0+pType0 = Type0 <$> sepBy1' (space !*> pType1 <*! space) (try "/")++pType1 :: Parser Type1+pType1 = do+  v <- pType2+  rest <- optional $ do+    (cmtFst, tyOp) <- try $ do+      cmt <- space+      tyOp <- pTyOp+      pure (cmt, tyOp)+    cmtSnd <- space+    w <- pType2+    pure (cmtFst, tyOp, cmtSnd, w)+  case rest of+    Just (cmtFst, tyOp, cmtSnd, w) ->+      pure $ Type1 v (Just (tyOp, w)) $ cmtFst <> cmtSnd+    Nothing -> pure $ Type1 v Nothing mempty++pType2 :: Parser Type2+pType2 =+  choice+    [ T2Value <$> pValue+    , T2Name <$> pName <*> optional pGenericArg+    , T2Group <$> label "group" ("(" *> space !*> pType0 <*! space <* ")")+    , T2Map <$> label "map" ("{" *> pGroup <* "}")+    , T2Array <$> label "array" ("[" *> space !*> pGroup <*! space <* "]")+    , T2Unwrapped <$> ("~" *> space !*> pName) <*> optional pGenericArg+    , do+        _ <- "&"+        cmt <- space+        choice+          [ T2Enum <$> ("(" *> space !*> pGroup <*! pure cmt <*! space <* ")")+          , T2EnumRef <$> pName <*> optional pGenericArg+          ]+    , "#" *> do+        mmajor :: Maybe Word8 <- optional L.decimal+        case mmajor of+          Just major -> do+            mminor <- optional ("." *> L.decimal)+            let+              pTag+                | major == 6 = T2Tag mminor <$> ("(" *> space !*> pType0 <*! space <* ")")+                | otherwise = empty+            pTag <|> pure (T2DataItem major mminor)+          Nothing -> pure T2Any+    ]++pHeadNumber :: Parser Word64+pHeadNumber = L.decimal++pRangeOp :: Parser RangeBound+pRangeOp = label "range operator" $ try ("..." $> ClOpen) <|> (".." $> Closed)++pCtlOp :: Parser CtlOp+pCtlOp =+  label "control operator" $+    "."+      *> choice+        ( try+            <$> [ "cborseq" $> COp.Cborseq+                , "cbor" $> COp.Cbor+                , "size" $> COp.Size+                , "bits" $> COp.Bits+                , "within" $> COp.Within+                , "and" $> COp.And+                , "lt" $> COp.Lt+                , "le" $> COp.Le+                , "gt" $> COp.Gt+                , "ge" $> COp.Ge+                , "eq" $> COp.Eq+                , "ne" $> COp.Ne+                , "default" $> COp.Default+                , "regexp" $> COp.Regexp+                ]+        )++pGroup :: Parser Group+pGroup = Group <$> NE.sepBy1 (space !*> pGrpChoice) "//"++pGrpChoice :: Parser GrpChoice+pGrpChoice = GrpChoice <$> many (space !*> pGrpEntry <*! pOptCom) <*> mempty++pGrpEntry :: Parser GroupEntry+pGrpEntry = do+  occur <- optcomp pOccur+  cmt <- space+  WithComment cmt' variant <-+    choice+      [ try $ do+          mKey <- optcomp $ pMemberKey <*! space+          t0 <- pType0+          pure $ GEType <$> sequence mKey <*> pure t0+      , try $ withComment <$> (GERef <$> pName <*> optional pGenericArg)+      , withComment . GEGroup <$> ("(" *> space !*> pGroup <*! space <* ")")+      ]+  pure $ GroupEntry occur (cmt <> cmt') variant++pMemberKey :: Parser (WithComment MemberKey)+pMemberKey =+  choice+    [ try $ do+        t1 <- pType1+        cmt0 <- space+        cmt1 <- fold <$> optcomp ("^" *> space) <* "=>"+        pure $ WithComment (cmt0 <> cmt1) (MKType t1)+    , try $ do+        name <- pName+        cmt <- space+        _ <- ":"+        pure . WithComment cmt $ MKBareword name+    , do+        val <- pValue+        cmt <- space+        _ <- ":"+        pure . WithComment cmt $ MKValue val+    ]++pOptCom :: Parser Comment+pOptCom = space <*! (fold <$> optional ("," >> space))++pOccur :: Parser OccurrenceIndicator+pOccur =+  label "occurrence indicator" $+    choice+      [ char '+' $> OIOneOrMore+      , char '?' $> OIOptional+      , pBounded+      ]++pValue :: Parser Value+pValue =+  label "value" $+    (`Value` mempty)+      <$> choice+        [ try pFloat+        , try pInt+        , try pBytes+        , pText+        ]+  where+    pSignedNum :: Num a => Parser a -> Parser (Bool, a)+    pSignedNum valParser = do+      sign <- optional "-"+      val <- valParser <* notFollowedBy "*"+      pure (isJust sign, val)+    -- Need to ensure that number values are not actually bounds on a later+    -- value.+    pInt =+      pSignedNum L.decimal >>= \case+        (False, val) -> pure $ VUInt val+        (True, val) -> pure $ VNInt val+    pFloat =+      pSignedNum L.float >>= \case+        (False, val) -> pure $ VFloat64 val+        (True, val) -> pure . VFloat64 $ negate val+    -- Currently this doesn't allow string escaping+    pSChar :: Parser Text+    pSChar = takeWhileP (Just "character") $ \x ->+      or $+        [ charInRange '\x20' '\x21'+        , charInRange '\x23' '\x5b'+        , charInRange '\x5d' '\x7e'+        , charInRange '\x80' '\x10fffd'+        ]+          <*> pure x+    pText = VText <$> ("\"" *> pSChar <* "\"")+    pSByte = takeWhileP (Just "byte character") $ \x ->+      or $+        [ charInRange '\x20' '\x26'+        , charInRange '\x28' '\x5b'+        , charInRange '\x5d' '\x10fffd'+        ]+          <*> pure x+    pBytes = do+      _qualifier <- optional ("h" <|> "b64")+      between "'" "'" $ VBytes . encodeUtf8 <$> pSByte++pTyOp :: Parser TyOp+pTyOp =+  choice+    [ try $ RangeOp <$> pRangeOp+    , CtrlOp <$> pCtlOp+    ]++pBounded :: Parser OccurrenceIndicator+pBounded = do+  lo <- optional L.decimal+  _ <- char '*'+  hi <- optional L.decimal+  pure $ case (lo, hi) of+    (Nothing, Nothing) -> OIZeroOrMore+    (x, y) -> OIBounded x y++-- | A variant of 'optional' for composite parsers, which will consume no input+-- if it fails.+optcomp :: MonadParsec e s f => f a -> f (Maybe a)+optcomp = optional . try++{-+cddl = S *(rule S)+rule = typename [genericparm] S assignt S type+     / groupname [genericparm] S assigng S grpent++typename = id+groupname = id++assignt = "=" / "/="+assigng = "=" / "//="++genericparm = "<" S id S *("," S id S ) ">"+genericarg = "<" S type1 S *("," S type1 S ) ">"++type = type1 *(S "/" S type1)++type1 = type2 [S (rangeop / ctlop) S type2]+; space may be needed before the operator if type2 ends in a name++type2 = value+      / typename [genericarg]+      / "(" S type S ")"+      / "{" S group S "}"+      / "[" S group S "]"+      / "~" S typename [genericarg]+      / "&" S "(" S group S ")"+      / "&" S groupname [genericarg]+      / "#" "6" ["." head-number] "(" S type S ")"+      / "#" "7" ["." head-number]+      / "#" DIGIT ["." uint]                ; major/ai+      / "#"                                 ; any+head-number = uint / ("<" type ">")++rangeop = "..." / ".."++ctlop = "." id++group = grpchoice *(S "//" S grpchoice)++grpchoice = *(grpent optcom)++grpent = [occur S] [memberkey S] type+       / [occur S] groupname [genericarg]  ; preempted by above+       / [occur S] "(" S group S ")"++memberkey = type1 S ["^" S] "=>"+          / bareword S ":"+          / value S ":"++bareword = id++optcom = S ["," S]++occur = [uint] "*" [uint]+      / "+"+      / "?"++uint = DIGIT1 *DIGIT+     / "0x" 1*HEXDIG+     / "0b" 1*BINDIG+     / "0"++value = number+      / text+      / bytes++int = ["-"] uint++; This is a float if it has fraction or exponent; int otherwise+number = hexfloat / (int ["." fraction] ["e" exponent ])+hexfloat = ["-"] "0x" 1*HEXDIG ["." 1*HEXDIG] "p" exponent+fraction = 1*DIGIT+exponent = ["+"/"-"] 1*DIGIT++text = %x22 *SCHAR %x22+SCHAR = %x20-21 / %x23-5B / %x5D-7E / NONASCII / SESC++SESC = "\" ( %x22 / "/" / "\" /                 ; \" \/ \\+             %x62 / %x66 / %x6E / %x72 / %x74 / ; \b \f \n \r \t+             (%x75 hexchar) )                   ; \uXXXX++hexchar = "{" (1*"0" [ hexscalar ] / hexscalar) "}" /+          non-surrogate / (high-surrogate "\" %x75 low-surrogate)+non-surrogate = ((DIGIT / "A"/"B"/"C" / "E"/"F") 3HEXDIG) /+                ("D" %x30-37 2HEXDIG )+high-surrogate = "D" ("8"/"9"/"A"/"B") 2HEXDIG+low-surrogate = "D" ("C"/"D"/"E"/"F") 2HEXDIG+hexscalar = "10" 4HEXDIG / HEXDIG1 4HEXDIG+          / non-surrogate / 1*3HEXDIG++bytes = [bsqual] %x27 *BCHAR %x27+BCHAR = %x20-26 / %x28-5B / %x5D-7E / NONASCII / SESC / "\'" / CRLF+bsqual = "h" / "b64"++id = EALPHA *(*("-" / ".") (EALPHA / DIGIT))+ALPHA = %x41-5A / %x61-7A+EALPHA = ALPHA / "@" / "_" / "$"+DIGIT = %x30-39+DIGIT1 = %x31-39+HEXDIG = DIGIT / "A" / "B" / "C" / "D" / "E" / "F"+HEXDIG1 = DIGIT1 / "A" / "B" / "C" / "D" / "E" / "F"+BINDIG = %x30-31++S = *WS+WS = SP / NL+SP = %x20+NL = COMMENT / CRLF+COMMENT = ";" *PCHAR CRLF+PCHAR = %x20-7E / NONASCII+NONASCII = %xA0-D7FF / %xE000-10FFFD+CRLF = %x0A / %x0D.0A+-}++-- | Variant on 'NE.sepEndBy1' which doesn't consume the separator+sepBy1' :: MonadParsec e s m => m a -> m sep -> m (NonEmpty a)+sepBy1' p sep = NE.fromList <$> go+  where+    go = liftA2 (:) p (many (try $ sep *> p))
+ src/Codec/CBOR/Cuddle/Parser/Lexer.hs view
@@ -0,0 +1,50 @@+{-# LANGUAGE OverloadedStrings #-}++module Codec.CBOR.Cuddle.Parser.Lexer (+  Parser,+  charInRange,+  space,+  pComment,+  sameLineComment,+  (|||),+  pCommentBlock,+) where++import Codec.CBOR.Cuddle.Comments (Comment (..))+import Control.Applicative.Combinators.NonEmpty qualified as NE+import Data.Foldable1 (Foldable1 (..))+import Data.Functor (($>))+import Data.Text (Text)+import Data.Void (Void)+import Text.Megaparsec (+  MonadParsec (..),+  Parsec,+  sepEndBy,+  (<|>),+ )+import Text.Megaparsec.Char (char, eol)+import Text.Megaparsec.Char qualified as L++type Parser = Parsec Void Text++charInRange :: Char -> Char -> Char -> Bool+charInRange lb ub x = lb <= x && x <= ub++(|||) :: (a -> Bool) -> (a -> Bool) -> (a -> Bool)+(x ||| y) a = x a || y a++pComment :: Parser Comment+pComment =+  Comment <$> label "comment" (char ';' *> takeWhileP Nothing validChar <* eol)+  where+    validChar = charInRange '\x20' '\x7e' ||| charInRange '\x80' '\x10fffd'++pCommentBlock :: Parser Comment+pCommentBlock = fold1 <$> NE.some (L.hspace *> pComment)++space :: Parser Comment+space = mconcat <$> (L.space *> sepEndBy pComment L.space)++sameLineComment :: Parser Comment+sameLineComment =+  try ((<>) <$> (L.hspace *> pComment) <*> space) <|> (L.space $> mempty)
+ src/Codec/CBOR/Cuddle/Pretty.hs view
@@ -0,0 +1,213 @@+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ViewPatterns #-}+{-# OPTIONS_GHC -Wno-orphans #-}++module Codec.CBOR.Cuddle.Pretty 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.Pretty.Columnar (+  Cell (..),+  CellAlign (..),+  Columnar (..),+  Row (..),+  cellL,+  columnarListing,+  columnarSepBy,+  emptyCell,+  prettyColumnar,+  singletonRow,+ )+import Codec.CBOR.Cuddle.Pretty.Utils (renderedLen, softspace)+import Data.ByteString.Char8 qualified as BS+import Data.Foldable (Foldable (..))+import Data.List.NonEmpty qualified as NE+import Data.String (fromString)+import Data.Text qualified as T+import Prettyprinter++instance Pretty CDDL where+  pretty = vsep . fmap pretty . NE.toList . cddlTopLevel++instance Pretty TopLevel where+  pretty (TopLevelComment cmt) = pretty cmt+  pretty (TopLevelRule x) = pretty x <> hardline++instance Pretty Name where+  pretty (Name name cmt) = pretty name <> prettyCommentNoBreakWS cmt++data CommentRender+  = PreComment+  | PostComment++prettyCommentNoBreak :: Comment -> Doc ann+prettyCommentNoBreak = align . vsep . toList . fmap (pretty . ("; " <>)) . unComment++prettyCommentNoBreakWS :: Comment -> Doc ann+prettyCommentNoBreakWS cmt+  | cmt == mempty = mempty+  | otherwise = space <> prettyCommentNoBreak cmt++instance Pretty Comment where+  pretty (Comment "") = mempty+  pretty c = prettyCommentNoBreak c <> hardline++type0Def :: Type0 -> Doc ann+type0Def t = nest 2 $ line' <> pretty t++instance Pretty Rule where+  pretty (Rule n mgen assign tog cmt) =+    pretty cmt+      <> groupIfNoComments+        tog+        ( pretty n <> pretty mgen <+> case tog of+            TOGType t -> ppAssignT <> softline <> type0Def t+            TOGGroup g -> ppAssignG <> softline <> nest 2 (line' <> pretty g)+        )+    where+      ppAssignT = case assign of+        AssignEq -> "="+        AssignExt -> "/="+      ppAssignG = case assign of+        AssignEq -> "="+        AssignExt -> "//="++instance Pretty GenericArg 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+    | otherwise = columnarListing "<" ">" "," . Columnar $ singletonRow . pretty <$> l++instance Pretty Type0 where+  pretty t0@(Type0 (NE.toList -> l)) =+    groupIfNoComments t0 $ columnarSepBy "/" . Columnar $ type1ToRow <$> l+    where+      type1ToRow (Type1 t2 tyOp cmt) =+        let+          valCell = case tyOp of+            Nothing -> cellL t2+            Just (to, t2') -> Cell (pretty t2 <+> pretty to <+> pretty t2') LeftAlign+         in+          Row [valCell, Cell (prettyCommentNoBreakWS cmt) LeftAlign]++instance Pretty CtlOp where+  pretty = pretty . T.toLower . T.pack . show++instance Pretty TyOp where+  pretty (RangeOp ClOpen) = "..."+  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) =+    groupIfNoComments t2 (pretty t2)+      <+> pretty tyop+      <+> groupIfNoComments t2' (pretty t2')+      <> prettyCommentNoBreakWS cmt++instance Pretty Type2 where+  pretty (T2Value v) = pretty v+  pretty (T2Name n mg) = pretty n <> pretty mg+  pretty (T2Group g) = cEncloseSep "(" ")" mempty [pretty g]+  pretty (T2Map g) = prettyGroup AsMap g+  pretty (T2Array g) = prettyGroup AsArray g+  pretty (T2Unwrapped n mg) = "~" <+> pretty n <> pretty mg+  pretty (T2Enum g) = "&" <+> prettyGroup AsGroup g+  pretty (T2EnumRef g mg) = "&" <+> pretty g <> pretty mg+  pretty (T2Tag minor t) = "#6" <> min' <> enclose "(" ")" (group $ nest 2 (line' <> pretty t) <> line')+    where+      min' = case minor of+        Nothing -> mempty+        Just m -> "." <> pretty m+  pretty (T2DataItem major mminor) =+    "#" <> pretty major <> case mminor of+      Nothing -> mempty+      Just minor -> "." <> pretty minor+  pretty T2Any = "#"++instance Pretty OccurrenceIndicator where+  pretty OIOptional = "?"+  pretty OIZeroOrMore = "*"+  pretty OIOneOrMore = "+"+  pretty (OIBounded ml mh) = pretty ml <> "*" <> pretty mh++-- | Control how to render a group+data GroupRender+  = AsMap+  | AsArray+  | AsGroup++memberKeySep :: MemberKey -> Doc ann+memberKeySep MKType {} = " => "+memberKeySep _ = " : "++cEncloseSep :: Doc ann -> Doc ann -> Doc ann -> [Doc ann] -> Doc ann+cEncloseSep lEnc rEnc _ [] = lEnc <> rEnc+cEncloseSep lEnc rEnc _ [x] =+  group . align . vcat $+    [ lEnc <> softspace <> x+    , rEnc+    ]+cEncloseSep lEnc rEnc s (h : tl) =+  group . align $ vsep ((lEnc <> lSpaces <> group h) : fmap ((s <> space) <>) tl) <> line' <> rEnc+  where+    lSpaces = mconcat $ replicate (renderedLen s) softspace++groupIfNoComments :: CollectComments a => a -> Doc ann -> Doc ann+groupIfNoComments x+  | not (any (mempty /=) $ collectComments x) = group+  | otherwise = id++columnarGroupChoice :: GrpChoice -> Columnar ann+columnarGroupChoice (GrpChoice ges _cmt) = Columnar grpEntryRows+  where+    groupEntryRow (GroupEntry oi cmt gev) =+      Row $+        [maybe emptyCell (\x -> Cell (pretty x <> space) LeftAlign) oi]+          <> groupEntryVariantCells gev+          <> [Cell (prettyCommentNoBreakWS cmt) LeftAlign]+    groupEntryVariantCells (GERef n ga) = [Cell (pretty n <> pretty ga) LeftAlign]+    groupEntryVariantCells (GEType (Just mk) t0) = [cellL mk, Cell (memberKeySep mk <> groupIfNoComments t0 (align $ pretty t0)) LeftAlign]+    groupEntryVariantCells (GEType Nothing t0) = [cellL t0]+    groupEntryVariantCells (GEGroup g) = [Cell (prettyGroup AsGroup g) LeftAlign, emptyCell]+    grpEntryRows = groupEntryRow <$> ges++prettyGroup :: GroupRender -> Group -> Doc ann+prettyGroup gr g@(Group (toList -> xs)) =+  groupIfNoComments g . columnarListing (lEnc <> softspace) rEnc "// " . Columnar $+    (\x -> singletonRow . groupIfNoComments x . columnarSepBy "," $ columnarGroupChoice x) <$> xs+  where+    (lEnc, rEnc) = case gr of+      AsMap -> ("{", "}")+      AsArray -> ("[", "]")+      AsGroup -> ("(", ")")++instance Pretty GroupEntry where+  pretty ge = prettyColumnar . columnarGroupChoice $ GrpChoice [ge] mempty++instance Pretty MemberKey where+  pretty (MKType t1) = pretty t1+  pretty (MKBareword n) = pretty n+  pretty (MKValue v) = pretty v++instance Pretty Value where+  pretty (Value v cmt) = pretty v <> prettyCommentNoBreakWS cmt++instance Pretty ValueVariant where+  pretty (VUInt i) = pretty i+  pretty (VNInt i) = "-" <> pretty i+  pretty (VBignum i) = pretty i+  pretty (VFloat16 i) = pretty i+  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 (VBool True) = "true"+  pretty (VBool False) = "false"
+ src/Codec/CBOR/Cuddle/Pretty/Columnar.hs view
@@ -0,0 +1,125 @@+-- | This module provides some utility functions to help with aligning pretty+-- printed values by column.+module Codec.CBOR.Cuddle.Pretty.Columnar (+  CellAlign (..),+  Row (..),+  Cell (..),+  cellL,+  cellR,+  emptyCell,+  isEmptyCell,+  Columnar (..),+  prettyColumnar,+  columnarListing,+  columnarSepBy,+  singletonRow,+) where++import Codec.CBOR.Cuddle.Pretty.Utils (fillLeft, fillRight, renderedLen)+import Prettyprinter (Doc, Pretty (..), line', vcat, (<+>))++data CellAlign+  = LeftAlign+  | RightAlign++data Cell ann = Cell+  { cellDoc :: Doc ann+  , cellAlign :: CellAlign+  }++-- | Creates a cell by pretty printing the input value and then left-aligning+-- the resulting `Doc` within the table.+cellL :: Pretty a => a -> Cell ann+cellL = (`Cell` LeftAlign) . pretty++-- | Creates a cell by pretty printing the input value and then right-aligning+-- the resulting `Doc` within the table.+cellR :: Pretty a => a -> Cell ann+cellR = (`Cell` RightAlign) . pretty++-- | A cell that takes up a cell but has no content.+emptyCell :: Cell ann+emptyCell = Cell mempty LeftAlign++-- | Checks whether the cell contains a `Doc` with a rendered width of zero.+isEmptyCell :: Cell ann -> Bool+isEmptyCell (Cell d _) = renderedLen d == 0++-- | A row within the table.+newtype Row ann = Row {rowCells :: [Cell ann]}++-- | Adds a cell at the beginning of the row.+prependCell :: Cell ann -> Row ann -> Row ann+prependCell c (Row cs) = Row $ c : cs++-- | A row with a single left-aligned document+singletonRow :: Doc ann -> Row ann+singletonRow x = Row [Cell x LeftAlign]++-- | `Columnar` is a two-dimensional table of `Doc`s. When rendered, the cells+-- within each row will be aligned with the cells of every other row in the+-- same column.+newtype Columnar ann = Columnar {colRows :: [Row ann]}++prettyRow :: [Int] -> [Cell ann] -> Doc ann+prettyRow = prettyRow'+  where+    prettyRow' [] (Cell c _ : cs) = c <> prettyRow' [] cs+    prettyRow' _ [] = mempty+    prettyRow' _ [Cell c LeftAlign] = c -- Do not add white space to the last cell+    prettyRow' (0 : ws) (_ : cs) = prettyRow' ws cs -- Skip empty columns+    prettyRow' (w : ws) (Cell c alignment : cs) =+      let+        align' = case alignment of+          LeftAlign -> fillRight+          RightAlign -> fillLeft+       in+        align' w c <> prettyRow' ws cs++-- | Pretty print the `Columnar` as a table.+prettyColumnar :: forall ann. Columnar ann -> Doc ann+prettyColumnar (Columnar rows) = vcat $ prettyRow columnWidths . rowCells <$> rows+  where+    columnWidths =+      foldr (zipWith max . fmap (renderedLen . cellDoc) . rowCells) (repeat 0) rows++-- | Pretty prints the `Columnar` so that the rows are separated by by the+-- separator `Doc` provided as the third argument and then everything is+-- enclosed within the left and right brackets provided as the first and second+-- argument accordingly. The brackets will be aligned with the separators in the+-- first column, e.g.+-- ```+-- [ foo+-- , bar+-- ]+-- ```+columnarListing :: Doc ann -> Doc ann -> Doc ann -> Columnar ann -> Doc ann+columnarListing lEnc rEnc _ (Columnar []) = lEnc <> rEnc+columnarListing lEnc rEnc s (Columnar (row : rows)) =+  prettyColumnar+    ( Columnar $+        prependCell (Cell lEnc LeftAlign) row+          : (prependCell (Cell s LeftAlign) <$> rows)+    )+    <> line'+    <> rEnc++-- | Pretty prints the `Columnar` so that every line after the first has a+-- separator prepended to it. This can be useful when you want to align the rows,+-- but the separator would cause all the other rows after the first to be shifted+-- right by one. The way you use this is you reduce the indentation on the+-- following lines by the width of the separator.+-- ```+-- foo = x+--     , y+--     , z+-- ```+columnarSepBy :: Doc ann -> Columnar ann -> Doc ann+columnarSepBy _ (Columnar []) = mempty+columnarSepBy s (Columnar rows@(Row x : xs)) =+  prettyRow columnWidths x <> line' <> prettyColumnar (Columnar $ prependRow <$> xs)+  where+    prependRow (Row (Cell c al : cs)) = Row $ Cell (s <+> c) al : cs+    prependRow (Row []) = Row []+    columnWidths =+      foldr (zipWith max . fmap (renderedLen . cellDoc) . rowCells) (repeat 0) rows
+ src/Codec/CBOR/Cuddle/Pretty/Utils.hs view
@@ -0,0 +1,20 @@+module Codec.CBOR.Cuddle.Pretty.Utils where++import Data.Text qualified as T+import Prettyprinter (Doc, flatAlt, layoutCompact, space)+import Prettyprinter.Render.Text (renderStrict)++renderedLen :: Doc ann -> Int+renderedLen = T.length . renderStrict . layoutCompact++softspace :: Doc ann+softspace = flatAlt space mempty++spaces :: Int -> Doc ann+spaces i = mconcat $ replicate i softspace++fillLeft :: Int -> Doc ann -> Doc ann+fillLeft len doc = spaces (len - renderedLen doc) <> doc++fillRight :: Int -> Doc ann -> Doc ann+fillRight len doc = doc <> spaces (len - renderedLen doc)
+ test/Main.hs view
@@ -0,0 +1,23 @@+module Main (main) where++import System.IO (BufferMode (..), hSetBuffering, hSetEncoding, stdout, utf8)+import Test.Codec.CBOR.Cuddle.CDDL.Examples qualified as Examples+import Test.Codec.CBOR.Cuddle.CDDL.Parser (parserSpec)+import Test.Codec.CBOR.Cuddle.Huddle (huddleSpec)+import Test.Hspec+import Test.Hspec.Runner++hspecConfig :: Config+hspecConfig =+  defaultConfig+    { configColorMode = ColorAlways+    }++main :: IO ()+main = do+  hSetBuffering stdout LineBuffering+  hSetEncoding stdout utf8+  hspecWith hspecConfig $ do+    describe "cddlParser" parserSpec+    describe "Huddle" huddleSpec+    describe "Examples" Examples.spec
+ test/Test/Codec/CBOR/Cuddle/CDDL/Examples.hs view
@@ -0,0 +1,27 @@+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.Parser (pCDDL)+import Data.Either (isRight)+import Data.Text.IO qualified as T+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+  cddl <- case parse pCDDL "" contents of+    Right x -> pure $ prependPrelude x+    Left x -> fail $ "Failed to parse the file:\n" <> errorBundlePretty x+  fullResolveCDDL cddl `shouldSatisfy` isRight++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"
+ test/Test/Codec/CBOR/Cuddle/CDDL/Gen.hs view
@@ -0,0 +1,294 @@+{-# LANGUAGE ViewPatterns #-}+{-# OPTIONS_GHC -Wno-orphans #-}++-- | Hedgehog generators for CDDL+module Test.Codec.CBOR.Cuddle.CDDL.Gen () where++import Codec.CBOR.Cuddle.CDDL+import Codec.CBOR.Cuddle.CDDL.CtlOp+import Codec.CBOR.Cuddle.Comments (Comment (..))+import Data.ByteString (ByteString)+import Data.ByteString qualified as BS+import Data.List.NonEmpty qualified as NE+import Data.Maybe (mapMaybe)+import Data.Text qualified as T+import Test.QuickCheck+import Test.QuickCheck qualified as Gen++instance Arbitrary CDDL where+  arbitrary = CDDL <$> arbitrary <*> arbitrary <*> arbitrary+  shrink = genericShrink++instance Arbitrary TopLevel where+  arbitrary =+    Gen.oneof+      [ TopLevelComment <$> arbitrary+      , TopLevelRule <$> arbitrary+      ]+  shrink = genericShrink++instance Arbitrary T.Text where+  arbitrary = T.pack <$> arbitrary+  shrink = fmap T.pack . shrink . T.unpack++instance Arbitrary ByteString where+  arbitrary = BS.pack <$> arbitrary+  shrink = fmap BS.pack . shrink . BS.unpack++instance Arbitrary Comment where+  arbitrary = Comment <$> arbitrary+  shrink = genericShrink++nameFstChars :: [Char]+nameFstChars = ['a' .. 'z'] <> ['A' .. 'Z'] <> ['@', '_', '$']++nameMidChars :: [Char]+nameMidChars = nameFstChars <> ['1' .. '9'] <> ['-', '.']++nameEndChars :: [Char]+nameEndChars = nameFstChars <> ['1' .. '9']++instance Arbitrary Name where+  arbitrary =+    let veryShortListOf = resize 3 . listOf+     in do+          fstChar <- elements nameFstChars+          midChar <- veryShortListOf . elements $ nameMidChars+          lastChar <- elements nameEndChars+          pure $ Name (T.pack $ fstChar : midChar <> [lastChar]) mempty++  shrink (Name xs cmt) =+    Name+      <$> fmap T.pack (filter isValidName (shrink $ T.unpack xs))+      <*> shrink cmt+    where+      isValidName [] = False+      isValidName (h : tl) = h `elem` nameFstChars && isValidNameTail tl++      isValidNameTail [] = True+      isValidNameTail [x] = x `elem` nameEndChars+      isValidNameTail (h : tl) = h `elem` nameMidChars && isValidNameTail tl++instance Arbitrary Assign where+  arbitrary = Gen.elements [AssignEq, AssignExt]+  shrink = genericShrink++instance Arbitrary GenericParam where+  arbitrary = GenericParam <$> nonEmpty arbitrary+  shrink (GenericParam neName) = GenericParam <$> shrinkNE neName++instance Arbitrary GenericArg where+  arbitrary = GenericArg <$> nonEmpty arbitrary+  shrink (GenericArg neArg) = GenericArg <$> shrinkNE neArg++instance Arbitrary Rule where+  arbitrary =+    Rule+      <$> arbitrary+      <*> arbitrary+      <*> arbitrary+      <*> arbitrary+      <*> arbitrary+  shrink = genericShrink++instance Arbitrary RangeBound where+  arbitrary = Gen.elements [ClOpen, Closed]+  shrink = genericShrink++instance Arbitrary TyOp where+  arbitrary =+    Gen.oneof+      [ RangeOp <$> arbitrary+      , CtrlOp <$> arbitrary+      ]+  shrink = genericShrink++instance Arbitrary TypeOrGroup where+  arbitrary =+    Gen.oneof+      [ TOGGroup <$> arbitrary+      , TOGType <$> arbitrary+      ]+  shrink = genericShrink++instance Arbitrary Type0 where+  arbitrary = Type0 <$> nonEmpty arbitrary+  shrink (Type0 neType1) = Type0 <$> shrinkNE neType1++instance Arbitrary Type1 where+  arbitrary = Type1 <$> arbitrary <*> arbitrary <*> arbitrary+  shrink = genericShrink++instance Arbitrary Type2 where+  arbitrary =+    recursive+      Gen.oneof+      [ T2Value <$> arbitrary+      , T2Map <$> arbitrary+      , T2Array <$> arbitrary+      , T2Enum <$> arbitrary+      , T2DataItem+          <$> elements [0 .. 7]+          <*> genMaybe Gen.arbitrarySizedBoundedIntegral+      , T2Name <$> arbitrary <*> maybeRec arbitrary+      , T2Unwrapped <$> arbitrary <*> maybeRec arbitrary+      , T2EnumRef <$> arbitrary <*> maybeRec arbitrary+      , pure T2Any+      ]+      [ T2Group <$> arbitrary+      , T2Tag <$> arbitrary <*> arbitrary+      ]+  shrink = genericShrink++instance Arbitrary OccurrenceIndicator where+  arbitrary =+    Gen.oneof+      [ pure OIOptional+      , pure OIZeroOrMore+      , pure OIOneOrMore+      , OIBounded+          <$> arbitrary+          <*> arbitrary+      ]++  shrink = genericShrink++instance Arbitrary Group where+  arbitrary = Group <$> nonEmpty arbitrary+  shrink (Group gr) = Group <$> shrinkNE gr++instance Arbitrary GrpChoice where+  arbitrary = GrpChoice <$> listOf' arbitrary <*> pure mempty+  shrink = genericShrink++instance Arbitrary GroupEntryVariant where+  arbitrary =+    recursive+      Gen.oneof+      [ GERef+          <$> arbitrary+          <*> maybeRec arbitrary+      ]+      [ GEType+          <$> arbitrary+          <*> arbitrary+      , GEGroup <$> arbitrary+      ]+  shrink = genericShrink++instance Arbitrary GroupEntry where+  arbitrary =+    GroupEntry+      <$> arbitrary+      <*> pure mempty+      <*> arbitrary+  shrink = genericShrink++instance Arbitrary MemberKey where+  arbitrary =+    recursive+      Gen.oneof+      [ MKBareword <$> arbitrary+      , MKValue <$> arbitrary+      ]+      [ MKType <$> arbitrary+      ]++  shrink = genericShrink++instance Arbitrary Value where+  arbitrary = Value <$> arbitrary <*> arbitrary+  shrink = genericShrink++instance Arbitrary ValueVariant where+  arbitrary =+    Gen.oneof+      [ VUInt <$> arbitrary+      , VNInt <$> arbitrary+      , VFloat16 <$> arbitrary+      , VFloat32 <$> arbitrary+      , VFloat64 <$> arbitrary+      , VText . T.pack <$> listOf (elements $ ['a' .. 'z'] <> ['0' .. '9'] <> [' '])+      -- VBytes <$> Gen.bytes (Range.linear 0 1100)+      ]+  shrink = genericShrink++instance Arbitrary CtlOp where+  arbitrary =+    Gen.elements+      [ Size+      , Bits+      , Regexp+      , Cbor+      , Cborseq+      , Within+      , And+      , Lt+      , Le+      , Gt+      , Ge+      , Eq+      , Ne+      , Default+      ]+  shrink = genericShrink++--------------------------------------------------------------------------------+-- Utility+--------------------------------------------------------------------------------++-- | Generate a non-empty list. This function applies similar recursive scaling+-- to @listOf'@ - see the comment there for details.+nonEmpty :: Gen a -> Gen (NE.NonEmpty a)+nonEmpty f = do+  sing <- f+  n <- getSize+  k <- choose (0, n)+  (sing NE.:|) <$> vectorOf k (scale (scaleBy k) f)++-- | Generates 'Nothing' some of the time+genMaybe :: Gen a -> Gen (Maybe a)+genMaybe f = Gen.oneof [Just <$> f, pure Nothing]++-- | Variant on maybe which shrinks the size whenever it selects the 'Just'+-- option. When the size gets to five or less, the Just constructor is no longer+-- called, ensuring termination.+maybeRec :: Gen a -> Gen (Maybe a)+maybeRec gen = sized $+  \n ->+    if n <= 5+      then pure Nothing+      else+        Gen.frequency+          [ (2, pure Nothing)+          , (1 + fromIntegral n, Just <$> Gen.scale golden gen)+          ]++-- | Choose from a set of non-recursive generators and a set of recursive+-- generators, decreasing the size parameter whenever we pick one of the+-- recursive generators.+recursive :: ([Gen a] -> Gen a) -> [Gen a] -> [Gen a] -> Gen a+recursive f nonrec rec = sized $ \n ->+  if n <= 5+    then f nonrec+    else f $ nonrec ++ fmap (scale golden) rec++golden :: Int -> Int+golden x = round (fromIntegral x * 0.61803398875 :: Double)++scaleBy :: Int -> Int -> Int+scaleBy k x = round (fromIntegral x * ((1 :: Double) / fromIntegral k))++shrinkNE :: Arbitrary a => NE.NonEmpty a -> [NE.NonEmpty a]+shrinkNE (NE.toList -> l) = mapMaybe NE.nonEmpty (shrink l)++-- | Variant on 'listOf' that tries to constrain the ultimate size of the+-- generated tree by scaling recursive generators according to the size of the+-- generated list - that is, short lists will result in minimal size scaling,+-- whereas long lists will give significant scaling. Overall, the flattened size+-- should therefore remain roughly constant.+listOf' :: Gen a -> Gen [a]+listOf' f = do+  n <- getSize+  k <- choose (0, n)+  vectorOf k $ scale (scaleBy k) f
+ test/Test/Codec/CBOR/Cuddle/CDDL/Parser.hs view
@@ -0,0 +1,682 @@+{-# LANGUAGE OverloadedStrings #-}++module Test.Codec.CBOR.Cuddle.CDDL.Parser where++import Codec.CBOR.Cuddle.CDDL+import Codec.CBOR.Cuddle.CDDL.CtlOp qualified as CtlOp+import Codec.CBOR.Cuddle.Comments (Comment (..))+import Codec.CBOR.Cuddle.Parser+import Codec.CBOR.Cuddle.Parser.Lexer (Parser)+import Codec.CBOR.Cuddle.Pretty ()+import Data.Default.Class (Default (..))+import Data.List.NonEmpty (NonEmpty (..))+import Data.Text qualified as T+import Data.TreeDiff (ToExpr (..), ansiWlBgEditExprCompact, exprDiff)+import Prettyprinter (Pretty, defaultLayoutOptions, layoutPretty, pretty)+import Prettyprinter.Render.String (renderString)+import Prettyprinter.Render.Text (renderStrict)+import Test.Codec.CBOR.Cuddle.CDDL.Gen qualified as Gen ()+import Test.Hspec+import Test.Hspec.Megaparsec+import Test.QuickCheck+import Text.Megaparsec (MonadParsec (..), errorBundlePretty, parse)++parserSpec :: Spec+parserSpec = do+  valueSpec+  occurSpec+  nameSpec+  type1Spec+  type2Spec+  grpEntrySpec+  grpChoiceSpec+  genericSpec+  roundtripSpec+  qcFoundSpec++roundtripSpec :: Spec+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+  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+    -- 'CDDL' doc, since CDDL contains some statements that allow multiple+    -- parsings.+    trip :: forall a. (Eq a, ToExpr a, Show a, Pretty a, Arbitrary a) => Parser a -> Property+    trip pa = property $ \(x :: a) -> within 1000000 $ do+      let printed = printText x+      case parse (pa <* eof) "" printed of+        Left e ->+          counterexample (show printed) $+            counterexample (errorBundlePretty e) $+              property False+        Right parsed ->+          counterexample+            ( renderString . layoutPretty defaultLayoutOptions . ansiWlBgEditExprCompact $+                toExpr x `exprDiff` toExpr parsed+            )+            $ printed `shouldBe` printText parsed+    printText :: Pretty a => a -> T.Text+    printText = renderStrict . layoutPretty defaultLayoutOptions . pretty++valueSpec :: Spec+valueSpec = describe "pValue" $ do+  it "Parses integer" $+    parse pValue "" "123" `shouldParse` value (VUInt 123)+  it "Parses negative integer" $+    parse pValue "" "-123" `shouldParse` value (VNInt 123)+  it "Parses float" $+    parse pValue "" "3.1415" `shouldParse` value (VFloat64 3.1415)+  it "Parses text" $+    parse pValue "" "\"Hello World\"" `shouldParse` value (VText "Hello World")++occurSpec :: Spec+occurSpec = describe "pOccur" $ do+  it "Parses OneOrMore" $+    parse pOccur "" "+" `shouldParse` OIOneOrMore+  it "Parses ZeroOrMore" $+    parse pOccur "" "*" `shouldParse` OIZeroOrMore+  it "Parses Optional" $+    parse pOccur "" "?" `shouldParse` OIOptional+  it "Parses Lower Bounded" $+    parse pOccur "" "3*" `shouldParse` OIBounded (Just 3) Nothing+  it "Parses Upper Bounded" $+    parse pOccur "" "*9" `shouldParse` OIBounded Nothing (Just 9)+  it "Parses bounded on both sides" $+    parse pOccur "" "3*9" `shouldParse` OIBounded (Just 3) (Just 9)++-- it "result of parsing satisfies what it should" $+--   parse myParser "" "aaaa" `parseSatisfies` ((== 4) . length)++nameSpec :: SpecWith ()+nameSpec = describe "pName" $ do+  it "Parses a boring name" $+    parse pName "" "coin" `shouldParse` Name "coin" mempty+  it "Allows . in the middle" $+    parse pName "" "coin.me" `shouldParse` Name "coin.me" mempty+  it "Allows $ as the last character" $+    parse pName "" "coin.me$" `shouldParse` Name "coin.me$" mempty+  it "Doesn't allow . as a last character" $+    parse pName "" "coin." `shouldFailWith` err 5 ueof++genericSpec :: Spec+genericSpec = describe "generics" $ do+  it "Parses a simple value generic" $+    parse pRule "" "a = b<0>"+      `shouldParse` Rule+        (Name "a" mempty)+        Nothing+        AssignEq+        ( TOGType+            ( Type0+                ( Type1+                    ( T2Name+                        (Name "b" mempty)+                        ( Just+                            ( GenericArg+                                ( Type1+                                    (T2Value (value $ VUInt 0))+                                    Nothing+                                    mempty+                                    :| []+                                )+                            )+                        )+                    )+                    Nothing+                    mempty+                    :| []+                )+            )+        )+        mempty+  it "Parses a range as a generic" $+    parse pRule "" "a = b<0 ... 1>"+      `shouldParse` Rule+        (Name "a" mempty)+        Nothing+        AssignEq+        ( TOGType+            ( Type0+                ( Type1+                    ( T2Name+                        (Name "b" mempty)+                        ( Just+                            ( GenericArg+                                ( Type1+                                    (T2Value (value $ VUInt 0))+                                    (Just (RangeOp ClOpen, T2Value (value $ VUInt 1)))+                                    mempty+                                    :| []+                                )+                            )+                        )+                    )+                    Nothing+                    mempty+                    :| []+                )+            )+        )+        mempty++type2Spec :: SpecWith ()+type2Spec = describe "type2" $ do+  describe "Value" $ do+    it "Parses a value" $+      parse pType2 "" "123" `shouldParse` T2Value (value $ VUInt 123)+  describe "Map" $ do+    it "Parses a basic group" $+      parse pType2 "" "{ int => string }"+        `shouldParse` T2Map+          ( Group+              { unGroup =+                  GrpChoice+                    { gcGroupEntries =+                        [ GroupEntry+                            { geOccurrenceIndicator = Nothing+                            , geComment = Comment mempty+                            , geVariant =+                                GEType+                                  ( Just+                                      ( MKType+                                          ( Type1+                                              { t1Main = T2Name (Name {name = "int", nameComment = Comment mempty}) Nothing+                                              , t1TyOp = Nothing+                                              , t1Comment = Comment mempty+                                              }+                                          )+                                      )+                                  )+                                  ( Type0+                                      { t0Type1 =+                                          Type1+                                            { t1Main = T2Name (Name {name = "string", nameComment = Comment mempty}) Nothing+                                            , t1TyOp = Nothing+                                            , t1Comment = Comment mempty+                                            }+                                            :| []+                                      }+                                  )+                            }+                        ]+                    , gcComment = Comment mempty+                    }+                    :| []+              }+          )+    it "Parses a table" $+      parse pType2 "" "{ * int => string }"+        `shouldParse` T2Map+          ( Group+              { unGroup =+                  GrpChoice+                    { gcGroupEntries =+                        [ GroupEntry+                            { geOccurrenceIndicator = Just OIZeroOrMore+                            , geComment = Comment mempty+                            , geVariant =+                                GEType+                                  ( Just+                                      ( MKType+                                          ( Type1+                                              { t1Main = T2Name (Name {name = "int", nameComment = Comment mempty}) Nothing+                                              , t1TyOp = Nothing+                                              , t1Comment = Comment mempty+                                              }+                                          )+                                      )+                                  )+                                  ( Type0+                                      { t0Type1 =+                                          Type1+                                            { t1Main = T2Name (Name {name = "string", nameComment = Comment mempty}) Nothing+                                            , t1TyOp = Nothing+                                            , t1Comment = Comment mempty+                                            }+                                            :| []+                                      }+                                  )+                            }+                        ]+                    , gcComment = Comment mempty+                    }+                    :| []+              }+          )+    it "Commas are optional" $+      parse pType2 "" "{ 1 => string, 2 => int 3 => bytes}"+        `shouldParse` T2Map+          ( Group+              { unGroup =+                  GrpChoice+                    { gcGroupEntries =+                        [ GroupEntry+                            { geOccurrenceIndicator = Nothing+                            , geComment = Comment mempty+                            , geVariant =+                                GEType+                                  ( Just+                                      (MKType (Type1 {t1Main = T2Value (value $ VUInt 1), t1TyOp = Nothing, t1Comment = Comment mempty}))+                                  )+                                  ( Type0+                                      { t0Type1 =+                                          Type1+                                            { t1Main = T2Name (Name {name = "string", nameComment = Comment mempty}) Nothing+                                            , t1TyOp = Nothing+                                            , t1Comment = Comment mempty+                                            }+                                            :| []+                                      }+                                  )+                            }+                        , GroupEntry+                            { geOccurrenceIndicator = Nothing+                            , geComment = Comment mempty+                            , geVariant =+                                GEType+                                  ( Just+                                      (MKType (Type1 {t1Main = T2Value (value $ VUInt 2), t1TyOp = Nothing, t1Comment = Comment mempty}))+                                  )+                                  ( Type0+                                      { t0Type1 =+                                          Type1+                                            { t1Main = T2Name (Name {name = "int", nameComment = Comment mempty}) Nothing+                                            , t1TyOp = Nothing+                                            , t1Comment = Comment mempty+                                            }+                                            :| []+                                      }+                                  )+                            }+                        , GroupEntry+                            { geOccurrenceIndicator = Nothing+                            , geComment = Comment mempty+                            , geVariant =+                                GEType+                                  ( Just+                                      (MKType (Type1 {t1Main = T2Value (value $ VUInt 3), t1TyOp = Nothing, t1Comment = Comment mempty}))+                                  )+                                  ( Type0+                                      { t0Type1 =+                                          Type1+                                            { t1Main = T2Name (Name {name = "bytes", nameComment = Comment mempty}) Nothing+                                            , t1TyOp = Nothing+                                            , t1Comment = Comment mempty+                                            }+                                            :| []+                                      }+                                  )+                            }+                        ]+                    , gcComment = Comment mempty+                    }+                    :| []+              }+          )+  describe "Array" $ do+    it "Parses an array with an alternative" $+      parse pType2 "" "[int // string]"+        `shouldParse` T2Array+          ( Group+              { unGroup =+                  GrpChoice+                    { gcGroupEntries =+                        [ GroupEntry+                            { geOccurrenceIndicator = Nothing+                            , geComment = Comment mempty+                            , geVariant =+                                GEType+                                  Nothing+                                  ( Type0+                                      { t0Type1 =+                                          Type1+                                            { t1Main = T2Name (Name {name = "int", nameComment = Comment mempty}) Nothing+                                            , t1TyOp = Nothing+                                            , t1Comment = Comment mempty+                                            }+                                            :| []+                                      }+                                  )+                            }+                        ]+                    , gcComment = Comment mempty+                    }+                    :| [ GrpChoice+                           { gcGroupEntries =+                               [ GroupEntry+                                   { geOccurrenceIndicator = Nothing+                                   , geComment = Comment mempty+                                   , geVariant =+                                       GEType+                                         Nothing+                                         ( Type0+                                             { t0Type1 =+                                                 Type1+                                                   { t1Main = T2Name (Name {name = "string", nameComment = Comment mempty}) Nothing+                                                   , t1TyOp = Nothing+                                                   , t1Comment = Comment mempty+                                                   }+                                                   :| []+                                             }+                                         )+                                   }+                               ]+                           , gcComment = Comment mempty+                           }+                       ]+              }+          )++    it "Parses an array with a value alternative" $+      parse pType2 "" "[0 // 1]"+        `shouldParse` T2Array+          ( Group+              { unGroup =+                  GrpChoice+                    { gcGroupEntries =+                        [ GroupEntry+                            { geOccurrenceIndicator = Nothing+                            , geComment = Comment mempty+                            , geVariant =+                                GEType+                                  Nothing+                                  ( Type0+                                      { t0Type1 =+                                          Type1 {t1Main = T2Value (value $ VUInt 0), t1TyOp = Nothing, t1Comment = Comment mempty} :| []+                                      }+                                  )+                            }+                        ]+                    , gcComment = Comment mempty+                    }+                    :| [ GrpChoice+                           { gcGroupEntries =+                               [ GroupEntry+                                   { geOccurrenceIndicator = Nothing+                                   , geComment = Comment mempty+                                   , geVariant =+                                       GEType+                                         Nothing+                                         ( Type0+                                             { t0Type1 =+                                                 Type1 {t1Main = T2Value (value $ VUInt 1), t1TyOp = Nothing, t1Comment = Comment mempty} :| []+                                             }+                                         )+                                   }+                               ]+                           , gcComment = Comment mempty+                           }+                       ]+              }+          )+    it "Trailing commas permitted" $+      parse pType2 "" "[ 1 , ]"+        `shouldParse` T2Array+          ( Group+              { unGroup =+                  GrpChoice+                    { gcGroupEntries =+                        [ GroupEntry+                            { geOccurrenceIndicator = Nothing+                            , geComment = Comment mempty+                            , geVariant =+                                GEType+                                  Nothing+                                  ( Type0+                                      { t0Type1 =+                                          Type1 {t1Main = T2Value (value $ VUInt 1), t1TyOp = Nothing, t1Comment = Comment mempty} :| []+                                      }+                                  )+                            }+                        ]+                    , gcComment = Comment mempty+                    }+                    :| []+              }+          )+    it "Values don't need a space" $+      parse pType2 "" "[ 2soon ]"+        `shouldParse` T2Array+          ( Group+              { unGroup =+                  GrpChoice+                    { gcGroupEntries =+                        [ GroupEntry+                            { geOccurrenceIndicator = Nothing+                            , geComment = Comment mempty+                            , geVariant =+                                GEType+                                  Nothing+                                  ( Type0+                                      { t0Type1 =+                                          Type1 {t1Main = T2Value (value $ VUInt 2), t1TyOp = Nothing, t1Comment = Comment mempty} :| []+                                      }+                                  )+                            }+                        , GroupEntry+                            { geOccurrenceIndicator = Nothing+                            , geComment = Comment mempty+                            , geVariant =+                                GEType+                                  Nothing+                                  ( Type0+                                      { t0Type1 =+                                          Type1+                                            { t1Main = T2Name (Name {name = "soon", nameComment = Comment mempty}) Nothing+                                            , t1TyOp = Nothing+                                            , t1Comment = Comment mempty+                                            }+                                            :| []+                                      }+                                  )+                            }+                        ]+                    , gcComment = Comment mempty+                    }+                    :| []+              }+          )++grpEntrySpec :: SpecWith ()+grpEntrySpec = describe "GroupEntry" $ do+  it "Prefers GEType over GERef for names" $+    parse pGrpEntry "" "int"+      `shouldParse` GroupEntry+        { geOccurrenceIndicator = Nothing+        , geComment = Comment mempty+        , geVariant =+            GEType+              Nothing+              ( Type0+                  { t0Type1 =+                      Type1+                        { t1Main = T2Name (Name {name = "int", nameComment = Comment mempty}) Nothing+                        , t1TyOp = Nothing+                        , t1Comment = Comment mempty+                        }+                        :| []+                  }+              )+        }+  it "Should parse part of a group alternative" $+    parse pGrpEntry "" "int // notConsideredHere"+      `shouldParse` GroupEntry+        { geOccurrenceIndicator = Nothing+        , geComment = Comment mempty+        , geVariant =+            GEType+              Nothing+              ( Type0+                  { t0Type1 =+                      Type1+                        { t1Main = T2Name (Name {name = "int", nameComment = Comment mempty}) Nothing+                        , t1TyOp = Nothing+                        , t1Comment = Comment mempty+                        }+                        :| []+                  }+              )+        }+  it "Should parse a generic" $+    parse pGrpEntry "" "a<0 ... #6(0)>"+      `shouldParse` GroupEntry+        { geOccurrenceIndicator = Nothing+        , geComment = Comment mempty+        , geVariant =+            GEType+              Nothing+              ( Type0+                  { t0Type1 =+                      Type1+                        { t1Main =+                            T2Name+                              (Name {name = "a", nameComment = Comment mempty})+                              ( Just+                                  ( GenericArg+                                      ( Type1+                                          { t1Main = T2Value (value $ VUInt 0)+                                          , t1TyOp =+                                              Just+                                                ( RangeOp ClOpen+                                                , T2Tag+                                                    Nothing+                                                    ( Type0+                                                        { t0Type1 =+                                                            Type1 {t1Main = T2Value (value $ VUInt 0), t1TyOp = Nothing, t1Comment = Comment mempty} :| []+                                                        }+                                                    )+                                                )+                                          , t1Comment = Comment mempty+                                          }+                                          :| []+                                      )+                                  )+                              )+                        , t1TyOp = Nothing+                        , t1Comment = Comment mempty+                        }+                        :| []+                  }+              )+        }+  it "Parses a GEType with an Occurrence Indicator" $+    parse pGrpEntry "" "0* a"+      `shouldParse` GroupEntry+        (Just (OIBounded (Just 0) Nothing))+        def+        ( GEType+            Nothing+            (Type0 (Type1 (T2Name (Name "a" mempty) Nothing) Nothing 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+                      :| []+                  )+              )+        ]+        mempty++type1Spec :: Spec+type1Spec = describe "Type1" $ do+  describe "CtlOp" $ do+    it "Should parse a basic control operator" $+      parse pType1 "" "uint .size 3"+        `shouldParse` Type1+          (T2Name (Name "uint" mempty) Nothing)+          (Just (CtrlOp CtlOp.Size, T2Value (value $ VUInt 3)))+          mempty+  describe "RangeOp" $ do+    it "Should parse a closed range operator" $+      parse pType1 "" "0 .. 3"+        `shouldParse` Type1+          (T2Value (value $ VUInt 0))+          (Just (RangeOp Closed, T2Value (value $ VUInt 3)))+          mempty+    it "Should parse a clopen range operator" $+      parse pType1 "" "0 ... 3"+        `shouldParse` Type1+          (T2Value (value $ VUInt 0))+          (Just (RangeOp ClOpen, T2Value (value $ VUInt 3)))+          mempty++parseExample :: (Show a, Eq a) => T.Text -> Parser a -> a -> Spec+parseExample str parser val =+  it (T.unpack str) $+    parse (parser <* eof) "" str `shouldParse` val++-- | A bunch of cases found by hedgehog/QC+qcFoundSpec :: Spec+qcFoundSpec =+  describe "Generated test cases" $ do+    parseExample "{} .ge & i<{}, 3>" pType1 $+      Type1+        { t1Main =+            T2Map+              (Group {unGroup = GrpChoice {gcGroupEntries = [], gcComment = Comment mempty} :| []})+        , t1TyOp =+            Just+              ( CtrlOp CtlOp.Ge+              , T2EnumRef+                  (Name {name = "i", nameComment = Comment mempty})+                  ( Just+                      ( GenericArg+                          ( Type1+                              { t1Main =+                                  T2Map+                                    (Group {unGroup = GrpChoice {gcGroupEntries = [], gcComment = Comment mempty} :| []})+                              , t1TyOp = Nothing+                              , t1Comment = Comment mempty+                              }+                              :| [Type1 {t1Main = T2Value (value $ VUInt 3), t1TyOp = Nothing, t1Comment = Comment mempty}]+                          )+                      )+                  )+              )+        , t1Comment = Comment mempty+        }+    parseExample "S = 0* ()" pRule $+      Rule+        (Name "S" mempty)+        Nothing+        AssignEq+        ( TOGGroup+            ( GroupEntry (Just (OIBounded (Just 0) Nothing)) mempty $+                GEGroup (Group (GrpChoice mempty mempty :| []))+            )+        )+        mempty+    parseExample+      "W = \"6 ybe2ddl8frq0vqa8zgrk07khrljq7p plrufpd1sff3p95\" : \"u\""+      pRule+      ( Rule+          (Name "W" mempty)+          Nothing+          AssignEq+          ( TOGGroup+              ( GroupEntry+                  Nothing+                  mempty+                  $ GEType+                    (Just (MKValue (value $ VText "6 ybe2ddl8frq0vqa8zgrk07khrljq7p plrufpd1sff3p95")))+                    (Type0 (Type1 (T2Value (value $ VText "u")) Nothing mempty :| []))+              )+          )+          mempty+      )
+ test/Test/Codec/CBOR/Cuddle/CDDL/Pretty.hs view
@@ -0,0 +1,187 @@+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE NoImplicitPrelude #-}++module Test.Codec.CBOR.Cuddle.CDDL.Pretty (+  spec,+) where++import Codec.CBOR.Cuddle.CDDL (+  Assign (..),+  CDDL,+  Group (Group),+  GroupEntry (..),+  GroupEntryVariant (..),+  GrpChoice (..),+  Name (..),+  Rule (..),+  Type0 (..),+  Type1 (..),+  Type2 (..),+  TypeOrGroup (..),+  ValueVariant (..),+  value,+ )+import Codec.CBOR.Cuddle.Pretty ()+import Data.List.NonEmpty (NonEmpty (..))+import Data.Text qualified as T+import Data.TreeDiff (ToExpr (..), prettyExpr)+import Prettyprinter (Pretty (..), defaultLayoutOptions, layoutPretty)+import Prettyprinter.Render.String (renderString)+import Test.Codec.CBOR.Cuddle.CDDL.Gen ()+import Test.HUnit (assertEqual)+import Test.Hspec (Expectation, Spec, describe, it, shouldBe, xit)+import Test.Hspec.QuickCheck (xprop)+import Test.QuickCheck (counterexample)+import Prelude hiding ((/))++prettyPrintsTo :: (Pretty a, ToExpr a) => a -> String -> Expectation+prettyPrintsTo x s = assertEqual (show . prettyExpr $ toExpr x) s rendered+  where+    rendered = renderString (layoutPretty defaultLayoutOptions (pretty x))++t2Name :: Type2+t2Name = T2Name (Name "a" mempty) mempty++t1Name :: Type1+t1Name = Type1 t2Name Nothing mempty++mkType0 :: Type2 -> Type0+mkType0 t2 = Type0 $ Type1 t2 Nothing mempty :| []++spec :: Spec+spec = describe "Pretty printer" $ do+  unitSpec+  qcSpec++qcSpec :: Spec+qcSpec = describe "QuickCheck" $ do+  xprop "CDDL prettyprinter leaves no trailing spaces" $ \(cddl :: CDDL) -> 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+    "drep"+    Nothing+    AssignEq+    ( TOGType+        ( Type0+            ( Type1+                ( T2Array+                    ( Group+                        ( GrpChoice+                            [ GroupEntry+                                Nothing+                                mempty+                                (GEType Nothing (Type0 $ Type1 (T2Value . value $ VUInt 0) Nothing mempty :| []))+                            , GroupEntry+                                Nothing+                                mempty+                                (GEType Nothing (Type0 $ Type1 (T2Name "addr_keyhash" Nothing) Nothing mempty :| []))+                            ]+                            mempty+                            :| [ GrpChoice+                                   [ GroupEntry+                                       Nothing+                                       mempty+                                       (GEType Nothing (Type0 $ Type1 (T2Value . value $ VUInt 1) Nothing mempty :| []))+                                   , GroupEntry+                                       Nothing+                                       mempty+                                       (GEType Nothing (Type0 $ Type1 (T2Name "script_hash" Nothing) Nothing mempty :| []))+                                   ]+                                   mempty+                               , GrpChoice+                                   [ GroupEntry+                                       Nothing+                                       mempty+                                       (GEType Nothing (Type0 $ Type1 (T2Value . value $ VUInt 2) Nothing mempty :| []))+                                   ]+                                   mempty+                               , GrpChoice+                                   [ GroupEntry+                                       Nothing+                                       mempty+                                       (GEType Nothing (Type0 $ Type1 (T2Value . value $ VUInt 3) Nothing mempty :| []))+                                   ]+                                   mempty+                               ]+                        )+                    )+                )+                Nothing+                mempty+                :| []+            )+        )+    )+    mempty++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]"
+ test/Test/Codec/CBOR/Cuddle/Huddle.hs view
@@ -0,0 +1,164 @@+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE OverloadedStrings #-}++{- HLINT ignore "Redundant bracket" -}++module Test.Codec.CBOR.Cuddle.Huddle where++import Codec.CBOR.Cuddle.CDDL (CDDL, sortCDDL)+import Codec.CBOR.Cuddle.Huddle+import Codec.CBOR.Cuddle.Parser+import Data.Text qualified as T+import Test.Codec.CBOR.Cuddle.CDDL.Pretty qualified as Pretty+import Test.Hspec+import Test.Hspec.Megaparsec+import Text.Megaparsec+import Prelude hiding ((/))++huddleSpec :: Spec+huddleSpec = describe "huddle" $ do+  basicAssign+  arraySpec+  mapSpec+  grpSpec+  nestedSpec+  genericSpec+  constraintSpec+  Pretty.spec++basicAssign :: Spec+basicAssign = describe "basic assignment" $ do+  it "Can assign a primitive" $+    toSortedCDDL ["port" =:= VUInt]+      `shouldMatchParseCDDL` "port = uint"+  it "Can assign an int" $+    toSortedCDDL ["one" =:= (int 1)]+      `shouldMatchParseCDDL` "one = 1"+  -- it "Can assign a float" $+  --   toSortedCDDL ["onepointone" =:= (1.1 :: Float)]+  --     `shouldMatchParseCDDL` "onepointone = 1.1"+  it "Can assign a text string" $+    toSortedCDDL ["hello" =:= ("Hello World" :: T.Text)]+      `shouldMatchParseCDDL` "hello = \"Hello World\""+  it "Can handle multiple assignments" $+    toSortedCDDL ["age" =:= VUInt, "location" =:= VText]+      `shouldMatchParseCDDL` "age = uint\n location = text"++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 ]"+  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 ]"+  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 (int 1)+            , a ("Hello" :: T.Text)+            ]+      ]+      `shouldMatchParseCDDL` "asl = [ uint, bool, text // 1, \"Hello\" ]"++mapSpec :: Spec+mapSpec = describe "Maps" $ do+  it "Can assign a small map" $+    toSortedCDDL ["asl" =:= mp ["age" ==> VUInt, "sex" ==> VBool, "location" ==> VText]]+      `shouldMatchParseCDDL` "asl = { age : uint, sex : bool, location : text }"+  it "Can quantify a lower bound" $+    toSortedCDDL ["age" =:= mp [0 <+ "years" ==> VUInt]]+      `shouldMatchParseCDDL` "age = { * years : uint }"+  it "Can quantify an upper bound" $+    toSortedCDDL ["age" =:= mp ["years" ==> VUInt +> 64]]+      `shouldMatchParseCDDL` "age = { *64 years : uint }"+  it "Can handle a choice" $+    toSortedCDDL ["ageOrSex" =:= mp ["age" ==> VUInt] / mp ["sex" ==> VBool]]+      `shouldMatchParseCDDL` "ageOrSex = { age : uint // sex : bool }"+  it "Can handle a choice with an entry" $+    toSortedCDDL ["mir" =:= arr [a (int 0 / int 1), a $ mp [0 <+ "test" ==> VUInt]]]+      `shouldMatchParseCDDL` "mir = [ 0 / 1, { * test : uint }]"++grpSpec :: Spec+grpSpec = describe "Groups" $ do+  it "Can handle a choice in a group entry" $+    let g1 = "g1" =:~ grp [a (VUInt / VBytes), a VUInt]+     in toSortedCDDL (collectFrom [HIRule $ "a1" =:= arr [a g1]])+          `shouldMatchParseCDDL` "a1 = [g1]\n g1 = ( uint / bytes, uint )"+  it "Can handle keys in a group entry" $+    let g1 = "g1" =:~ grp ["bytes" ==> VBytes]+     in toSortedCDDL (collectFrom [HIRule $ "a1" =:= arr [a g1]])+          `shouldMatchParseCDDL` "a1 = [g1]\n g1 = (bytes : bytes)"++-- it "Can handle a group in a map" $+--   let g1 = "g1" =:~ grp ["bytes"==> VBytes]+--   in toSortedCDDL (collectFrom ["a1" =:= mp [g1]])+--     `shouldMatchParseCDDL` "a1 = [g1]\n g1 = (bytes : bytes)"++nestedSpec :: Spec+nestedSpec =+  describe "Nesting" $+    it "Handles references" $+      let headerBody = "header_body" =:= arr ["block_number" ==> VUInt, "slot" ==> VUInt]+       in toSortedCDDL+            [ headerBody+            , "header" =:= arr [a headerBody, "body_signature" ==> VBytes]+            ]+            `shouldMatchParseCDDL` "header = [header_body, body_signature : bytes]\n header_body = [block_number : uint, slot : uint]"++genericSpec :: Spec+genericSpec =+  describe "Generics" $+    let set :: IsType0 t0 => t0 -> GRuleCall+        set = binding $ \x -> "set" =:= arr [0 <+ a x]++        dict :: (IsType0 t0, IsType0 t1) => t0 -> t1 -> GRuleCall+        dict = binding2 $ \k v -> "dict" =:= mp [0 <+ asKey k ==> v]+     in do+          it "Should bind a single parameter" $+            toSortedCDDL (collectFrom [HIRule $ "intset" =:= set VUInt])+              `shouldMatchParseCDDL` "intset = set<uint>\n set<a0> = [* a0]"+          it "Should bind two parameters" $+            toSortedCDDL (collectFrom [HIRule $ "mymap" =:= dict VUInt VText])+              `shouldMatchParseCDDL` "dict<a0, b0> = {* a0 => b0}\n mymap = dict<uint, text>"++constraintSpec :: Spec+constraintSpec =+  describe "Constraints" $ do+    it "Size can take a Word" $+      toSortedCDDL (collectFrom [HIRule $ "sz" =:= VUInt `sized` (2 :: Word)])+        `shouldMatchParseCDDL` "sz = uint .size 2"++    it "Range bound can take a reference" $+      let b = "b" =:= (16 :: Integer)+       in toSortedCDDL (collectFrom [HIRule $ "b" =:= (16 :: Integer), HIRule $ "c" =:= int 0 ... b])+            `shouldMatchParseCDDL` "b = 16\n c = 0 .. b"++--------------------------------------------------------------------------------+-- Helper functions+--------------------------------------------------------------------------------++shouldMatchParse ::+  (Text.Megaparsec.ShowErrorComponent e, Show a, Eq a) =>+  a ->+  Text.Megaparsec.Parsec e T.Text a ->+  String ->+  Expectation+shouldMatchParse x parseFun input = parse parseFun "" (T.pack input) `shouldParse` x++shouldMatchParseCDDL ::+  CDDL ->+  String ->+  Expectation+shouldMatchParseCDDL x = shouldMatchParse x pCDDL++toSortedCDDL :: Huddle -> CDDL+toSortedCDDL = sortCDDL . toCDDLNoRoot