diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -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. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/bin/Main.hs b/bin/Main.hs new file mode 100644 --- /dev/null +++ b/bin/Main.hs @@ -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 diff --git a/cuddle.cabal b/cuddle.cabal new file mode 100644 --- /dev/null +++ b/cuddle.cabal @@ -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, diff --git a/example/Conway.hs b/example/Conway.hs new file mode 100644 --- /dev/null +++ b/example/Conway.hs @@ -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)) diff --git a/example/Main.hs b/example/Main.hs new file mode 100644 --- /dev/null +++ b/example/Main.hs @@ -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 diff --git a/example/Monad.hs b/example/Monad.hs new file mode 100644 --- /dev/null +++ b/example/Monad.hs @@ -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 () + ) diff --git a/src/Codec/CBOR/Cuddle/CBOR/Gen.hs b/src/Codec/CBOR/Cuddle/CBOR/Gen.hs new file mode 100644 --- /dev/null +++ b/src/Codec/CBOR/Cuddle/CBOR/Gen.hs @@ -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 diff --git a/src/Codec/CBOR/Cuddle/CBOR/Validator.hs b/src/Codec/CBOR/Cuddle/CBOR/Validator.hs new file mode 100644 --- /dev/null +++ b/src/Codec/CBOR/Cuddle/CBOR/Validator.hs @@ -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 = + 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 = (<) diff --git a/src/Codec/CBOR/Cuddle/CDDL.hs b/src/Codec/CBOR/Cuddle/CDDL.hs new file mode 100644 --- /dev/null +++ b/src/Codec/CBOR/Cuddle/CDDL.hs @@ -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 = {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) diff --git a/src/Codec/CBOR/Cuddle/CDDL/CTree.hs b/src/Codec/CBOR/Cuddle/CDDL/CTree.hs new file mode 100644 --- /dev/null +++ b/src/Codec/CBOR/Cuddle/CDDL/CTree.hs @@ -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) diff --git a/src/Codec/CBOR/Cuddle/CDDL/CtlOp.hs b/src/Codec/CBOR/Cuddle/CDDL/CtlOp.hs new file mode 100644 --- /dev/null +++ b/src/Codec/CBOR/Cuddle/CDDL/CtlOp.hs @@ -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 diff --git a/src/Codec/CBOR/Cuddle/CDDL/Postlude.hs b/src/Codec/CBOR/Cuddle/CDDL/Postlude.hs new file mode 100644 --- /dev/null +++ b/src/Codec/CBOR/Cuddle/CDDL/Postlude.hs @@ -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 diff --git a/src/Codec/CBOR/Cuddle/CDDL/Prelude.hs b/src/Codec/CBOR/Cuddle/CDDL/Prelude.hs new file mode 100644 --- /dev/null +++ b/src/Codec/CBOR/Cuddle/CDDL/Prelude.hs @@ -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 + "" + " any = # \ + \ uint = #0 \ + \ nint = #1 \ + \ int = uint / nint \ + \ \ + \ bstr = #2 \ + \ bytes = bstr \ + \ tstr = #3 \ + \ text = tstr \ + \ \ + \ tdate = #6.0(tstr) \ + \ time = #6.1(number) \ + \ number = int / float \ + \ biguint = #6.2(bstr) \ + \ bignint = #6.3(bstr) \ + \ bigint = biguint / bignint \ + \ integer = int / bigint \ + \ unsigned = uint / biguint \ + \ decfrac = #6.4([e10: int, m: integer]) \ + \ bigfloat = #6.5([e2: int, m: integer]) \ + \ eb64url = #6.21(any) \ + \ eb64legacy = #6.22(any) \ + \ eb16 = #6.23(any) \ + \ encoded-cbor = #6.24(bstr) \ + \ uri = #6.32(tstr) \ + \ b64url = #6.33(tstr) \ + \ b64legacy = #6.34(tstr) \ + \ regexp = #6.35(tstr) \ + \ mime-message = #6.36(tstr) \ + \ cbor-any = #6.55799(any) \ + \ float16 = #7.25 \ + \ float32 = #7.26 \ + \ float64 = #7.27 \ + \ float16-32 = float16 / float32 \ + \ float32-64 = float32 / float64 \ + \ float = float16-32 / float64 \ + \ \ + \ false = #7.20 \ + \ true = #7.21 \ + \ bool = false / true \ + \ nil = #7.22 \ + \ null = nil \ + \ undefined = #7.23" + +prependPrelude :: CDDL -> CDDL +prependPrelude = (cddlPrelude <>) diff --git a/src/Codec/CBOR/Cuddle/CDDL/Resolve.hs b/src/Codec/CBOR/Cuddle/CDDL/Resolve.hs new file mode 100644 --- /dev/null +++ b/src/Codec/CBOR/Cuddle/CDDL/Resolve.hs @@ -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 diff --git a/src/Codec/CBOR/Cuddle/Comments.hs b/src/Codec/CBOR/Cuddle/Comments.hs new file mode 100644 --- /dev/null +++ b/src/Codec/CBOR/Cuddle/Comments.hs @@ -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 diff --git a/src/Codec/CBOR/Cuddle/Huddle.hs b/src/Codec/CBOR/Cuddle/Huddle.hs new file mode 100644 --- /dev/null +++ b/src/Codec/CBOR/Cuddle/Huddle.hs @@ -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) diff --git a/src/Codec/CBOR/Cuddle/Huddle/HuddleM.hs b/src/Codec/CBOR/Cuddle/Huddle/HuddleM.hs new file mode 100644 --- /dev/null +++ b/src/Codec/CBOR/Cuddle/Huddle/HuddleM.hs @@ -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" diff --git a/src/Codec/CBOR/Cuddle/Huddle/Optics.hs b/src/Codec/CBOR/Cuddle/Huddle/Optics.hs new file mode 100644 --- /dev/null +++ b/src/Codec/CBOR/Cuddle/Huddle/Optics.hs @@ -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" diff --git a/src/Codec/CBOR/Cuddle/Parser.hs b/src/Codec/CBOR/Cuddle/Parser.hs new file mode 100644 --- /dev/null +++ b/src/Codec/CBOR/Cuddle/Parser.hs @@ -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)) diff --git a/src/Codec/CBOR/Cuddle/Parser/Lexer.hs b/src/Codec/CBOR/Cuddle/Parser/Lexer.hs new file mode 100644 --- /dev/null +++ b/src/Codec/CBOR/Cuddle/Parser/Lexer.hs @@ -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) diff --git a/src/Codec/CBOR/Cuddle/Pretty.hs b/src/Codec/CBOR/Cuddle/Pretty.hs new file mode 100644 --- /dev/null +++ b/src/Codec/CBOR/Cuddle/Pretty.hs @@ -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" diff --git a/src/Codec/CBOR/Cuddle/Pretty/Columnar.hs b/src/Codec/CBOR/Cuddle/Pretty/Columnar.hs new file mode 100644 --- /dev/null +++ b/src/Codec/CBOR/Cuddle/Pretty/Columnar.hs @@ -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 diff --git a/src/Codec/CBOR/Cuddle/Pretty/Utils.hs b/src/Codec/CBOR/Cuddle/Pretty/Utils.hs new file mode 100644 --- /dev/null +++ b/src/Codec/CBOR/Cuddle/Pretty/Utils.hs @@ -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) diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -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 diff --git a/test/Test/Codec/CBOR/Cuddle/CDDL/Examples.hs b/test/Test/Codec/CBOR/Cuddle/CDDL/Examples.hs new file mode 100644 --- /dev/null +++ b/test/Test/Codec/CBOR/Cuddle/CDDL/Examples.hs @@ -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" diff --git a/test/Test/Codec/CBOR/Cuddle/CDDL/Gen.hs b/test/Test/Codec/CBOR/Cuddle/CDDL/Gen.hs new file mode 100644 --- /dev/null +++ b/test/Test/Codec/CBOR/Cuddle/CDDL/Gen.hs @@ -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 diff --git a/test/Test/Codec/CBOR/Cuddle/CDDL/Parser.hs b/test/Test/Codec/CBOR/Cuddle/CDDL/Parser.hs new file mode 100644 --- /dev/null +++ b/test/Test/Codec/CBOR/Cuddle/CDDL/Parser.hs @@ -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 + ) diff --git a/test/Test/Codec/CBOR/Cuddle/CDDL/Pretty.hs b/test/Test/Codec/CBOR/Cuddle/CDDL/Pretty.hs new file mode 100644 --- /dev/null +++ b/test/Test/Codec/CBOR/Cuddle/CDDL/Pretty.hs @@ -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]" diff --git a/test/Test/Codec/CBOR/Cuddle/Huddle.hs b/test/Test/Codec/CBOR/Cuddle/Huddle.hs new file mode 100644 --- /dev/null +++ b/test/Test/Codec/CBOR/Cuddle/Huddle.hs @@ -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\n set = [* a0]" + it "Should bind two parameters" $ + toSortedCDDL (collectFrom [HIRule $ "mymap" =:= dict VUInt VText]) + `shouldMatchParseCDDL` "dict = {* a0 => b0}\n mymap = dict" + +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