summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorJoachimBreitner <>2020-11-21 19:03:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2020-11-21 19:03:00 (GMT)
commite828aa7942d4b7274ba0fd733cc5df8662bcb644 (patch)
treeef114bc8fa8bcb335c9fcfc4d7e9d9a058259067
version 0.1HEAD0.1master
-rwxr-xr-xCHANGELOG.md5
-rw-r--r--LICENSE208
-rw-r--r--Setup.hs2
-rw-r--r--candid.cabal121
-rw-r--r--doctests.hs2
-rw-r--r--hcandid.hs67
-rw-r--r--src/Codec/Candid.hs386
-rw-r--r--src/Codec/Candid/Class.hs506
-rw-r--r--src/Codec/Candid/Data.hs42
-rw-r--r--src/Codec/Candid/Decode.hs155
-rw-r--r--src/Codec/Candid/Encode.hs191
-rw-r--r--src/Codec/Candid/EncodeTextual.hs16
-rw-r--r--src/Codec/Candid/FieldName.hs87
-rw-r--r--src/Codec/Candid/Generic.hs49
-rw-r--r--src/Codec/Candid/Infer.hs101
-rw-r--r--src/Codec/Candid/Parse.hs396
-rw-r--r--src/Codec/Candid/Service.hs74
-rw-r--r--src/Codec/Candid/TH.hs156
-rw-r--r--src/Codec/Candid/TestExports.hs23
-rw-r--r--src/Codec/Candid/Tuples.hs56
-rw-r--r--src/Codec/Candid/TypTable.hs74
-rw-r--r--src/Codec/Candid/Types.hs268
-rw-r--r--test/SpecTests.hs100
-rw-r--r--test/THTests.hs51
-rw-r--r--test/test.hs400
25 files changed, 3536 insertions, 0 deletions
diff --git a/CHANGELOG.md b/CHANGELOG.md
new file mode 100755
index 0000000..03126f9
--- /dev/null
+++ b/CHANGELOG.md
@@ -0,0 +1,5 @@
+# Revision history for haskell-candid
+
+## 0.1 -- 2020-11-21
+
+* First version.
diff --git a/LICENSE b/LICENSE
new file mode 100644
index 0000000..d5dadbd
--- /dev/null
+++ b/LICENSE
@@ -0,0 +1,208 @@
+ 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
+
+LLVM EXCEPTIONS TO THE APACHE 2.0 LICENSE
+
+As an exception, if, as a result of your compiling your source code, portions
+of this Software are embedded into an Object form of such source code, you may
+redistribute such embedded portions in such Object form without complying with
+the conditions of Sections 4(a), 4(b) and 4(d) of the License.
+
+In addition, if you combine or link compiled forms of this Software with
+software that is licensed under the GPLv2 ("Combined Software") and if a court
+of competent jurisdiction determines that the patent provision (Section 3), the
+indemnity provision (Section 9) or other Section of the License conflicts with
+the conditions of the GPLv2, you may retroactively and prospectively choose to
+deem waived or otherwise exclude such Section(s) of the License, but only in
+their entirety and only with respect to the Combined Software.
+
+END OF LLVM EXCEPTIONS
+
+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.
+
+END OF APPENDIX
diff --git a/Setup.hs b/Setup.hs
new file mode 100644
index 0000000..9a994af
--- /dev/null
+++ b/Setup.hs
@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain
diff --git a/candid.cabal b/candid.cabal
new file mode 100644
index 0000000..659325f
--- /dev/null
+++ b/candid.cabal
@@ -0,0 +1,121 @@
+cabal-version: >=1.10
+name: candid
+version: 0.1
+license: Apache
+license-file: LICENSE
+maintainer: mail@joachim-breitner.de
+author: Joachim Breitner
+homepage: https://github.com/dfinity/candid
+synopsis: Candid integration
+description:
+ This package brings the Candid interface definition language to Haskell,
+ supporting serialization, deserialization, importing type definition and
+ other features.
+ .
+ See "Codec.Candid" for an overview and <https://github.com/dfinity/candid> to
+ learn more about Candid.
+
+category: Codec
+build-type: Simple
+extra-source-files: CHANGELOG.md
+
+library
+ exposed-modules:
+ Codec.Candid
+ Codec.Candid.Tuples
+ Codec.Candid.TestExports
+
+ hs-source-dirs: src
+ other-modules:
+ Codec.Candid.Parse
+ Codec.Candid.Class
+ Codec.Candid.Generic
+ Codec.Candid.Service
+ Codec.Candid.TH
+ Codec.Candid.Data
+ Codec.Candid.Types
+ Codec.Candid.FieldName
+ Codec.Candid.TypTable
+ Codec.Candid.Decode
+ Codec.Candid.EncodeTextual
+ Codec.Candid.Encode
+ Codec.Candid.Infer
+
+ default-language: Haskell2010
+ ghc-options: -Wall -Wno-name-shadowing
+ build-depends:
+ base >=4.12 && <5,
+ text >=1.2.3.1 && <1.3,
+ dlist >=0.8.0.8 && <1.1,
+ vector >=0.12.1.2 && <0.13,
+ bytestring >=0.10.8.2 && <0.11,
+ mtl >=2.2.2 && <2.3,
+ transformers >=0.5.6.2 && <0.6,
+ hex-text >=0.1.0.0 && <0.2,
+ crc >=0.1.0.0 && <0.2,
+ megaparsec >=8 && <9.1,
+ scientific >=0.3.6.2 && <0.4,
+ cereal >=0.5.8.1 && <0.6,
+ leb128-cereal ==1.2.*,
+ containers >=0.6.0.1 && <0.7,
+ unordered-containers >=0.2.10.0 && <0.3,
+ row-types ==0.4.*,
+ constraints ==0.12.*,
+ prettyprinter >=1.6.2 && <1.8,
+ template-haskell >=2.14.0.0 && <2.17,
+ base32 >=0.1.1.2 && <0.3,
+ split >=0.2.3.4 && <0.3
+
+executable hcandid
+ main-is: hcandid.hs
+ default-language: Haskell2010
+ ghc-options: -Wall -Wno-name-shadowing
+ build-depends:
+ base ==4.*,
+ candid -any,
+ optparse-applicative >=0.15.1.0 && <0.17,
+ text >=1.2.3.1 && <1.3,
+ bytestring >=0.10.8.2 && <0.11,
+ hex-text >=0.1.0.0 && <0.2,
+ prettyprinter >=1.6.2 && <1.8
+
+test-suite test
+ type: exitcode-stdio-1.0
+ main-is: test.hs
+ hs-source-dirs: test
+ other-modules:
+ SpecTests
+ THTests
+
+ default-language: Haskell2010
+ ghc-options: -Wall -Wno-name-shadowing -rtsopts
+ build-depends:
+ base ==4.*,
+ tasty >=0.7 && <1.5,
+ tasty-hunit >=0.10.0.2 && <0.11,
+ tasty-smallcheck >=0.8.1 && <0.9,
+ tasty-rerun >=1.1.17 && <1.2,
+ smallcheck >=1.1.7 && <1.2,
+ candid -any,
+ bytestring >=0.10.8.2 && <0.11,
+ text >=1.2.3.1 && <1.3,
+ vector >=0.12.1.2 && <0.13,
+ prettyprinter >=1.6.2 && <1.8,
+ unordered-containers >=0.2.10.0 && <0.3,
+ row-types ==0.4.*,
+ directory >=1.3.3.0 && <1.4,
+ filepath >=1.4.2.1 && <1.5,
+ template-haskell >=2.14.0.0 && <2.17
+
+test-suite doctest
+ type: exitcode-stdio-1.0
+ main-is: doctests.hs
+ default-language: Haskell2010
+ ghc-options: -threaded
+ build-depends:
+ base >=4.12.0.0 && <4.15,
+ candid -any,
+ doctest >=0.8 && <0.18,
+ row-types ==0.4.*,
+ leb128-cereal ==1.2.*,
+ prettyprinter >=1.6.2 && <1.8
diff --git a/doctests.hs b/doctests.hs
new file mode 100644
index 0000000..d67d2b1
--- /dev/null
+++ b/doctests.hs
@@ -0,0 +1,2 @@
+import Test.DocTest
+main = doctest ["-isrc", "src/Codec/Candid.hs", "--fast"]
diff --git a/hcandid.hs b/hcandid.hs
new file mode 100644
index 0000000..add67a5
--- /dev/null
+++ b/hcandid.hs
@@ -0,0 +1,67 @@
+{-# LANGUAGE OverloadedStrings #-}
+import qualified Data.ByteString.Builder as BS
+import qualified Data.ByteString.Lazy as BS
+import qualified Data.Text as T
+import qualified Text.Hex as T
+import Options.Applicative
+import Control.Monad
+import Codec.Candid
+import Data.Char
+import System.IO
+import System.Exit
+import Data.Text.Prettyprint.Doc
+import Data.Text.Prettyprint.Doc.Util
+
+err :: String -> IO b
+err s = hPutStr stderr s >> exitFailure
+
+fromHex :: String -> IO BS.ByteString
+fromHex = maybe (err "Invalid hex data") (return . BS.fromStrict) . T.decodeHex . T.pack . filter (not . isSpace)
+
+fromRust :: String -> IO BS.ByteString
+fromRust = go
+ where
+ go :: String -> IO BS.ByteString
+ go "" = return mempty
+ go ('\\':'x':h1:h2:xs)
+ | Just b <- T.decodeHex (T.pack [h1,h2])
+ = (BS.fromStrict b <>) <$> go xs
+ go ('\\':c:xs)
+ | ord c <= 0xff
+ = (BS.singleton (fromIntegral (ord c)) <>) <$> go xs
+ go (c:xs)
+ | ord c <= 0xff
+ = (BS.singleton (fromIntegral (ord c)) <>) <$> go xs
+ go xs = err $ "Stuck parsing rust string at\n" <> xs
+
+decodeCandid :: BS.ByteString -> IO ()
+decodeCandid b = case decodeVals b of
+ Left msg -> err msg
+ Right vs -> putDocW 80 (pretty vs) >> putStrLn ""
+
+encodeCandid :: String -> IO ()
+encodeCandid txt = case parseValues txt of
+ Left msg -> err msg
+ Right vs -> case encodeDynValues vs of
+ Left msg -> err msg
+ Right b -> BS.putStr (BS.toLazyByteString b)
+
+main :: IO ()
+main = join . customExecParser (prefs showHelpOnError) $
+ info (helper <*> parser)
+ ( fullDesc
+ <> header "Candid tooling"
+ -- <> progDesc "A stand-alone local reference implementation of the Internet Computer"
+ )
+ where
+ parser :: Parser (IO ())
+ parser =
+ (decodeCandid =<<) <$> (
+ flag' () (long "decode" <> help "Decode bytes to Candid")
+ *> (
+ fromHex <$> strOption (long "hex" <> help "parse hex data")
+ <|> fromRust <$> strOption (long "rust" <> help "parse text with \\xFF escapes")
+ <|> flag' BS.getContents (long "stdin" <> help "read data from stdin")
+ )
+ ) <|>
+ encodeCandid <$> strOption (long "encode" <> help "encode Candid textual form, at inferred type)")
diff --git a/src/Codec/Candid.hs b/src/Codec/Candid.hs
new file mode 100644
index 0000000..ff8ea46
--- /dev/null
+++ b/src/Codec/Candid.hs
@@ -0,0 +1,386 @@
+{-|
+
+This module provides preliminary Haskell supprot for decoding and encoding the __Candid__ data format. See <https://github.com/dfinity/candid/blob/master/spec/Candid.md> for the official Candid specification.
+
+__Warning:__ The interface of this library is still in flux, as we are yet learning the best idioms around Candid and Haskell.
+
+-}
+
+{-# LANGUAGE CPP #-}
+
+module Codec.Candid
+ (
+-- * Tutorial
+
+{- |
+
+Candid is inherently typed, so before encoding or decoding, you have to indicate the types to use. In most cases, you can use Haskell types for that:
+
+-}
+
+-- ** Haskell types
+
+-- $haskell_types
+
+-- ** Custom types
+
+-- $own_type
+
+-- ** Generic types
+
+-- $generic
+
+-- ** Candid services
+
+-- $services
+
+-- ** Importing Candid
+
+-- $import
+-- $import2
+-- $import3
+
+-- ** Dynamic use
+
+-- $dynamic
+
+-- ** Missing features
+
+{- |
+
+* Generating interface descriptions (.did files) from Haskell functions
+* Service and function types
+* Future types
+* Parsing the textual representation dynamically against an expected type
+* Method annotations in service types
+
+-}
+
+-- * Reference
+
+-- ** Encoding and decoding
+
+ encode
+ , encodeBuilder
+ , decode
+
+-- ** Type classes
+
+ , Candid(..)
+ , CandidRow
+ , CandidArg
+ , CandidVal
+ , seqDesc
+ , SeqDesc
+ , tieKnot
+ , typeDesc
+
+ -- ** Special types
+
+ , Unary(..)
+ , Principal(..)
+ , prettyPrincipal
+ , parsePrincipal
+ , Reserved(..)
+
+-- ** Generics
+
+ , AsRecord(..)
+ , AsVariant(..)
+
+-- ** Candid services
+
+ , CandidService
+ , RawService
+ , toCandidService
+ , fromCandidService
+
+-- ** Meta-programming
+
+ , candid
+ , candidFile
+ , candidType
+
+-- ** Types and values
+
+ , Type(..)
+ , Fields
+ , FieldName
+ , labledField
+ , hashedField
+ , fieldHash
+ , escapeFieldName
+ , unescapeFieldName
+ , candidHash
+ , Value(..)
+
+-- ** Dynamic use
+
+ , decodeVals
+ , fromCandidVals
+ , toCandidVals
+ , encodeDynValues
+ , encodeTextual
+ , DidFile
+ , parseDid
+ , parseValue
+ , parseValues
+
+-- Convenience re-exports
+-- not useful due to https://github.com/haskell/haddock/issues/698#issuecomment-632328837
+-- , Generic
+
+ ) where
+
+import Codec.Candid.Data
+import Codec.Candid.Types
+import Codec.Candid.FieldName
+import Codec.Candid.Tuples
+import Codec.Candid.Class
+import Codec.Candid.Generic
+import Codec.Candid.Service
+import Codec.Candid.Parse
+import Codec.Candid.TH
+import Codec.Candid.TypTable
+import Codec.Candid.Decode
+import Codec.Candid.Encode
+import Codec.Candid.EncodeTextual
+
+-- $setup
+-- >>> :set -dppr-cols=200
+-- >>> import Data.Text (Text)
+-- >>> import qualified Data.Text as T
+-- >>> import Data.Void (Void)
+-- >>> import Data.Text.Prettyprint.Doc (pretty)
+-- >>> import qualified Data.ByteString.Lazy.Char8 as BS
+-- >>> :set -XScopedTypeVariables
+
+{- $haskell_types
+
+The easiest way is to use this library is to use the canonical Haskell types. Any type that is an instance of 'Candid' can be used:
+
+>>> encode ([True, False], Just 100)
+"DIDL\STXm~n|\STX\NUL\SOH\STX\SOH\NUL\SOH\228\NUL"
+>>> decode (encode ([True, False], Just 100)) == Right ([True, False], Just 100)
+True
+
+Here, no type annotations are needed, the library can infer them from the types of the Haskell values. You can see the Candid types used using `typeDesc` and `seqDesc`:
+
+>>> :type +d ([True, False], Just 100)
+([True, False], Just 100) :: ([Bool], Maybe Integer)
+>>> :set -XTypeApplications
+>>> pretty (tieKnot (seqDesc @([Bool], Maybe Integer)))
+(vec bool, opt int)
+
+This library is integrated with the @row-types@ library, so you can use their
+records directly:
+
+>>> :set -XOverloadedLabels
+>>> import Data.Row
+>>> encode (#foo .== [True, False] .+ #bar .== Just 100)
+"DIDL\ETXl\STX\211\227\170\STX\SOH\134\142\183\STX\STXn|m~\SOH\NUL\SOH\228\NUL\STX\SOH\NUL"
+>>> :set -XDataKinds -XTypeOperators
+>>> pretty (typeDesc @(Rec ("bar" .== Maybe Integer .+ "foo" .== [Bool])))
+record {bar : opt int; foo : vec bool}
+
+-}
+
+{- $own_type
+
+If you want to use your own types directly, you have to declare an instance of the 'Candid' type class. In this instance, you indicate a canonical Haskel type to describe how your type should serialize, and provide conversion functions to the corresponding 'AsCandid'.
+
+>>> :set -XTypeFamilies
+>>> newtype Age = Age Integer
+>>> :{
+instance Candid Age where
+ type AsCandid Age = Integer
+ toCandid (Age i) = i
+ fromCandid = Age
+:}
+
+>>> encode (Age 42)
+"DIDL\NUL\SOH|*"
+
+This is more or less the only way to introduce recursive types:
+
+>>> data Peano = N | S Peano deriving (Show, Eq)
+>>> :{
+instance Candid Peano where
+ type AsCandid Peano = Maybe Peano
+ toCandid N = Nothing
+ toCandid (S p) = Just p
+ fromCandid Nothing = N
+ fromCandid (Just p) = S p
+:}
+
+>>> peano = S (S (S N))
+>>> encode peano
+"DIDL\SOHn\NUL\SOH\NUL\SOH\SOH\SOH\NUL"
+-}
+
+{- $generic
+
+Especially for Haskell record types, you can use magic involving generic types to create the 'Candid' instance automatically. The best way is using the @DerivingVia@ langauge extension,using the 'AsRecord' new type to indicate that this strategy should be used:
+
+>>> :set -XDerivingVia -XDeriveGeneric -XUndecidableInstances
+>>> import GHC.Generics (Generic)
+>>> :{
+data SimpleRecord = SimpleRecord { foo :: [Bool], bar :: Maybe Integer }
+ deriving Generic
+ deriving Candid via (AsRecord SimpleRecord)
+:}
+
+>>> pretty (typeDesc @SimpleRecord)
+record {bar : opt int; foo : vec bool}
+>>> encode (SimpleRecord { foo = [True, False], bar = Just 100 })
+"DIDL\ETXl\STX\211\227\170\STX\SOH\134\142\183\STX\STXn|m~\SOH\NUL\SOH\228\NUL\STX\SOH\NUL"
+
+Unfortunately, this feature requires @UndecidableInstances@.
+
+This works for variants too:
+
+>>> :{
+data Shape = Point () | Sphere Double | Rectangle (Double, Double)
+ deriving Generic
+ deriving Candid via (AsVariant Shape)
+:}
+
+>>> pretty (typeDesc @Shape)
+variant {Point; Rectangle : record {0 : float64; 1 : float64}; Sphere : float64}
+>>> encode (Rectangle (100,100))
+"DIDL\STXk\ETX\176\200\244\205\ENQ\DEL\143\232\190\218\v\SOH\173\198\172\140\SIrl\STX\NULr\SOHr\SOH\NUL\SOH\NUL\NUL\NUL\NUL\NUL\NULY@\NUL\NUL\NUL\NUL\NUL\NULY@"
+
+Because data constructors are capitalized in Haskell, you cannot derive enums or variants with lower-case names. Also, nullary data constructors are not supported by @row-types@, and thus here, even though they would nicely map onto variants with arguments of type '@null@.
+
+-}
+
+{- $services
+
+Very likely you want to either implement or use whole Candid interfaces. In order to apply the encoding/decoding in one go, you can use 'fromCandidService' and 'toCandidService'. These convert between a raw service ('RawService', takes a method name and bytes, and return bytes), and a typed 'CandidService' (expressed as an 'Data.Row.Rec' record).
+
+Let us create a simple service:
+
+>>> :set -XOverloadedLabels
+>>> import Data.Row
+>>> import Data.Row.Internal
+>>> import Data.IORef
+>>> c <- newIORef 0
+>>> let service = #get .== (\() -> readIORef c) .+ #inc .== (\d -> modifyIORef c (d +))
+>>> service .! #get $ ()
+0
+>>> service .! #inc $ 5
+>>> service .! #get $ ()
+5
+
+For convenience, we name its type
+
+>>> :t service
+service :: Rec ('R '[ "get" ':-> (() -> IO Integer), "inc" ':-> (Integer -> IO ())])
+>>> :set -XTypeOperators -XDataKinds -XFlexibleContexts
+>>> type Interface = 'R '[ "get" ':-> (() -> IO Integer), "inc" ':-> (Integer -> IO ())]
+
+Now we can turn this into a raw service operating on bytes:
+
+>>> let raw = fromCandidService (error . show) error service
+>>> raw (T.pack "get") (BS.pack "DUDE")
+*** Exception: Failed reading: Expected magic bytes "DIDL", got "DUDE"
+...
+>>> raw (T.pack "get") (BS.pack "DIDL\NUL\NUL")
+"DIDL\NUL\SOH|\ENQ"
+>>> raw (T.pack "inc") (BS.pack "DIDL\NUL\SOH|\ENQ")
+"DIDL\NUL\NUL"
+>>> service .! #get $ ()
+10
+
+And finally, we can turn this raw function back into a typed interface:
+
+>>> let service' :: Rec Interface = toCandidService error raw
+>>> service .! #get $ ()
+10
+>>> service .! #inc $ 5
+>>> service .! #get $ ()
+15
+
+In a real application you would more likely pass some networking code to 'toCandidService'.
+
+-}
+
+{- $import
+
+In the example above, we wrote the type of the service in Haskell. But very
+likely you want to talk to a service whose is given to you in the form of a
+@.did@ files, like
+
+> service : {
+> get : () -> (int);
+> inc : (int) -> ();
+> }
+
+You can parse such a description:
+
+>>> either error pretty $ parseDid "service : { get : () -> (int); inc : (int) -> (); }"
+service : {get : () -> (int); inc : (int) -> ();}
+
+And you can even, using Template Haskell, turn this into a proper Haskell type. The 'candid' antiquotation produces a type, and expects a free type variable @m@ for the monad you want to use.
+
+-}
+
+#if MIN_VERSION_GLASGOW_HASKELL(8,10,0,0)
+{- $import2
+>>> :set -XQuasiQuotes
+>>> import Data.Row.Internal
+>>> type Counter m = [candid| service : { get : () -> (int); inc : (int) -> (); } |]
+>>> :info Counter
+type Counter :: (* -> *) -> Row *
+type Counter m = ("get" .== (() -> m Integer)) .+ ("inc" .== (Integer -> m ())) :: Row *
+...
+-}
+#else
+{- $import2
+>>> :set -XQuasiQuotes
+>>> import Data.Row.Internal
+>>> type Counter m = [candid| service : { get : () -> (int); inc : (int) -> (); } |]
+>>> :info Counter
+type Counter (m :: * -> *) = ("get" .== (() -> m Integer)) .+ ("inc" .== (Integer -> m ())) :: Row *
+...
+-}
+#endif
+
+{- $import3
+You can then use this with 'toCandidService' to talk to a service.
+
+If you want to read the description from a @.did@ file, you can use 'candidFile'.
+
+If this encounters a Candid type definition, it will just inline them. This means that cyclic type definitions are not supported.
+
+
+-}
+
+{- $dynamic
+
+Sometimes one needs to interact with Candid in a dynamic way, without static type information.
+
+This library allows the parsing and pretty-printing of candid values. The binary value was copied from above:
+
+>>> import Data.Row
+>>> :set -XDataKinds -XTypeOperators
+>>> let bytes = encode (#bar .== Just 100 .+ #foo .== [True,False])
+>>> let Right vs = decodeVals bytes
+>>> pretty vs
+(record {4895187 = opt +100; 5097222 = vec {true; false}})
+
+As you can see, the binary format does not preserve the field names. Future versions of this library will allow you to specify the (dynamic) 'Type' at which you want to decode these values, to overcome that problem.
+
+Conversely, you can encode from the textual representation:
+
+>>> let Right bytes = encodeTextual "record { foo = vec { true; false }; bar = opt 100 }"
+>>> bytes
+"DIDL\ETXl\STX\211\227\170\STX\STX\134\142\183\STX\SOHm~n}\SOH\NUL\SOHd\STX\SOH\NUL"
+>>> decode @(Rec ("bar" .== Maybe Integer .+ "foo" .== [Bool])) bytes
+Right (#bar .== Just 100 .+ #foo .== [True,False])
+
+
+This function does not support the full textual format yet; in particular type annotation can only be used around number literals.
+
+-}
+
diff --git a/src/Codec/Candid/Class.hs b/src/Codec/Candid/Class.hs
new file mode 100644
index 0000000..1a88153
--- /dev/null
+++ b/src/Codec/Candid/Class.hs
@@ -0,0 +1,506 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE AllowAmbiguousTypes #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE DefaultSignatures #-}
+{-# LANGUAGE OverloadedLabels #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# OPTIONS -Wno-orphans -Wno-deprecations #-}
+-- | This (internal) module contains the encoding and decoding, as well
+-- as the relevant classes
+module Codec.Candid.Class where
+
+import Numeric.Natural
+import qualified Data.Vector as Vec
+import qualified Data.Text as T
+import qualified Data.ByteString as SBS
+import qualified Data.ByteString.Lazy as BS
+import qualified Data.ByteString.Builder as B
+import Data.Row
+import Data.Row.Internal (Row(R), LT((:->)), metamorph)
+import qualified Data.Row.Records as R
+import qualified Data.Row.Internal as R
+import qualified Data.Row.Variants as V
+import Control.Monad.State.Lazy
+import Control.Monad.Trans.Error
+import Control.Applicative ((<|>), Alternative)
+import Data.Functor.Const
+import Data.Bifunctor
+import Data.Proxy
+import Data.Typeable
+import Data.Scientific
+import Data.Word
+import Data.Int
+import Data.Void
+import Data.Text.Prettyprint.Doc
+import Data.Constraint ((\\))
+import Language.Haskell.TH (mkName, tupleDataName)
+import Language.Haskell.TH.Lib
+ ( appT, tupleT, varT, litT, strTyLit
+ , tupP, varP, wildP, infixP
+ , labelE, varE, conE, tupE, listE, uInfixE
+ )
+
+import Codec.Candid.Tuples
+import Codec.Candid.Data
+import Codec.Candid.TypTable
+import Codec.Candid.Types
+import Codec.Candid.FieldName
+import Codec.Candid.Decode
+import Codec.Candid.Encode
+
+-- | Encode based on Haskell type
+encode :: CandidArg a => a -> BS.ByteString
+encode = B.toLazyByteString . encodeBuilder
+
+-- | Encode to a 'B.Builder' based on Haskell type
+encodeBuilder :: forall a. CandidArg a => a -> B.Builder
+encodeBuilder x = encodeValues (seqDesc @a) (toCandidVals x)
+
+-- | Decode to Haskell type
+decode :: forall a. CandidArg a => BS.ByteString -> Either String a
+decode = decodeVals >=> fromCandidVals
+
+-- | Decode values to Haskell type
+fromCandidVals :: CandidArg a => [Value] -> Either String a
+fromCandidVals = fromVals >=> return . fromTuple
+
+toCandidVals :: CandidArg a => a -> [Value]
+toCandidVals = seqVal . asTuple
+
+-- Using normal Haskell values
+
+-- | The class of types that can be used as Candid argument sequences.
+-- Essentially all types that are in 'Candid', but tuples need to be treated specially.
+type CandidArg a = (CandidSeq (AsTuple a), Tuplable a)
+
+
+class CandidSeq a where
+ asTypes :: [Type (Ref TypeRep Type)]
+ seqVal :: a -> [Value]
+ fromVals :: [Value] -> Either String a
+
+seqDesc :: forall a. CandidArg a => SeqDesc
+seqDesc = buildSeqDesc (asTypes @(AsTuple a))
+
+-- | NB: This will loop with recursive types!
+typeDesc :: forall a. Candid a => Type Void
+typeDesc = asType @(AsCandid a) >>= go
+ where go (Ref _ t) = t >>= go
+
+instance Pretty TypeRep where
+ pretty = pretty . show
+
+instance CandidSeq () where
+ asTypes = []
+ seqVal () = []
+ fromVals _ = return () -- Subtyping
+
+instance Candid a => CandidSeq (Unary a) where
+ asTypes = [asType' @a]
+ seqVal (Unary x) = [ toCandidVal x ]
+ fromVals (x:_) = Unary <$> fromCandidVal x -- Subtyping
+ fromVals _ = Left "Not enough arguments"
+
+-- see below for tuple instances
+
+data DeserializeError
+ = DecodeError String -- ^ fatal
+ | CoerceError String Value -- ^ can be recovered
+ | MissingFieldError FieldName -- ^ can be recovered
+ | UnexpectedTagError FieldName -- ^ can be recovered
+
+-- TODO: Can we get rid of this?
+instance Error DeserializeError where strMsg = DecodeError
+
+isRecoverable :: DeserializeError -> Bool
+isRecoverable (DecodeError _) = False
+isRecoverable _ = True
+
+recoverWith :: a -> Either DeserializeError a -> Either DeserializeError a
+recoverWith x (Left e) | isRecoverable e = Right x
+recoverWith _ y = y
+
+showDeserializeError :: DeserializeError -> String
+showDeserializeError e = case e of
+ DecodeError err -> err
+ CoerceError t v -> "Cannot coerce " ++ show (pretty v) ++ " into " ++ t
+ MissingFieldError f -> "Missing field " ++ show (pretty f)
+ UnexpectedTagError f -> "Unexpected tag " ++ show (pretty f)
+
+cannotDecode :: String -> Either DeserializeError a
+cannotDecode s = Left (DecodeError s)
+cannotCoerce :: String -> Value -> Either DeserializeError a
+cannotCoerce t v = Left (CoerceError t v)
+missingField :: FieldName -> Either DeserializeError a
+missingField f = Left (MissingFieldError f)
+unexpectedTag :: FieldName -> Either DeserializeError a
+unexpectedTag f = Left (UnexpectedTagError f)
+
+-- | The internal class of Haskell types that canonically map to Candid.
+-- You would add instances to the 'Candid' type class.
+class Typeable a => CandidVal a where
+ asType :: Type (Ref TypeRep Type)
+ toCandidVal' :: a -> Value
+ fromCandidVal' :: Value -> Either DeserializeError a
+ fromMissingField :: Maybe a
+ fromMissingField = Nothing
+
+-- | The class of Haskell types that can be converted to Candid.
+--
+-- You can create intances of this class for your own types, see the tutorial above for examples. The default instance is mostly for internal use.
+class (Typeable a, CandidVal (AsCandid a)) => Candid a where
+ type AsCandid a
+ toCandid :: a -> AsCandid a
+ fromCandid :: AsCandid a -> a
+
+ type AsCandid a = a
+ default toCandid :: a ~ AsCandid a => a -> AsCandid a
+ toCandid = id
+ default fromCandid :: a ~ AsCandid a => AsCandid a -> a
+ fromCandid = id
+
+toCandidVal :: Candid a => a -> Value
+toCandidVal = toCandidVal' . toCandid
+
+fromCandidVal :: Candid a => Value -> Either String a
+fromCandidVal = first showDeserializeError . fromCandidVal''
+
+fromCandidVal'' :: Candid a => Value -> Either DeserializeError a
+fromCandidVal'' = fmap fromCandid . fromCandidVal'
+
+asType' :: forall a. Candid a => Type (Ref TypeRep Type)
+asType' = RefT (Ref (typeRep (Proxy @(AsCandid a))) (asType @(AsCandid a)))
+
+instance Candid Bool
+instance CandidVal Bool where
+ asType = BoolT
+ toCandidVal' = BoolV
+ fromCandidVal' (BoolV b) = Right b
+ fromCandidVal' v = cannotCoerce "bool" v
+
+instance Candid Natural
+instance CandidVal Natural where
+ asType = NatT
+ toCandidVal' = NatV
+ fromCandidVal' (NumV n)
+ | n >= 0, Right i <- floatingOrInteger @Double n = Right i
+ | otherwise = cannotDecode $ "Not a natural number: " ++ show n
+ fromCandidVal' (NatV n) = Right n
+ fromCandidVal' v = cannotCoerce "nat" v
+
+inBounds :: forall a. (Integral a, Bounded a) => Integer -> Either DeserializeError a
+inBounds i
+ | fromIntegral (minBound :: a) <= i
+ , fromIntegral (maxBound :: a) >= i
+ = Right (fromIntegral i)
+ | otherwise
+ = cannotDecode $ "Out of bounds: " ++ show i
+
+instance Candid Word8
+instance CandidVal Word8 where
+ asType = Nat8T
+ toCandidVal' = Nat8V
+ fromCandidVal' (NumV n) | Right i <- floatingOrInteger @Double n = inBounds i
+ fromCandidVal' (Nat8V n) = Right n
+ fromCandidVal' v = cannotCoerce "word8" v
+
+instance Candid Word16
+instance CandidVal Word16 where
+ asType = Nat16T
+ toCandidVal' = Nat16V
+ fromCandidVal' (NumV n) | Right i <- floatingOrInteger @Double n = inBounds i
+ fromCandidVal' (Nat16V n) = Right n
+ fromCandidVal' v = cannotCoerce "word16" v
+
+instance Candid Word32
+instance CandidVal Word32 where
+ asType = Nat32T
+ toCandidVal' = Nat32V
+ fromCandidVal' (NumV n) | Right i <- floatingOrInteger @Double n = inBounds i
+ fromCandidVal' (Nat32V n) = Right n
+ fromCandidVal' v = cannotCoerce "word32" v
+
+instance Candid Word64
+instance CandidVal Word64 where
+ asType = Nat64T
+ toCandidVal' = Nat64V
+ fromCandidVal' (NumV n) | Right i <- floatingOrInteger @Double n = inBounds i
+ fromCandidVal' (Nat64V n) = Right n
+ fromCandidVal' v = cannotCoerce "word64" v
+
+instance Candid Integer
+instance CandidVal Integer where
+ asType = IntT
+ toCandidVal' = IntV
+ fromCandidVal' (NumV n)
+ | Right i <- floatingOrInteger @Double n = Right i
+ | otherwise = cannotDecode $ "Not an integer: " ++ show n
+ fromCandidVal' (NatV n) = Right (fromIntegral n)
+ fromCandidVal' (IntV n) = Right n
+ fromCandidVal' v = cannotCoerce "int" v
+
+instance Candid Int8
+instance CandidVal Int8 where
+ asType = Int8T
+ toCandidVal' = Int8V
+ fromCandidVal' (NumV n) | Right i <- floatingOrInteger @Double n = inBounds i
+ fromCandidVal' (Int8V n) = Right n
+ fromCandidVal' v = cannotCoerce "int8" v
+
+instance Candid Int16
+instance CandidVal Int16 where
+ asType = Int16T
+ toCandidVal' = Int16V
+ fromCandidVal' (NumV n) | Right i <- floatingOrInteger @Double n = inBounds i
+ fromCandidVal' (Int16V n) = Right n
+ fromCandidVal' v = cannotCoerce "int16" v
+
+instance Candid Int32
+instance CandidVal Int32 where
+ asType = Int32T
+ toCandidVal' = Int32V
+ fromCandidVal' (NumV n) | Right i <- floatingOrInteger @Double n = inBounds i
+ fromCandidVal' (Int32V n) = Right n
+ fromCandidVal' v = cannotCoerce "int32" v
+
+instance Candid Int64
+instance CandidVal Int64 where
+ asType = Int64T
+ toCandidVal' = Int64V
+ fromCandidVal' (NumV n) | Right i <- floatingOrInteger @Double n = inBounds i
+ fromCandidVal' (Int64V n) = Right n
+ fromCandidVal' v = cannotCoerce "int64" v
+
+instance Candid Float
+instance CandidVal Float where
+ asType = Float32T
+ toCandidVal' = Float32V
+ fromCandidVal' (NumV n) = Right (toRealFloat n)
+ fromCandidVal' (Float32V n) = Right n
+ fromCandidVal' v = cannotCoerce "float32" v
+
+instance Candid Double
+instance CandidVal Double where
+ asType = Float64T
+ toCandidVal' = Float64V
+ fromCandidVal' (NumV n) = Right (toRealFloat n)
+ fromCandidVal' (Float64V n) = Right n
+ fromCandidVal' v = cannotCoerce "float64" v
+
+instance Candid Void
+instance CandidVal Void where
+ asType = EmptyT
+ toCandidVal' = absurd
+ fromCandidVal' v = cannotCoerce "void" v
+
+instance Candid T.Text
+instance CandidVal T.Text where
+ asType = TextT
+ toCandidVal' = TextV
+ fromCandidVal' (TextV t) = return t
+ fromCandidVal' v = cannotCoerce "text" v
+
+instance Candid BS.ByteString
+instance CandidVal BS.ByteString where
+ asType = BlobT
+ toCandidVal' = BlobV
+ fromCandidVal' (VecV v) = BS.pack . Vec.toList <$> mapM (fromCandidVal'' @Word8) v
+ fromCandidVal' (BlobV t) = return t
+ fromCandidVal' v = cannotCoerce "blob" v
+
+instance Candid Principal
+instance CandidVal Principal where
+ asType = PrincipalT
+ toCandidVal' = PrincipalV
+ fromCandidVal' (PrincipalV t) = return t
+ fromCandidVal' v = cannotCoerce "principal" v
+
+instance Candid Reserved
+instance CandidVal Reserved where
+ asType = ReservedT
+ toCandidVal' Reserved = ReservedV
+ fromCandidVal' _ = return Reserved
+ fromMissingField = Just Reserved
+
+instance Candid a => Candid (Maybe a)
+instance Candid a => CandidVal (Maybe a) where
+ asType = OptT (asType' @a)
+ toCandidVal' = OptV . fmap toCandidVal
+ fromCandidVal' (OptV x) = recoverWith Nothing $
+ traverse fromCandidVal'' x
+ fromCandidVal' NullV = return Nothing
+ fromCandidVal' ReservedV = return Nothing
+ fromCandidVal' v = case asType @(AsCandid a) of
+ OptT _ -> pure Nothing
+ NullT -> pure Nothing
+ ReservedT -> pure Nothing
+ _ -> recoverWith Nothing $
+ Just <$> fromCandidVal'' v
+ fromMissingField = Just Nothing
+
+
+
+instance Candid a => Candid (Vec.Vector a)
+instance Candid a => CandidVal (Vec.Vector a) where
+ asType = VecT (asType' @a)
+ toCandidVal' = VecV . fmap toCandidVal
+ fromCandidVal' (VecV x) = traverse fromCandidVal'' x
+ fromCandidVal' (BlobV b) = traverse (fromCandidVal'' . Nat8V) $ Vec.fromList $ BS.unpack b
+ fromCandidVal' v = cannotCoerce "vec" v
+
+-- | Maybe a bit opinionated, but 'null' seems to be the unit of Candid
+instance Candid ()
+instance CandidVal () where
+ asType = NullT
+ toCandidVal' () = NullV
+ fromCandidVal' NullV = Right ()
+ fromCandidVal' v = cannotCoerce "null" v
+
+-- row-types integration
+
+fieldOfRow :: forall r. Forall r Candid => Fields (Ref TypeRep Type)
+fieldOfRow = getConst $ metamorph @_ @r @Candid @(Const ()) @(Const (Fields (Ref TypeRep Type))) @Proxy Proxy doNil doUncons doCons (Const ())
+ where
+ doNil :: Const () Empty -> Const (Fields (Ref TypeRep Type)) Empty
+ doNil = const $ Const []
+ doUncons :: forall l t r. (KnownSymbol l)
+ => Label l -> Const () ('R (l ':-> t ': r)) -> (Proxy t, Const () ('R r))
+ doUncons _ _ = (Proxy, Const ())
+ doCons :: forall l t r. (KnownSymbol l, Candid t)
+ => Label l -> Proxy t -> Const (Fields (Ref TypeRep Type)) ('R r) -> Const (Fields (Ref TypeRep Type)) ('R (l ':-> t ': r))
+ doCons l Proxy (Const lst) = Const $ (unescapeFieldName (R.toKey l), asType' @t) : lst
+
+
+type CandidRow r = (Typeable r, AllUniqueLabels r, AllUniqueLabels (V.Map (Either String) r), Forall r Candid, Forall r R.Unconstrained1)
+
+instance CandidRow r => Candid (Rec r)
+instance CandidRow r => CandidVal (Rec r) where
+ asType = RecT $ fieldOfRow @r
+
+ toCandidVal' = do
+ RecV . fmap (first unescapeFieldName) . R.eraseWithLabels @Candid @r @T.Text @Value toCandidVal
+
+ fromCandidVal' = \case
+ RecV m -> toRowRec m
+ TupV m -> toRowRec (zip (map hashedField [0..]) m)
+ v -> cannotCoerce "record" v
+ where
+ toRowRec m = R.fromLabelsA @Candid $ \l ->
+ let fn = unescapeFieldName (R.toKey l) in
+ case lookup fn m of
+ Just v -> fromCandidVal'' v
+ Nothing -> case fromMissingField of
+ Just v -> return (fromCandid v)
+ Nothing -> missingField fn
+
+instance CandidRow r => Candid (V.Var r)
+instance CandidRow r => CandidVal (V.Var r) where
+ asType = VariantT $ fieldOfRow @r
+
+ toCandidVal' v = VariantV (unescapeFieldName t) val
+ where (t, val) = V.eraseWithLabels @Candid toCandidVal v
+
+ fromCandidVal' (VariantV f v) = do
+ needle :: V.Var (V.Map (Either DeserializeError) r) <-
+ (fromLabelsMapA @Candid @_ @_ @r $ \l -> do
+ guard (f == unescapeFieldName (R.toKey l))
+ return $ fromCandidVal'' v
+ ) <|> unexpectedTag f
+ V.sequence (needle :: V.Var (V.Map (Either DeserializeError) r))
+ fromCandidVal' v = cannotCoerce "variant" v
+
+-- https://github.com/target/row-types/issues/66
+fromLabelsMapA :: forall c f g ρ. (Alternative f, Forall ρ c, AllUniqueLabels ρ)
+ => (forall l a. (KnownSymbol l, c a) => Label l -> f (g a)) -> f (V.Var (V.Map g ρ))
+fromLabelsMapA f = V.fromLabels @(R.IsA c g) @(V.Map g ρ) @f inner
+ \\ R.mapForall @g @c @ρ
+ \\ R.uniqueMap @g @ρ
+ where inner :: forall l a. (KnownSymbol l, R.IsA c g a) => Label l -> f a
+ inner l = case R.as @c @g @a of R.As -> f l
+
+
+-- Derived forms
+
+instance Candid SBS.ByteString where
+ type AsCandid SBS.ByteString = BS.ByteString
+ toCandid = BS.fromStrict
+ fromCandid = BS.toStrict
+
+-- Tuples, generated by TH
+
+-- This is what it looks like:
+instance (Candid a, Candid b) => Candid (a, b) where
+ type AsCandid (a,b) = Rec ("_0_" .== a .+ "_1_" .== b)
+ toCandid (a,b) = #_0_ .== a .+ #_1_ .== b
+ fromCandid r = (r .! #_0_, r .! #_1_)
+
+instance (Candid a, Candid b) => CandidSeq (a, b) where
+ asTypes = [asType' @a, asType' @b]
+ seqVal (x, y) = [ toCandidVal x, toCandidVal y ]
+ fromVals (x:y:_) = (,) <$> fromCandidVal x <*> fromCandidVal y
+ fromVals _ = Left "Not enough arguments"
+
+$(
+ let tupT ts = foldl appT (tupleT (length ts)) ts in
+ let fieldLabelT n = litT $ strTyLit ("_" ++ show (n::Int) ++ "_") in
+ let fieldLabelE n = labelE ("_" ++ show (n::Int) ++ "_") in
+
+ fmap concat . sequence $
+ [
+ let names = take n $ map (mkName . (:[])) ['a'..]
+ tvs = map varT names
+ pvs = map varP names
+ vs = map varE names
+ in [d|
+ instance $(tupT [ [t|Candid $v |] | v <- tvs ]) => Candid $(tupT tvs) where
+ type AsCandid $(tupT tvs) =
+ Rec $(
+ foldr1 (\a b -> [t| $a .+ $b |])
+ [ [t| $(fieldLabelT n) .== $b |]
+ | (n,b) <- zip [0..] tvs ])
+ toCandid $(tupP pvs) =
+ $( foldr1 (\a b -> [| $a .+ $b |])
+ [ [| $(fieldLabelE n) .== $b |]
+ | (n,b) <- zip [0..] vs ])
+ fromCandid $(varP (mkName "r")) =
+ $( tupE [ [| $(varE (mkName "r")) .! $(fieldLabelE n) |]
+ | (n,_) <- zip [0..] vs])
+
+ instance $(tupT [ [t|Candid $v |] | v <- tvs ]) => CandidSeq $(tupT tvs) where
+ asTypes = $(listE [ [| asType' @ $v |] | v <- tvs ])
+ seqVal $(tupP pvs) = $(listE [ [| toCandidVal $v |] | v <- vs ])
+ fromVals $(foldr (`infixP` '(:)) wildP pvs)
+ = $( foldl (`uInfixE` varE '(<*>))
+ [| pure $(conE (tupleDataName n)) |]
+ [ [| fromCandidVal $v |] | v <- vs ] )
+ fromVals _ = Left "Not enough arguments"
+ |]
+ | n <- [3..15]
+ ]
+ )
+
+
+instance Candid a => Candid [a] where
+ type AsCandid [a] = Vec.Vector a
+ toCandid = Vec.fromList
+ fromCandid = Vec.toList
+
+
+instance (Candid a, Candid b) => Candid (Either a b) where
+ type AsCandid (Either a b) = V.Var ("Left" V..== a V..+ "Right" V..== b)
+ toCandid (Left x) = IsJust (Label @"Left") x
+ toCandid (Right x) = IsJust (Label @"Right") x
+ fromCandid v = switch v $ empty
+ .+ Label @"Left" .== Left
+ .+ Label @"Right" .== Right
+
diff --git a/src/Codec/Candid/Data.hs b/src/Codec/Candid/Data.hs
new file mode 100644
index 0000000..d6c2ce0
--- /dev/null
+++ b/src/Codec/Candid/Data.hs
@@ -0,0 +1,42 @@
+{-# LANGUAGE OverloadedStrings #-}
+-- | A few extra data types
+module Codec.Candid.Data where
+
+import qualified Data.ByteString.Lazy as BS
+import qualified Data.ByteString.Builder as BS
+import qualified Data.Text as T
+import qualified Data.Text.Encoding as T
+import Data.Digest.CRC
+import Data.Digest.CRC32
+import Data.ByteString.Base32
+import Data.List
+import Data.List.Split (chunksOf)
+import Data.Bifunctor
+import Control.Monad
+
+data Reserved = Reserved
+ deriving (Eq, Ord, Show)
+
+newtype Principal = Principal { rawPrincipal :: BS.ByteString }
+ deriving (Eq, Ord, Show)
+
+prettyPrincipal :: Principal -> T.Text
+prettyPrincipal (Principal blob) =
+ T.pack $ intercalate "-" $ chunksOf 5 $ base32 $ checkbytes <> blob
+ where
+ CRC32 checksum = digest (BS.toStrict blob)
+ checkbytes = BS.toLazyByteString (BS.word32BE checksum)
+ base32 = filter (/='=') . T.unpack . T.toLower . encodeBase32 . BS.toStrict
+
+parsePrincipal :: T.Text -> Either String Principal
+parsePrincipal s = do
+ all_bytes <- bimap T.unpack BS.fromStrict $
+ decodeBase32Unpadded (T.encodeUtf8 (T.filter (/= '-') s))
+ unless (BS.length all_bytes >= 4) $
+ Left "Too short id"
+ let p = Principal (BS.drop 4 all_bytes)
+ let expected = prettyPrincipal p
+ unless (s == expected) $
+ Left $ "Principal id " ++ show s ++ " malformed; did you mean " ++ show expected ++ "?"
+ return p
+
diff --git a/src/Codec/Candid/Decode.hs b/src/Codec/Candid/Decode.hs
new file mode 100644
index 0000000..51afdd7
--- /dev/null
+++ b/src/Codec/Candid/Decode.hs
@@ -0,0 +1,155 @@
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE TupleSections #-}
+
+module Codec.Candid.Decode where
+
+import Numeric.Natural
+import qualified Data.Vector as V
+import qualified Data.Text as T
+import qualified Data.Text.Encoding as T
+import qualified Data.ByteString.Lazy as BS
+import qualified Data.Map as M
+import Control.Monad.State.Lazy
+import Data.List
+import Data.Void
+import Data.Serialize.LEB128.Lenient
+import qualified Data.Serialize.Get as G
+import qualified Data.Serialize.IEEE754 as G
+
+import Codec.Candid.Data
+import Codec.Candid.TypTable
+import Codec.Candid.Types
+import Codec.Candid.FieldName
+
+-- | Decode to value representation
+decodeVals :: BS.ByteString -> Either String [Value]
+decodeVals bytes = G.runGet go (BS.toStrict bytes)
+ where
+ go = do
+ decodeMagic
+ arg_tys <- decodeTypTable
+ vs <- mapM decodeVal (tieKnot (voidEmptyTypes arg_tys))
+ G.remaining >>= \case
+ 0 -> return vs
+ n -> fail $ "Unexpected " ++ show n ++ " left-over bytes"
+
+decodeVal :: Type Void -> G.Get Value
+decodeVal BoolT = G.getWord8 >>= \case
+ 0 -> return $ BoolV False
+ 1 -> return $ BoolV True
+ _ -> fail "Invalid boolean value"
+decodeVal NatT = NatV <$> getLEB128
+decodeVal Nat8T = Nat8V <$> G.getWord8
+decodeVal Nat16T = Nat16V <$> G.getWord16le
+decodeVal Nat32T = Nat32V <$> G.getWord32le
+decodeVal Nat64T = Nat64V <$> G.getWord64le
+decodeVal IntT = IntV <$> getSLEB128
+decodeVal Int8T = Int8V <$> G.getInt8
+decodeVal Int16T = Int16V <$> G.getInt16le
+decodeVal Int32T = Int32V <$> G.getInt32le
+decodeVal Int64T = Int64V <$> G.getInt64le
+decodeVal Float32T = Float32V <$> G.getFloat32le
+decodeVal Float64T = Float64V <$> G.getFloat64le
+decodeVal TextT = TextV <$> do
+ bs <- decodeBytes
+ case T.decodeUtf8' (BS.toStrict bs) of
+ Left err -> fail $ "Invalid utf8: " ++ show err
+ Right t -> return t
+decodeVal NullT = return NullV
+decodeVal ReservedT = return ReservedV
+decodeVal (OptT t) = G.getWord8 >>= \case
+ 0 -> return $ OptV Nothing
+ 1 -> OptV . Just <$> decodeVal t
+ _ -> fail "Invalid optional value"
+decodeVal (VecT Nat8T) = BlobV <$> decodeBytes
+decodeVal (VecT t) = do
+ n <- getLEB128Int
+ VecV . V.fromList <$> replicateM n (decodeVal t)
+decodeVal (RecT fs)
+ | isTuple = TupV <$> mapM (\(_,t) -> decodeVal t) fs'
+ | otherwise = RecV <$> mapM (\(fn, t) -> (fn,) <$> decodeVal t) fs'
+ where
+ fs' = sortOn fst fs
+ isTuple = and $ zipWith (==) (map fst fs') (map hashedField [0..])
+decodeVal (VariantT fs) = do
+ i <- getLEB128Int
+ unless (i < length fs) $ fail "variant index out of bound"
+ let (fn, t) = fs' !! i
+ VariantV fn <$> decodeVal t
+ where
+ fs' = sortOn fst fs
+decodeVal PrincipalT = G.getWord8 >>= \case
+ 0 -> fail "reference encountered"
+ 1 -> PrincipalV . Principal <$> decodeBytes
+ _ -> fail "Invalid principal value"
+decodeVal BlobT = error "shorthand encountered while decoding"
+decodeVal EmptyT = fail "Empty value"
+decodeVal (RefT v) = absurd v
+
+decodeBytes :: G.Get BS.ByteString
+decodeBytes = getLEB128Int >>= G.getLazyByteString
+
+decodeMagic :: G.Get ()
+decodeMagic = do
+ magic <- G.getBytes 4
+ unless (magic == T.encodeUtf8 (T.pack "DIDL")) $
+ fail $ "Expected magic bytes \"DIDL\", got " ++ show magic
+
+getLEB128Int :: Integral a => G.Get a
+getLEB128Int = fromIntegral <$> getLEB128 @Natural
+
+-- eagerly detect overshoot
+checkOvershoot :: Natural -> G.Get ()
+checkOvershoot n = void (G.lookAhead $ G.ensure $ fromIntegral n)
+
+decodeSeq :: G.Get a -> G.Get [a]
+decodeSeq act = do
+ len <- getLEB128Int
+ checkOvershoot (fromIntegral len)
+ replicateM len act
+
+decodeTypTable :: G.Get SeqDesc
+decodeTypTable = do
+ len <- getLEB128
+ checkOvershoot len
+ table <- replicateM (fromIntegral len) (decodeTypTableEntry len)
+ ts <- decodeSeq (decodeTypRef len)
+ let m = M.fromList (zip [0..] table)
+ return $ SeqDesc m ts
+
+decodeTypTableEntry :: Natural -> G.Get (Type Int)
+decodeTypTableEntry max = getSLEB128 @Integer >>= \case
+ -18 -> OptT <$> decodeTypRef max
+ -19 -> VecT <$> decodeTypRef max
+ -20 -> RecT <$> decodeTypFields max
+ -21 -> VariantT <$> decodeTypFields max
+ _ -> fail "Unknown structural type"
+
+decodeTypRef :: Natural -> G.Get (Type Int)
+decodeTypRef max = do
+ i <- getSLEB128
+ when (i >= fromIntegral max) $ fail "Type reference out of range"
+ if i < 0
+ then case primTyp i of
+ Just t -> return t
+ Nothing -> fail $ "Unknown prim typ " ++ show i
+ else return $ RefT (fromIntegral i)
+
+isOrdered :: Ord a => [a] -> Bool
+isOrdered [] = True
+isOrdered [_] = True
+isOrdered (x:y:xs) = x < y && isOrdered (y:xs)
+
+decodeTypFields :: Natural -> G.Get (Fields Int)
+decodeTypFields max = do
+ fs <- decodeSeq (decodeTypField max)
+ unless (isOrdered (map fst fs)) $
+ fail "Fields not in strict order"
+ return fs
+
+decodeTypField :: Natural -> G.Get (FieldName, Type Int)
+decodeTypField max = do
+ h <- getLEB128
+ t <- decodeTypRef max
+ return (hashedField h, t)
diff --git a/src/Codec/Candid/Encode.hs b/src/Codec/Candid/Encode.hs
new file mode 100644
index 0000000..004437b
--- /dev/null
+++ b/src/Codec/Candid/Encode.hs
@@ -0,0 +1,191 @@
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE RecursiveDo #-}
+
+module Codec.Candid.Encode (encodeValues, encodeDynValues) where
+
+import Numeric.Natural
+import qualified Data.Vector as V
+import qualified Data.Text.Encoding as T
+import qualified Data.ByteString.Lazy as BS
+import qualified Data.ByteString.Builder as B
+import qualified Data.Map as M
+import Data.Scientific
+import Control.Monad.State.Lazy
+import Data.Bifunctor
+import Data.List
+import Data.Void
+import Control.Monad.RWS.Lazy
+import Data.Serialize.LEB128
+import Data.Text.Prettyprint.Doc
+
+import Codec.Candid.Data
+import Codec.Candid.TypTable
+import Codec.Candid.Types
+import Codec.Candid.FieldName
+import Codec.Candid.Infer
+
+
+-- | Encodes a Candid value given in the dynamic 'Value' form, at inferred type.
+--
+-- This may fail if the values have inconsistent types. It does not use the
+-- @reserved@ supertype (unless explicitly told to).
+encodeDynValues :: [Value] -> Either String B.Builder
+encodeDynValues vs = do
+ ts <- inferTypes vs
+ return $ encodeValues (SeqDesc mempty ts) vs
+
+-- | Encodes a Candid value given in the dynamic 'Value' form, at given type.
+--
+-- This fails if the values do not match the given type.
+encodeValues :: SeqDesc -> [Value] -> B.Builder
+encodeValues t vs = mconcat
+ [ B.stringUtf8 "DIDL"
+ , typTable t
+ , encodeSeq (tieKnot t) vs
+ ]
+
+encodeSeq :: [Type Void] -> [Value] -> B.Builder
+encodeSeq [] _ = mempty -- NB: Subtyping
+encodeSeq (t:ts) (x:xs) = encodeVal t x <> encodeSeq ts xs
+encodeSeq _ [] = error "encodeSeq: Not enough values"
+
+encodeVal :: Type Void -> Value -> B.Builder
+encodeVal BoolT (BoolV False) = B.word8 0
+encodeVal BoolT (BoolV True) = B.word8 1
+encodeVal NatT (NumV n) | n >= 0, Right i <- floatingOrInteger @Double n = encodeVal NatT (NatV i)
+encodeVal NatT (NatV n) = buildLEB128 n
+encodeVal Nat8T (Nat8V n) = B.word8 n
+encodeVal Nat16T (Nat16V n) = B.word16LE n
+encodeVal Nat32T (Nat32V n) = B.word32LE n
+encodeVal Nat64T (Nat64V n) = B.word64LE n
+encodeVal IntT (NumV n) | Right i <- floatingOrInteger @Double n = encodeVal IntT (IntV i)
+encodeVal IntT (NatV n) = encodeVal IntT (IntV (fromIntegral n)) -- NB Subtyping
+encodeVal IntT (IntV n) = buildSLEB128 n
+encodeVal Int8T (Int8V n) = B.int8 n
+encodeVal Int16T (Int16V n) = B.int16LE n
+encodeVal Int32T (Int32V n) = B.int32LE n
+encodeVal Int64T (Int64V n) = B.int64LE n
+encodeVal Float32T (Float32V n) = B.floatLE n
+encodeVal Float64T (Float64V n) = B.doubleLE n
+encodeVal TextT (TextV t) = encodeBytes (BS.fromStrict (T.encodeUtf8 t))
+encodeVal NullT NullV = mempty
+encodeVal ReservedT _ = mempty -- NB Subtyping
+encodeVal (OptT _) (OptV Nothing) = B.word8 0
+encodeVal (OptT t) (OptV (Just x)) = B.word8 1 <> encodeVal t x
+encodeVal (VecT t) (VecV xs) =
+ buildLEB128Int (V.length xs) <>
+ foldMap (encodeVal t) xs
+encodeVal (RecT fs) (TupV vs) = encodeVal (RecT fs) (tupV vs)
+encodeVal (RecT fs) (RecV vs) = encodeRec fs' vs
+ where
+ fs' = sortOn fst fs
+encodeVal (VariantT fs) (VariantV f x) =
+ case findIndex (\(f',_) -> f' == f) fs' of
+ Just i | let t = snd (fs' !! i) ->
+ buildLEB128Int i <> encodeVal t x
+ Nothing -> error $ "encodeVal: Variant field " ++ show (pretty f) ++ " not found"
+ where
+ fs' = sortOn fst fs
+encodeVal PrincipalT (PrincipalV (Principal s)) = B.int8 1 <> encodeBytes s
+encodeVal BlobT (BlobV b) = encodeBytes b
+encodeVal (VecT Nat8T) (BlobV b) = encodeBytes b
+encodeVal (RefT x) _ = absurd x
+encodeVal t v = error $ "Unexpected value at type " ++ show (pretty t) ++ ": " ++ show (pretty v)
+
+encodeBytes :: BS.ByteString -> B.Builder
+encodeBytes bytes = buildLEB128Int (BS.length bytes) <> B.lazyByteString bytes
+
+-- Encodes the fields in order specified by the type
+encodeRec :: [(FieldName, Type Void)] -> [(FieldName, Value)] -> B.Builder
+encodeRec [] _ = mempty -- NB: Subtyping
+encodeRec ((f,t):fs) vs
+ | Just v <- lookup f vs = encodeVal t v <> encodeRec fs vs
+ | otherwise = error $ "Missing record field " ++ show (pretty f)
+
+type TypTableBuilder k = RWS () B.Builder (M.Map (Type k) Integer, Natural)
+
+typTable :: SeqDesc -> B.Builder
+typTable (SeqDesc m (ts :: [Type k])) = mconcat
+ [ buildLEB128 typ_tbl_len
+ , typ_tbl
+ , leb128Len ts
+ , foldMap buildSLEB128 typ_idxs
+ ]
+ where
+ (typ_idxs, (_, typ_tbl_len), typ_tbl) = runRWS (mapM go ts) () (M.empty, 0)
+
+ addCon :: Type k -> TypTableBuilder k B.Builder -> TypTableBuilder k Integer
+ addCon t body = gets (M.lookup t . fst) >>= \case
+ Just i -> return i
+ Nothing -> mdo
+ i <- gets snd
+ modify' (first (M.insert t (fromIntegral i)))
+ modify' (second succ)
+ tell b
+ b <- body
+ return $ fromIntegral i
+
+ go :: Type k -> TypTableBuilder k Integer
+ go t = case t of
+ NullT -> return $ -1
+ BoolT -> return $ -2
+ NatT -> return $ -3
+ IntT -> return $ -4
+ Nat8T -> return $ -5
+ Nat16T -> return $ -6
+ Nat32T -> return $ -7
+ Nat64T -> return $ -8
+ Int8T -> return $ -9
+ Int16T -> return $ -10
+ Int32T -> return $ -11
+ Int64T -> return $ -12
+ Float32T -> return $ -13
+ Float64T -> return $ -14
+ TextT -> return $ -15
+ ReservedT -> return $ -16
+ EmptyT -> return $ -17
+
+ -- Constructors
+ OptT t' -> addCon t $ do
+ ti <- go t'
+ return $ buildSLEB128 @Integer (-18) <> buildSLEB128 ti
+ VecT t' -> addCon t $ do
+ ti <- go t'
+ return $ buildSLEB128 @Integer (-19) <> buildSLEB128 ti
+ RecT fs -> addCon t $ recordLike (-20) fs
+ VariantT fs -> addCon t $ recordLike (-21) fs
+
+ -- References
+ PrincipalT -> return $ -24
+
+ -- Short-hands
+ BlobT -> addCon t $
+ -- blob = vec nat8
+ return $ buildSLEB128 @Integer (-19) <> buildSLEB128 @Integer (-5)
+
+ RefT t -> go (m M.! t)
+
+ goField :: (FieldName, Type k) -> TypTableBuilder k (FieldName, Integer)
+ goField (fn, t) = do
+ ti <- go t
+ return (fn, ti)
+
+ recordLike :: Integer -> Fields k -> TypTableBuilder k B.Builder
+ recordLike n fs = do
+ tis <- mapM goField fs
+ return $ mconcat
+ [ buildSLEB128 n
+ , leb128Len tis
+ , foldMap (\(f,ti) -> buildLEB128 (fieldHash f) <> buildSLEB128 ti) $
+ sortOn fst tis -- TODO: Check duplicates maybe?
+ ]
+
+buildLEB128Int :: Integral a => a -> B.Builder
+buildLEB128Int = buildLEB128 @Natural . fromIntegral
+
+leb128Len :: [a] -> B.Builder
+leb128Len = buildLEB128Int . length
+
diff --git a/src/Codec/Candid/EncodeTextual.hs b/src/Codec/Candid/EncodeTextual.hs
new file mode 100644
index 0000000..bbefff5
--- /dev/null
+++ b/src/Codec/Candid/EncodeTextual.hs
@@ -0,0 +1,16 @@
+module Codec.Candid.EncodeTextual where
+
+import qualified Data.ByteString.Lazy as BS
+import qualified Data.ByteString.Builder as B
+import Control.Monad
+
+import Codec.Candid.Parse
+import Codec.Candid.Encode
+
+-- | Encodes a Candid value given in textual form.
+--
+-- This may fail if the textual form cannot be parsed or has inconsistent
+-- types. It does not use the @reserved@ supertype (unless explicitly told to).
+encodeTextual :: String -> Either String BS.ByteString
+encodeTextual = parseValues >=> encodeDynValues >=> return . B.toLazyByteString
+
diff --git a/src/Codec/Candid/FieldName.hs b/src/Codec/Candid/FieldName.hs
new file mode 100644
index 0000000..2054879
--- /dev/null
+++ b/src/Codec/Candid/FieldName.hs
@@ -0,0 +1,87 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+-- This module keeps the FieldName type abstract,
+-- to ensure that the field name hash is correct
+module Codec.Candid.FieldName
+ ( FieldName
+ , labledField
+ , hashedField
+ , fieldHash
+ , candidHash
+ , unescapeFieldName
+ , escapeFieldName
+ ) where
+
+import qualified Data.Text as T
+import qualified Data.Text.Encoding as T
+import qualified Data.ByteString.Lazy as BS
+import Data.Text.Prettyprint.Doc
+import Data.String
+import Data.Word
+import Numeric.Natural
+import Data.Function
+import Text.Read (readMaybe)
+
+-- | A type for a Candid field name. Essentially a 'Word32' with maybe a textual label attached
+data FieldName = FieldName
+ { fieldHash :: Word32 -- ^ Extract the raw field hash value
+ , fieldName :: Maybe T.Text
+ }
+ deriving Show
+
+-- | Create a 'FieldName' from a label
+labledField :: T.Text -> FieldName
+labledField s = FieldName (candidHash s) (Just s)
+
+-- | Create a 'FieldName' from the raw hash
+hashedField :: Word32 -> FieldName
+hashedField h = FieldName h Nothing
+
+-- | The Candid field label hashing algorithm
+candidHash :: T.Text -> Word32
+candidHash s = BS.foldl (\h c -> (h * 223 + fromIntegral c)) 0 $ BS.fromStrict $ T.encodeUtf8 s
+
+instance Eq FieldName where
+ (==) = (==) `on` fieldHash
+ (/=) = (/=) `on` fieldHash
+
+instance Ord FieldName where
+ compare = compare `on` fieldHash
+ (<) = (<) `on` fieldHash
+ (>) = (>) `on` fieldHash
+ (<=) = (<=) `on` fieldHash
+ (>=) = (>=) `on` fieldHash
+
+instance IsString FieldName where
+ fromString = labledField . fromString
+
+instance Pretty FieldName where
+ pretty (FieldName _ (Just x)) = pretty x
+ pretty (FieldName h Nothing) = pretty h
+
+
+-- | The inverse of 'escapeFieldName'
+unescapeFieldName :: T.Text -> FieldName
+unescapeFieldName n
+ | Just ('_',r') <- T.uncons n
+ , Just (r,'_') <- T.unsnoc r'
+ , Just (n' :: Natural) <- readMaybe (T.unpack r)
+ , n' <= fromIntegral (maxBound :: Word32)
+ = hashedField (fromIntegral n')
+ | Just (n', '_') <- T.unsnoc n
+ = labledField n'
+ | otherwise
+ = labledField n
+
+-- | Represent a 'FieldName' (which may be numeric) in contexts where only text
+-- is allowed, using the same encoding/decoding algorithm as Motoko.
+--
+-- This used in the 'Codec.Candid.Class.Candid' instance for 'Data.Row.Rec' and
+-- 'Data.Row.Vec'
+escapeFieldName :: FieldName -> T.Text
+escapeFieldName (FieldName _ (Just "")) = ""
+escapeFieldName (FieldName _ (Just n)) | T.last n == '_' = n <> "_"
+escapeFieldName (FieldName _ (Just n)) = n
+escapeFieldName (FieldName h Nothing) = T.singleton '_' <> T.pack (show h) <> T.singleton '_'
+
+
diff --git a/src/Codec/Candid/Generic.hs b/src/Codec/Candid/Generic.hs
new file mode 100644
index 0000000..b1d9a1d
--- /dev/null
+++ b/src/Codec/Candid/Generic.hs
@@ -0,0 +1,49 @@
+{-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE GADTSyntax #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE UndecidableInstances #-} -- the reason for this being in its own module
+{-# OPTIONS_GHC -Wno-orphans #-}
+module Codec.Candid.Generic (AsRecord(..), AsVariant(..)) where
+
+import qualified Data.Row as R
+import qualified Data.Row.Records as R
+import qualified Data.Row.Variants as V
+import Data.Typeable
+
+import Codec.Candid.Class
+
+-- | This newtype encodes a Haskell record type using generic programming. Best used with @DerivingVia@, as shown in the tutorial.
+newtype AsRecord a = AsRecord { unAsRecord :: a }
+
+
+type CanBeCandidRecord a =
+ ( Typeable a
+ , Candid (R.Rec (R.NativeRow a))
+ , R.ToNative a
+ , R.FromNative a
+ )
+instance CanBeCandidRecord a => Candid (AsRecord a) where
+ type AsCandid (AsRecord a) = AsCandid (R.Rec (R.NativeRow a))
+ toCandid = toCandid @(R.Rec (R.NativeRow a)) . R.fromNative . unAsRecord
+ fromCandid = AsRecord . R.toNative . fromCandid @(R.Rec (R.NativeRow a))
+
+-- | This newtype encodes a Haskell data type as a variant using generic programming. Best used with @DerivingVia@, as shown in the tutorial.
+newtype AsVariant a = AsVariant { unAsVariant :: a }
+
+type CanBeCandidVariant a =
+ ( Typeable a
+ , Candid (V.Var (V.NativeRow a))
+ , V.ToNative a
+ , V.FromNative a
+ )
+
+instance CanBeCandidVariant a => Candid (AsVariant a) where
+ type AsCandid (AsVariant a) = AsCandid (V.Var (V.NativeRow a))
+ toCandid = toCandid @(V.Var (V.NativeRow a)) . V.fromNative . unAsVariant
+ fromCandid = AsVariant . V.toNative . fromCandid @(V.Var (V.NativeRow a))
diff --git a/src/Codec/Candid/Infer.hs b/src/Codec/Candid/Infer.hs
new file mode 100644
index 0000000..0ecbd8c
--- /dev/null
+++ b/src/Codec/Candid/Infer.hs
@@ -0,0 +1,101 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TupleSections #-}
+module Codec.Candid.Infer where
+
+import qualified Data.Vector as V
+import Control.Monad
+import Data.Void
+import Data.List
+import Data.Text.Prettyprint.Doc
+
+import Codec.Candid.Types
+
+inferTypes :: [Value] -> Either String [Type Void]
+inferTypes = mapM inferTyp
+
+inferTyp :: Value -> Either String (Type Void)
+inferTyp (NumV v) = return $ if v >= 0 then NatT else IntT
+inferTyp (BoolV _) = return BoolT
+inferTyp (NatV _) = return NatT
+inferTyp (Nat8V _) = return Nat8T
+inferTyp (Nat16V _) = return Nat16T
+inferTyp (Nat32V _) = return Nat32T
+inferTyp (Nat64V _) = return Nat64T
+inferTyp (IntV _) = return IntT
+inferTyp (Int8V _) = return Int8T
+inferTyp (Int16V _) = return Int16T
+inferTyp (Int32V _) = return Int32T
+inferTyp (Int64V _) = return Int64T
+inferTyp (Float32V _) = return Float32T
+inferTyp (Float64V _) = return Float64T
+inferTyp (TextV _) = return TextT
+inferTyp NullV = return NullT
+inferTyp ReservedV = return ReservedT
+inferTyp (OptV Nothing) = return $ OptT EmptyT
+inferTyp (OptV (Just v)) = OptT <$> inferTyp v
+inferTyp (VecV vs) = VecT <$> (mapM inferTyp (V.toList vs) >>= lubs)
+inferTyp (RecV fs) = RecT <$> sequence [ (fn,) <$> inferTyp t | (fn, t) <- fs ]
+inferTyp (VariantV f v) = do
+ t <- inferTyp v
+ return $ VariantT [ (f, t) ]
+inferTyp (TupV vs) = tupT <$> mapM inferTyp vs
+inferTyp (PrincipalV _) = return PrincipalT
+inferTyp (BlobV _) = return BlobT
+inferTyp (AnnV _ t) = return t -- Maybe do type checking?
+
+lubs :: [Type Void] -> Either String (Type Void)
+lubs = foldM lub EmptyT
+
+lub :: Type Void -> Type Void -> Either String (Type Void)
+lub ReservedT _ = return ReservedT
+lub _ ReservedT = return ReservedT
+lub EmptyT t = return t
+lub t EmptyT = return t
+lub NatT IntT = return IntT
+lub IntT NatT = return IntT
+lub NullT (OptT t) = return (OptT t)
+lub (OptT t) NullT = return (OptT t)
+lub (OptT t1) (OptT t2) = OptT <$> lub t1 t2
+lub (VecT t1) (VecT t2) = VecT <$> lub t1 t2
+lub (RecT fs1) (RecT fs2) = RecT <$> go (sortOn fst fs1) (sortOn fst fs2)
+ where
+ go [] _ = return []
+ go _ [] = return []
+ go ((f1, v1):fs1) ((f2,v2):fs2)
+ | f1 < f2 = go fs1 ((f2,v2):fs2)
+ | f1 > f2 = go ((f1,v1):fs1) fs2
+ | otherwise = (:) <$> ((f1,) <$> lub v1 v2) <*> go fs1 fs2
+lub (VariantT fs1) (VariantT fs2) = VariantT <$> go (sortOn fst fs1) (sortOn fst fs2)
+ where
+ go [] fs = return fs
+ go fs [] = return fs
+ go ((f1, v1):fs1) ((f2,v2):fs2)
+ | f1 < f2 = ((f1,v1) :) <$> go fs1 ((f2,v2):fs2)
+ | f1 > f2 = ((f2,v2) :) <$> go ((f1,v1):fs1) fs2
+ | otherwise = (:) <$> ((f1,) <$> lub v1 v2) <*> go fs1 fs2
+
+-- the reflexive cases
+lub NatT NatT = return NatT
+lub Nat8T Nat8T = return Nat8T
+lub Nat16T Nat16T = return Nat16T
+lub Nat32T Nat32T = return Nat32T
+lub Nat64T Nat64T = return Nat64T
+lub IntT IntT = return IntT
+lub Int8T Int8T = return Int8T
+lub Int16T Int16T = return Int16T
+lub Int32T Int32T = return Int32T
+lub Int64T Int64T = return Int64T
+lub Float32T Float32T = return Float32T
+lub Float64T Float64T = return Float64T
+lub BoolT BoolT = return BoolT
+lub TextT TextT = return TextT
+lub NullT NullT = return NullT
+lub BlobT BlobT = return BlobT
+lub PrincipalT PrincipalT = return PrincipalT
+
+-- The shorthands
+lub BlobT t@(VecT _) = lub (VecT Nat8T) t
+lub t@(VecT _) BlobT = lub (VecT Nat8T) t
+
+-- failure
+lub t1 t2 = Left $ show $ "Incompatible types: " <+> pretty t1 <+> " and " <+> pretty t2
diff --git a/src/Codec/Candid/Parse.hs b/src/Codec/Candid/Parse.hs
new file mode 100644
index 0000000..d4022b6
--- /dev/null
+++ b/src/Codec/Candid/Parse.hs
@@ -0,0 +1,396 @@
+{-# LANGUAGE DeriveTraversable #-}
+module Codec.Candid.Parse
+ ( DidFile(..)
+ , DidDef
+ , DidMethod(..)
+ , TypeName
+ , parseDid
+ , parseDidType
+ , parseValue
+ , parseValues
+ , CandidTestFile(..)
+ , CandidTest(..)
+ , TestInput(..)
+ , TestAssertion(..)
+ , parseCandidTests
+ ) where
+
+import qualified Data.ByteString.Lazy as BS
+import qualified Data.Text.Encoding as T
+import qualified Data.Text as T
+import qualified Data.Vector as V
+import qualified Data.Set as Set
+import Text.Megaparsec
+import Text.Megaparsec.Char
+import Data.Bifunctor
+import Data.Char
+import Data.Functor
+import Data.Word
+import Numeric.Natural
+import Numeric
+import Control.Monad
+import Data.Void
+import Text.Read (readMaybe)
+import Data.Scientific
+
+import Codec.Candid.Data
+import Codec.Candid.Types
+import Codec.Candid.FieldName
+
+type Parser = Parsec Void String
+
+-- | Parses a Candid description (@.did@) from a string
+parseDid :: String -> Either String DidFile
+parseDid = first errorBundlePretty . parse (allInput fileP) "Candid service"
+
+parseDidType :: String -> Either String (Type TypeName)
+parseDidType = first errorBundlePretty . parse (allInput dataTypeP) "Candid type"
+
+-- | Parses a Candid textual value from a string
+parseValue :: String -> Either String Value
+parseValue = first errorBundlePretty . parse (allInput valueP) "Candid value"
+
+-- | Parses a sequence of Candid textual values from a string
+parseValues :: String -> Either String [Value]
+parseValues = first errorBundlePretty . parse (allInput valuesP) "Candid values (argument sequence)"
+
+allInput :: Parser a -> Parser a
+allInput = between theVoid eof
+
+fileP :: Parser DidFile
+fileP = DidFile <$> defsP <*> actorP
+
+defsP :: Parser [DidDef TypeName]
+defsP = concat <$> many defP
+
+defP :: Parser [DidDef TypeName]
+defP = (typeP <|> importP) <* s ";"
+
+typeP :: Parser [DidDef TypeName]
+typeP = fmap (:[]) $
+ (,) <$ k "type" <*> idP <* s "=" <*> dataTypeP
+
+importP :: Parser [DidDef TypeName]
+importP = withPredicate (const (Left "imports not yet supported")) $
+ [] <$ k "import"
+
+actorP :: Parser (DidService TypeName)
+actorP = k "service" *> optional idP *> s ":" *> actorTypeP -- TODO could be a type id
+
+actorTypeP :: Parser (DidService TypeName)
+actorTypeP = braceSemi methTypeP
+
+methTypeP :: Parser (DidMethod TypeName)
+methTypeP = do
+ n <- nameP
+ s ":"
+ (ts1, ts2) <- funcTypeP -- TODO could be a type id
+ return $ DidMethod n ts1 ts2
+
+funcTypeP :: Parser ([Type TypeName], [Type TypeName])
+funcTypeP = (,) <$> seqP <* s "->" <*> seqP <* many funcAnnP
+
+funcAnnP :: Parser () -- TODO: Annotations are dropped
+funcAnnP = s "oneway" <|> s "query"
+
+nameP :: Parser T.Text
+nameP = textP <|> idP <?> "name"
+
+textP :: Parser T.Text
+textP = T.pack <$> l (between (char '"') (char '"') (many stringElem)) <?> "text"
+
+blobP :: Parser BS.ByteString
+blobP = BS.concat <$> l (between (char '"') (char '"') (many blobElem)) <?> "blob"
+
+blobElem :: Parser BS.ByteString
+blobElem = choice
+ [ try (char '\\' *> lookAhead hexdigit) *> do
+ raw <- replicateM 2 hexdigit
+ case readHex raw of
+ [(n,"")] -> return (BS.singleton (fromIntegral (n::Integer)))
+ _ -> fail "Internal parsing error parsing hex digits"
+ , BS.fromStrict . T.encodeUtf8 . T.singleton <$> stringElem
+ ]
+
+stringElem :: Parser Char
+stringElem = (char '\\' *> go) <|> noneOf "\""
+ where
+ go :: Parser Char
+ go = choice
+ [ '\t' <$ char 't'
+ , '\n' <$ char 'n'
+ , '\r' <$ char 'r'
+ , '\"' <$ char '\"'
+ , '\'' <$ char '\''
+ , '\\' <$ char '\\'
+ , between (string "u{") (string "}") hexnum
+ ]
+
+ hexnum :: Parser Char
+ hexnum = do
+ raw <- concat <$> some (replicateM 2 hexdigit)
+ case readHex raw of
+ [(n,"")] -> return (chr n)
+ _ -> fail $ "Invalid hex string " ++ show raw
+
+hexdigit :: Parser Char
+hexdigit = oneOf "0123456789ABCDEFabcdef"
+
+seqP :: Parser [Type TypeName]
+seqP = parenComma argTypeP
+
+argTypeP :: Parser (Type TypeName)
+argTypeP = dataTypeP <|> (nameP *> s ":" *> dataTypeP)
+
+dataTypeP :: Parser (Type TypeName)
+dataTypeP = primTypeP <|> constTypeP <|> (RefT <$> idP)-- TODO: reftypes
+
+primTypeP :: Parser (Type TypeName)
+primTypeP = choice
+ [ NatT <$ k "nat"
+ , Nat8T <$ k "nat8"
+ , Nat16T <$ k "nat16"
+ , Nat32T <$ k "nat32"
+ , Nat64T <$ k "nat64"
+ , IntT <$ k "int"
+ , Int8T <$ k "int8"
+ , Int16T <$ k "int16"
+ , Int32T <$ k "int32"
+ , Int64T <$ k "int64"
+ , Float32T <$ k "float32"
+ , Float64T <$ k "float64"
+ , BoolT <$ k "bool"
+ , TextT <$ k "text"
+ , NullT <$ k "null"
+ , ReservedT <$ k "reserved"
+ , EmptyT <$ k "empty"
+ , BlobT <$ k "blob"
+ , PrincipalT <$ k "principal"
+ ]
+
+constTypeP :: Parser (Type TypeName)
+constTypeP = choice
+ [ OptT <$ k "opt" <*> dataTypeP
+ , VecT <$ k "vec" <*> dataTypeP
+ , RecT . resolveShorthand <$ k "record" <*> braceSemi recordFieldTypeP
+ , VariantT <$ k "variant" <*> braceSemi variantFieldTypeP
+ ]
+
+fieldLabelP :: Parser FieldName
+fieldLabelP =
+ hashedField . fromIntegral <$> natP <|>
+ labledField <$> nameP
+
+variantFieldTypeP :: Parser (FieldName, Type TypeName)
+variantFieldTypeP =
+ (,) <$> fieldLabelP <*> ((s ":" *> dataTypeP) <|> pure NullT)
+
+resolveShorthand :: [Word32 -> (FieldName, a)] -> [(FieldName, a)]
+resolveShorthand = go 0
+ where
+ go _ [] = []
+ go n (f:fs) =
+ let f' = f n in
+ f' : go (succ (fieldHash (fst f'))) fs
+
+recordFieldTypeP :: Parser (Word32 -> (FieldName, Type TypeName))
+recordFieldTypeP = choice
+ [ try $ do
+ l <- fieldLabelP
+ s ":"
+ t <- dataTypeP
+ return $ const (l,t)
+ , do
+ t <- dataTypeP
+ return $ \next -> (hashedField next, t)
+ ]
+
+idP :: Parser T.Text
+idP = T.pack <$> l ((:)
+ <$> satisfy (\c -> isAscii c && isLetter c || c == '_')
+ <*> many (satisfy (\c -> isAscii c && isAlphaNum c || c == '_'))
+ ) <?> "id"
+
+valuesP :: Parser [Value]
+valuesP = (parenComma annValueP <?> "argument sequence")
+ <|> ((:[]) <$> annValueP) -- for convenience
+
+annValueP :: Parser Value
+annValueP =
+ parens annValueP <|> do -- this parser allows extra parentheses
+ v <- valueP
+ s ":" *> do
+ t <- dataTypeP
+ smartAnnV v t
+ <|> return v
+
+smartAnnV :: Value -> Type TypeName -> Parser Value
+smartAnnV (NumV n) Nat8T = Nat8V <$> toBounded n
+smartAnnV (NumV n) Nat16T = Nat16V <$> toBounded n
+smartAnnV (NumV n) Nat32T = Nat32V <$> toBounded n
+smartAnnV (NumV n) Nat64T = Nat64V <$> toBounded n
+smartAnnV (NumV n) Int8T = Int8V <$> toBounded n
+smartAnnV (NumV n) Int16T = Int16V <$> toBounded n
+smartAnnV (NumV n) Int32T = Int32V <$> toBounded n
+smartAnnV (NumV n) Int64T = Int64V <$> toBounded n
+smartAnnV (NumV n) Float32T = return $ Float32V $ toRealFloat n
+smartAnnV (NumV n) Float64T = return $ Float64V $ toRealFloat n
+smartAnnV v ReservedT = return $ AnnV v ReservedT
+smartAnnV _ _ = fail "Annotations are only supported around number literals"
+
+toBounded :: (Integral a, Bounded a) => Scientific -> Parser a
+toBounded v = maybe err return $ toBoundedInteger v
+ where err = fail $ "Number literal out of bounds: " ++ show v
+
+numP :: Parser Scientific
+numP = l p >>= conv <?> "number"
+ where
+ p =(:) <$> oneOf "-+0123456789" <*> many (oneOf "-+.0123456789eE_")
+ conv raw = case readMaybe (filter (/= '_') (handle_trailing_perdiod raw)) of
+ Nothing -> fail $ "Invald number literal: " ++ show raw
+ Just s -> return s
+ -- 1. is allowed by candid, but not by scientific
+ handle_trailing_perdiod s =
+ if not (null s) && last s == '.' then s ++ "0" else s
+
+valueP :: Parser Value
+valueP = choice
+ [ parens annValueP
+ , NumV <$> numP
+ , BoolV True <$ k "true"
+ , BoolV False <$ k "false"
+ , TextV <$> textP
+ , NullV <$ k "null"
+ , OptV . Just <$ k "opt" <*> valueP
+ , VecV . V.fromList <$ k "vec" <*> braceSemi annValueP
+ , RecV . resolveShorthand <$ k "record" <*> braceSemi recordFieldValP
+ , uncurry VariantV <$ k "variant" <*> braces variantFieldValP
+ , PrincipalV <$ k "service" <*> withPredicate parsePrincipal textP
+ , BlobV <$ k "blob" <*> blobP
+ ]
+
+variantFieldValP :: Parser (FieldName, Value)
+variantFieldValP = (,) <$> fieldLabelP <*> ((s "=" *> annValueP) <|> pure NullV)
+
+recordFieldValP :: Parser (Word32 -> (FieldName, Value))
+recordFieldValP = choice
+ [ try $ do
+ l <- fieldLabelP
+ s "="
+ v <- annValueP
+ return $ const (l,v)
+ , do
+ v <- annValueP
+ return $ \next -> (hashedField next, v)
+ ]
+
+-- A lexeme
+l :: Parser a -> Parser a
+l x = x <* theVoid
+
+-- The space between a lexeme
+theVoid :: Parser ()
+theVoid = void $ many (space1 <|> comment)
+
+comment :: Parser ()
+comment = lineComment <|> multiLineComment
+
+-- a parser for nested multi-line comments. there might be a nicer way
+multiLineComment :: Parser ()
+multiLineComment = between (string "/*") (string "*/") $
+ void $ many $
+ multiLineComment <|>
+ try (try $ char '*' *> notFollowedBy (char '/')) <|>
+ void (anySingleBut '*')
+
+lineComment :: Parser ()
+lineComment = do
+ void (string "//")
+ void (takeWhileP (Just "character") (/= '\n'))
+ void (char '\n')
+
+-- a symbol
+s :: String -> Parser ()
+s str = void (l (string str)) <?> str
+
+-- a keyword
+k :: String -> Parser ()
+k str = try (void (l (string str <* no)) <?> str)
+ where
+ no = notFollowedBy (satisfy (\c -> isAscii c && isAlphaNum c || c == '_'))
+
+natP :: Parser Natural
+natP = l (read <$> some digitChar <?> "number")
+
+braces :: Parser a -> Parser a
+braces = between (s "{") (s "}")
+braceSemi :: Parser a -> Parser [a]
+braceSemi p = braces $ sepEndBy p (s ";")
+parens :: Parser a -> Parser a
+parens = between (s "(") (s ")")
+parenComma :: Parser a -> Parser [a]
+parenComma p = parens $ sepEndBy p (s ",")
+
+
+-- from https://markkarpov.com/tutorial/megaparsec.html#parse-errors
+withPredicate :: (a -> Either String b) -> Parser a -> Parser b
+withPredicate f p = do
+ o <- getOffset
+ r <- p
+ case f r of
+ Left msg -> parseError (FancyError o (Set.singleton (ErrorFail msg)))
+ Right x -> return x
+
+
+-- | A candid test file
+--
+-- (no support for type definitions yet)
+data CandidTestFile = CandidTestFile
+ { testDefs :: [ DidDef TypeName ]
+ , testTests :: [ CandidTest TypeName ]
+ }
+
+data CandidTest a = CandidTest
+ { testLine :: Int
+ , testAssertion :: TestAssertion
+ , testType :: [Type a]
+ , testDesc :: Maybe T.Text
+ }
+ deriving (Functor, Foldable, Traversable)
+
+data TestInput
+ = FromTextual T.Text
+ | FromBinary BS.ByteString
+
+data TestAssertion
+ = CanParse TestInput
+ | CannotParse TestInput
+ | ParseEq Bool TestInput TestInput
+
+-- | Parses a candid spec test file from a string
+parseCandidTests :: String -> String -> Either String CandidTestFile
+parseCandidTests source = first errorBundlePretty . parse (allInput testFileP) source
+
+testFileP :: Parser CandidTestFile
+testFileP = CandidTestFile <$> defsP <*> sepEndBy testP (s ";")
+
+testP :: Parser (CandidTest TypeName)
+testP = CandidTest
+ <$> (unPos . sourceLine <$> getSourcePos)
+ <* k "assert"
+ <*> testAssertP
+ <*> seqP
+ <*> optional textP
+
+testAssertP :: Parser TestAssertion
+testAssertP = do
+ input1 <- testInputP
+ choice
+ [ CanParse input1 <$ s ":"
+ , CannotParse input1 <$ s "!:"
+ , ParseEq True input1 <$ s "==" <*> testInputP <* s ":"
+ , ParseEq False input1 <$ s "!=" <*> testInputP <* s ":"
+ ]
+
+testInputP :: Parser TestInput
+testInputP = FromTextual <$> textP <|> FromBinary <$> (k "blob" *> blobP)
diff --git a/src/Codec/Candid/Service.hs b/src/Codec/Candid/Service.hs
new file mode 100644
index 0000000..4ed7d36
--- /dev/null
+++ b/src/Codec/Candid/Service.hs
@@ -0,0 +1,74 @@
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FunctionalDependencies #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE ConstraintKinds #-}
+module Codec.Candid.Service where
+
+import qualified Data.Text as T
+import qualified Data.HashMap.Strict as H
+import qualified Data.ByteString.Lazy as BS
+import Data.Row
+import Data.Row.Records
+import Data.Row.Internal
+
+import Codec.Candid.Class
+
+-- | A raw service, operating on bytes
+type RawService m = T.Text -> BS.ByteString -> m BS.ByteString
+type RawMethod m = BS.ByteString -> m BS.ByteString
+
+class CandidMethod (m :: * -> *) f | f -> m where
+ fromMeth :: (forall a. String -> m a) -> f -> RawMethod m
+ toMeth :: (forall a. String -> m a) -> RawMethod m -> f
+
+instance (CandidArg a, CandidArg b, Monad m) => CandidMethod m (a -> m b) where
+ fromMeth onErr m b = case decode b of
+ Left err -> onErr err
+ Right x -> encode <$> m x
+
+ toMeth onErr f x = do
+ b <- f (encode x)
+ case decode b of
+ Left err -> onErr err
+ Right y -> return y
+
+-- | A Candid service. The @r@ describes the type of a 'Rec'.
+type CandidService m r = (Forall r (CandidMethod m), AllUniqueLabels r)
+
+-- | Turns a raw service (function operating on bytes) into a typed Candid service (a record of typed methods). The raw service is typically code that talks over the network.
+toCandidService ::
+ forall m r.
+ CandidService m r =>
+ -- | What to do if the raw service returns unparsable data
+ (forall a. String -> m a) ->
+ RawService m ->
+ Rec r
+toCandidService onErr f = fromLabels @ (CandidMethod m) $ \l ->
+ toMeth onErr (f (toKey l))
+
+-- | Turns a typed candid service into a raw service. Typically used in a framework warpping Candid services.
+fromCandidService ::
+ forall m r.
+ CandidService m r =>
+ -- | What to do if the method name does not exist
+ (forall a. T.Text -> m a) ->
+ -- | What to do when the caller provides unparsable data
+ (forall a. String -> m a) ->
+ Rec r ->
+ RawService m
+fromCandidService notFound onErr r =
+ \meth a -> case H.lookup meth m of
+ Just f -> f a
+ Nothing -> notFound meth
+ where
+ m :: H.HashMap T.Text (RawMethod m)
+ m = eraseToHashMap @(CandidMethod m) (fromMeth onErr) r
diff --git a/src/Codec/Candid/TH.hs b/src/Codec/Candid/TH.hs
new file mode 100644
index 0000000..cdcc703
--- /dev/null
+++ b/src/Codec/Candid/TH.hs
@@ -0,0 +1,156 @@
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+module Codec.Candid.TH
+ ( candid, candidFile, candidType, candidTypeQ
+ , generateCandidDefs
+ ) where
+
+import qualified Data.Map as M
+import qualified Data.Row.Records as R
+import qualified Data.Row.Variants as V
+import qualified Data.Text as T
+import qualified Data.Vector as V
+import Numeric.Natural
+import Data.Word
+import Data.Int
+import Data.Void
+import Data.Foldable
+import Data.Traversable
+import Data.List
+import Data.Graph (stronglyConnComp, SCC(..))
+import Control.Monad
+import qualified Data.ByteString.Lazy as BS
+
+import qualified Language.Haskell.TH.Syntax as TH (Name)
+import Language.Haskell.TH.Quote
+import Language.Haskell.TH.Lib
+import Language.Haskell.TH.Syntax (Q, lookupTypeName, newName, Dec)
+
+import Codec.Candid.Parse
+import Codec.Candid.Data
+import Codec.Candid.Tuples
+import Codec.Candid.Types
+import Codec.Candid.FieldName
+import Codec.Candid.Class (Candid)
+
+-- | This quasi-quoter turns a Candid description into a Haskell type. It assumes a type variable @m@ to be in scope.
+candid :: QuasiQuoter
+candid = QuasiQuoter { quoteExp = err, quotePat = err, quoteDec = err, quoteType = quoteCandidService }
+ where err _ = fail "[candid| … |] can only be used as a type"
+
+-- | As 'candid', but takes a filename
+candidFile :: QuasiQuoter
+candidFile = quoteFile candid
+
+-- | This quasi-quoter turns works on individual candid types, e.g.
+--
+-- > type InstallMode = [candidType| variant {install : null; reinstall : null; upgrade : null}; |]
+candidType :: QuasiQuoter
+candidType = QuasiQuoter { quoteExp = err, quotePat = err, quoteDec = err, quoteType = quoteCandidType }
+ where err _ = fail "[candid| … |] can only be used as a type"
+
+-- | Turns all candid type definitions into newtypes
+-- Used, so far, only in the Candid test suite runner
+generateCandidDefs :: [DidDef TypeName] -> Q ([Dec], TypeName -> Q TH.Name)
+generateCandidDefs defs = do
+ assocs <- for defs $ \(tn, _) -> do
+ thn <- newName ("Candid_" ++ T.unpack tn)
+ return (tn, thn)
+
+ let m = M.fromList assocs
+ let resolve tn = case M.lookup tn m of
+ Just thn -> return thn
+ Nothing -> fail $ "Could not find type " ++ T.unpack tn
+ decls <- for defs $ \(tn, t) -> do
+ t' <- traverse resolve t
+ n <- resolve tn
+ dn <- newName ("Candid_" ++ T.unpack tn)
+ newtypeD (cxt []) n [] Nothing
+ (normalC dn [bangType (bang noSourceUnpackedness noSourceStrictness) (typ t')])
+ [derivClause Nothing [conT ''Candid, conT ''Eq]]
+ return (decls, resolve)
+
+-- | Inlines all candid type definitions, after checking for loops
+inlineDefs :: forall k. (Show k, Ord k) => [DidDef k] -> Q (k -> Q (), k -> Type Void)
+inlineDefs defs = do
+ for_ sccs $ \scc ->
+ fail $ "Cyclic type definitions not supported: " ++ intercalate ", " (map show scc)
+ for_ defs $ \(_, t) -> for_ t checkKey
+ return (checkKey, f)
+ where
+ sccs = [ tns | CyclicSCC tns <-
+ stronglyConnComp [ (tn, tn, toList t) | (tn, t) <- defs ] ]
+ f :: k -> Type Void
+ f k = m M.! k
+ m :: M.Map k (Type Void)
+ m = (>>= f) <$> M.fromList defs
+ checkKey tn = unless (tn `M.member` m) $ unboundErr tn
+ unboundErr k = fail $ "Unbound type: " ++ show k
+
+
+quoteCandidService :: String -> TypeQ
+quoteCandidService s = case parseDid s of
+ Left err -> fail err
+ Right DidFile{ service = []} -> [t|R.Empty|]
+ Right DidFile{ defs = ds, service = s} -> do
+ Just m <- lookupTypeName "m"
+ (check, inline) <- inlineDefs ds
+ for_ s $ \m -> for_ m check
+ foldl1 (\a b -> [t|$(a) R..+ $(b)|])
+ [ [t| $(litT (strTyLit (T.unpack methodName)))
+ R..== ($(candidTypeQ params) -> $(varT m) $(candidTypeQ results)) |]
+ | DidMethod{..} <- s
+ , let params = map ((absurd <$>) . (>>= inline)) methodParams
+ , let results = map ((absurd <$>) . (>>= inline)) methodResults
+ ]
+
+quoteCandidType :: String -> TypeQ
+quoteCandidType s = case parseDidType s of
+ Left err -> fail err
+ Right t -> typ (err <$> t)
+ where
+ err s = error $ "Type name in stand-alone Candid type: " ++ T.unpack s
+
+candidTypeQ :: [Type TH.Name] -> TypeQ
+candidTypeQ [] = [t| () |]
+candidTypeQ [NullT] = [t| Unary () |]
+candidTypeQ [t] = typ t
+candidTypeQ ts = foldl appT (tupleT (length ts)) (map typ ts)
+
+
+row :: TypeQ -> TypeQ -> TypeQ -> Fields TH.Name -> TypeQ
+row eq add = foldr (\(fn, t) rest -> [t|
+ $add ($eq $(fieldName fn) $(typ t)) $rest
+ |])
+
+fieldName :: FieldName -> TypeQ
+fieldName f = litT (strTyLit (T.unpack (escapeFieldName f)))
+
+typ :: Type TH.Name -> TypeQ
+typ NatT = [t| Natural |]
+typ Nat8T = [t| Word8 |]
+typ Nat16T = [t| Word16 |]
+typ Nat32T = [t| Word32 |]
+typ Nat64T = [t| Word64 |]
+typ IntT = [t| Integer |]
+typ Int8T = [t| Int8 |]
+typ Int16T = [t| Int16 |]
+typ Int32T = [t| Int32 |]
+typ Int64T = [t| Int64 |]
+typ Float32T = [t| Float |]
+typ Float64T = [t| Double |]
+typ BoolT = [t| Bool |]
+typ TextT = [t| T.Text |]
+typ NullT = [t| () |]
+typ ReservedT = [t| Reserved |]
+typ EmptyT = [t| Void |]
+typ PrincipalT = [t| Principal |]
+typ BlobT = [t| BS.ByteString|]
+typ (OptT t) = [t| Maybe $( typ t ) |]
+typ (VecT t) = [t| V.Vector $( typ t ) |]
+typ (RecT fs) = [t| R.Rec $(row [t| (R..==) |] [t| (R..+) |] [t| R.Empty |] fs) |]
+typ (VariantT fs) = [t| V.Var $(row [t| (V..==) |] [t| (V..+) |] [t| V.Empty |] fs) |]
+typ (RefT v) = conT v
diff --git a/src/Codec/Candid/TestExports.hs b/src/Codec/Candid/TestExports.hs
new file mode 100644
index 0000000..dff9efa
--- /dev/null
+++ b/src/Codec/Candid/TestExports.hs
@@ -0,0 +1,23 @@
+-- | This modules exports internals soley for the purpose of importing them in
+-- the test suite
+module Codec.Candid.TestExports
+ ( module Codec.Candid.Parse
+ , module Codec.Candid.TH
+ ) where
+
+import Codec.Candid.Parse
+ ( CandidTestFile(..)
+ , CandidTest(..)
+ , DidFile(..)
+ , DidMethod(..)
+ , TestInput(..)
+ , TestAssertion(..)
+ , parseCandidTests
+ )
+
+import Codec.Candid.TH
+ ( candidTypeQ
+ , generateCandidDefs
+ )
+
+
diff --git a/src/Codec/Candid/Tuples.hs b/src/Codec/Candid/Tuples.hs
new file mode 100644
index 0000000..8d0bd1a
--- /dev/null
+++ b/src/Codec/Candid/Tuples.hs
@@ -0,0 +1,56 @@
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE TypeFamilyDependencies #-}
+{-# LANGUAGE AllowAmbiguousTypes #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE DefaultSignatures #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE EmptyCase #-}
+{-# LANGUAGE RecursiveDo #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module Codec.Candid.Tuples ( Unary(..), Tuplable, AsTuple, asTuple, fromTuple ) where
+
+import Data.Type.Bool
+
+-- | A newtype to stand in for the unary tuple
+newtype Unary a = Unary {unUnary :: a} deriving (Eq, Show)
+
+type family IsTuple a :: Bool where
+ IsTuple () = 'True
+ IsTuple (Unary t) = 'True
+ IsTuple (_,_) = 'True
+ IsTuple (_,_,_) = 'True
+ IsTuple (_,_,_,_) = 'True
+ IsTuple (_,_,_,_,_) = 'True
+ IsTuple (_,_,_,_,_,_) = 'True
+ IsTuple (_,_,_,_,_,_,_) = 'True
+ IsTuple (_,_,_,_,_,_,_,_) = 'True
+ IsTuple (_,_,_,_,_,_,_,_,_) = 'True
+ IsTuple (_,_,_,_,_,_,_,_,_,_) = 'True
+ IsTuple t = 'False
+
+type AsTuple a = If (IsTuple a) a (Unary a)
+
+class IsTuple a ~ b => AsTuple_ a b where
+ asTuple :: a -> AsTuple a
+ fromTuple :: AsTuple a -> a
+instance IsTuple a ~ 'True => AsTuple_ a 'True where
+ asTuple = id
+ fromTuple = id
+instance IsTuple a ~ 'False => AsTuple_ a 'False where
+ asTuple = Unary
+ fromTuple = unUnary
+
+type Tuplable a = (AsTuple_ a (IsTuple a))
diff --git a/src/Codec/Candid/TypTable.hs b/src/Codec/Candid/TypTable.hs
new file mode 100644
index 0000000..fe16f43
--- /dev/null
+++ b/src/Codec/Candid/TypTable.hs
@@ -0,0 +1,74 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE TypeFamilyDependencies #-}
+{-# LANGUAGE AllowAmbiguousTypes #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE RecursiveDo #-}
+{-# LANGUAGE OverloadedLabels #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# OPTIONS -Wno-orphans #-}
+module Codec.Candid.TypTable where
+
+import qualified Data.Map as M
+import Control.Monad.State.Lazy
+import Data.Void
+import Data.Text.Prettyprint.Doc
+import Data.DList (singleton, DList)
+import Data.Graph
+import Data.Foldable
+
+import Codec.Candid.Types
+
+data SeqDesc where
+ SeqDesc :: forall k. (Pretty k, Ord k) => M.Map k (Type k) -> [Type k] -> SeqDesc
+
+instance Pretty SeqDesc where
+ pretty (SeqDesc m ts) = pretty (M.toList m, ts)
+
+data Ref k f = Ref k (f (Ref k f))
+
+buildSeqDesc :: forall k. (Pretty k, Ord k) => [Type (Ref k Type)] -> SeqDesc
+buildSeqDesc ts = SeqDesc m ts'
+ where
+ (ts', m) = runState (mapM (mapM go) ts) mempty
+
+ go :: Ref k Type -> State (M.Map k (Type k)) k
+ go (Ref k t) = do
+ seen <- gets (M.member k)
+ unless seen $ mdo
+ modify (M.insert k t')
+ t' <- mapM go t
+ return ()
+ return k
+
+voidEmptyTypes :: SeqDesc -> SeqDesc
+voidEmptyTypes (SeqDesc m ts) = SeqDesc m' ts
+ where
+ edges = [ (k,k, toList (underRec t)) | (k,t) <- M.toList m ]
+ sccs = stronglyConnComp edges
+ bad = concat [ xs | CyclicSCC xs <- sccs ]
+ m' = foldl' (\m k -> M.insert k EmptyT m) m bad
+
+
+underRec :: Type k -> DList k
+underRec (RefT x) = singleton x
+underRec (RecT fs) = foldMap (underRec . snd) fs
+underRec _ = mempty
+
+tieKnot :: SeqDesc -> [Type Void]
+tieKnot (SeqDesc m (ts :: [Type k])) = ts'
+ where
+ f :: k -> Type Void
+ f k = m' M.! k
+ m' :: M.Map k (Type Void)
+ m' = (>>= f) <$> m
+ ts' :: [Type Void]
+ ts' = (>>= f) <$> ts
+
diff --git a/src/Codec/Candid/Types.hs b/src/Codec/Candid/Types.hs
new file mode 100644
index 0000000..aa5a0dc
--- /dev/null
+++ b/src/Codec/Candid/Types.hs
@@ -0,0 +1,268 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE DeriveTraversable #-}
+module Codec.Candid.Types where
+
+import qualified Data.ByteString.Lazy as BS
+import qualified Data.Text as T
+import qualified Data.Vector as V
+import Data.Word
+import Data.Int
+import Numeric.Natural
+import Control.Monad
+import Data.Bifunctor
+import Data.Void
+import Data.Scientific
+import Data.Char
+import Numeric
+
+import Data.Text.Prettyprint.Doc
+
+import Codec.Candid.Data
+import Codec.Candid.FieldName
+
+data Type a
+ -- prim types
+ = NatT | Nat8T | Nat16T | Nat32T | Nat64T
+ | IntT | Int8T | Int16T | Int32T | Int64T
+ | Float32T | Float64T
+ | BoolT
+ | TextT
+ | NullT
+ | ReservedT
+ | EmptyT
+ -- constructors
+ | OptT (Type a)
+ | VecT (Type a)
+ | RecT (Fields a)
+ | VariantT (Fields a)
+ -- reference
+ | PrincipalT
+ -- short-hands
+ | BlobT
+ -- ^ a short-hand for 'VecT' 'Nat8T'
+ -- for recursive types
+ | RefT a -- ^ A reference to a named type
+ deriving (Show, Eq, Ord, Functor, Foldable, Traversable)
+
+tupT :: [Type a] -> Type a
+tupT = RecT . zipWith (\n t -> (hashedField n, t)) [0..]
+
+instance Applicative Type where
+ pure = RefT
+ (<*>) = ap
+
+instance Monad Type where
+ return = pure
+ NatT >>= _ = NatT
+ Nat8T >>= _ = Nat8T
+ Nat16T >>= _ = Nat16T
+ Nat32T >>= _ = Nat32T
+ Nat64T >>= _ = Nat64T
+ IntT >>= _ = IntT
+ Int8T >>= _ = Int8T
+ Int16T >>= _ = Int16T
+ Int32T >>= _ = Int32T
+ Int64T >>= _ = Int64T
+ Float32T >>= _ = Float32T
+ Float64T >>= _ = Float64T
+ BoolT >>= _ = BoolT
+ TextT >>= _ = TextT
+ NullT >>= _ = NullT
+ ReservedT >>= _ = ReservedT
+ EmptyT >>= _ = EmptyT
+ BlobT >>= _ = BlobT
+ PrincipalT >>= _ = PrincipalT
+ OptT t >>= f = OptT (t >>= f)
+ VecT t >>= f = VecT (t >>= f)
+ RecT fs >>= f = RecT (map (second (>>= f)) fs)
+ VariantT fs >>= f = VariantT (map (second (>>= f)) fs)
+ RefT x >>= f = f x
+
+type Fields a = [(FieldName, Type a)]
+
+type Args a = [Type a]
+
+instance Pretty a => Pretty (Type a) where
+ pretty NatT = "nat"
+ pretty Nat8T = "nat8"
+ pretty Nat16T = "nat16"
+ pretty Nat32T = "nat32"
+ pretty Nat64T = "nat64"
+ pretty IntT = "int"
+ pretty Int8T = "int8"
+ pretty Int16T = "int16"
+ pretty Int32T = "int32"
+ pretty Int64T = "int64"
+ pretty Float32T = "float32"
+ pretty Float64T = "float64"
+ pretty BoolT = "bool"
+ pretty TextT = "text"
+ pretty NullT = "null"
+ pretty ReservedT = "reserved"
+ pretty EmptyT = "empty"
+ pretty (OptT t) = "opt" <+> pretty t
+ pretty (VecT t) = "vec" <+> pretty t
+ pretty (RecT fs) = "record" <+> prettyFields False fs
+ pretty (VariantT fs) = "variant" <+> prettyFields True fs
+ pretty (RefT a) = pretty a
+ pretty BlobT = "blob"
+ pretty PrincipalT = "principal"
+
+ prettyList = encloseSep lparen rparen (comma <> space) . map pretty
+
+prettyFields :: Pretty a => Bool -> Fields a -> Doc ann
+prettyFields in_variant fs = prettyBraceSemi $ map (prettyField in_variant) fs
+
+prettyBraceSemi :: [Doc ann] -> Doc ann
+prettyBraceSemi = braces . hsep . punctuate semi
+
+prettyField :: Pretty a => Bool -> (FieldName, Type a) -> Doc ann
+prettyField True (f, NullT) = pretty f
+prettyField _ (f, t) = pretty f <+> colon <+> pretty t -- TODO: encode field names
+
+data Value
+ = NumV Scientific -- used when parsing at an unknown numeric type
+ | NatV Natural
+ | Nat8V Word8
+ | Nat16V Word16
+ | Nat32V Word32
+ | Nat64V Word64
+ | IntV Integer
+ | Int8V Int8
+ | Int16V Int16
+ | Int32V Int32
+ | Int64V Int64
+ | Float32V Float
+ | Float64V Double
+ | BoolV Bool
+ | TextV T.Text
+ | NullV
+ | ReservedV
+ | OptV (Maybe Value)
+ | VecV (V.Vector Value)
+ | RecV [(FieldName, Value)]
+ | TupV [Value]
+ | VariantV FieldName Value
+ | PrincipalV Principal
+ | BlobV BS.ByteString
+ | AnnV Value (Type Void)
+ deriving (Eq, Ord, Show)
+
+instance Pretty Value where
+ pretty (NumV v) = pretty (show v)
+ pretty (NatV v) = pretty v
+ pretty (IntV v) | v >= 0 = "+" <> pretty v
+ | otherwise = pretty v
+ pretty (Nat8V v) = prettyAnn v Nat8T
+ pretty (Nat16V v) = prettyAnn v Nat16T
+ pretty (Nat32V v) = prettyAnn v Nat32T
+ pretty (Nat64V v) = prettyAnn v Nat64T
+ pretty (Int8V v) = prettyAnn v Int8T
+ pretty (Int16V v) = prettyAnn v Int16T
+ pretty (Int32V v) = prettyAnn v Int32T
+ pretty (Int64V v) = prettyAnn v Int64T
+ pretty (Float32V v) = prettyAnn v Float32T
+ pretty (Float64V v) = prettyAnn v Float64T
+ pretty (BoolV True) = "true"
+ pretty (BoolV False) = "false"
+ pretty (TextV v) = prettyText v
+ pretty NullV = "null"
+ pretty ReservedV = prettyAnn ("null"::T.Text) ReservedT
+ pretty (PrincipalV b) = "service" <+> prettyText (prettyPrincipal b)
+ pretty (BlobV b) = "blob" <+> prettyBlob b
+ pretty (OptV Nothing) = pretty NullV
+ pretty (OptV (Just v)) = "opt" <+> pretty v
+ pretty (VecV vs) = "vec" <+> prettyBraceSemi (map pretty (V.toList vs))
+ pretty (TupV vs) = "record" <+> prettyBraceSemi (map pretty vs)
+ pretty (RecV vs) = "record" <+> prettyBraceSemi (map go vs)
+ where go (fn, v) = pretty fn <+> "=" <+> pretty v
+ pretty (VariantV f NullV) = "variant" <+> braces (pretty f)
+ pretty (VariantV f v) = "variant" <+> braces (pretty f <+> "=" <+> pretty v)
+ pretty (AnnV v t) = prettyAnn v t
+
+ prettyList = encloseSep lparen rparen (comma <> space) . map pretty
+
+prettyAnn :: Pretty a => a -> Type Void -> Doc ann
+prettyAnn v t = parens $ pretty v <+> ":" <+> pretty t
+
+prettyBlob :: BS.ByteString -> Doc ann
+prettyBlob = dquotes . pretty . T.concat . map go . BS.unpack
+ where
+ go b | fromIntegral b == ord '\t' = "\\t"
+ go b | fromIntegral b == ord '\n' = "\\n"
+ go b | fromIntegral b == ord '\r' = "\\r"
+ go b | fromIntegral b == ord '"' = "\\\""
+ go b | fromIntegral b == ord '\'' = "\\\'"
+ go b | fromIntegral b == ord '\\' = "\\\\"
+ go b | b >= 0x20 && b < 0x7f = T.singleton (chr (fromIntegral b))
+ go b | b < 0x10 = "\\0" <> T.pack (showHex b "")
+ go b = "\\" <> T.pack (showHex b "")
+
+prettyText :: T.Text -> Doc ann
+prettyText = dquotes . pretty . T.concatMap go
+ where
+ go '\t' = "\\t"
+ go '\n' = "\\n"
+ go '\r' = "\\r"
+ go '"' = "\\\""
+ go '\'' = "\\\'"
+ go '\\' = "\\\\"
+ go c | isControl c = "\\u{" <> T.pack (showHex (ord c) "") <> "}"
+ go c = T.singleton c
+
+tupV :: [Value] -> Value
+tupV = RecV . zipWith (\n t -> (hashedField n, t)) [0..]
+
+
+-- Put here because used for both decoding and encoding
+primTyp :: Integer -> Maybe (Type a)
+primTyp (-1) = Just NullT
+primTyp (-2) = Just BoolT
+primTyp (-3) = Just NatT
+primTyp (-4) = Just IntT
+primTyp (-5) = Just Nat8T
+primTyp (-6) = Just Nat16T
+primTyp (-7) = Just Nat32T
+primTyp (-8) = Just Nat64T
+primTyp (-9) = Just Int8T
+primTyp (-10) = Just Int16T
+primTyp (-11) = Just Int32T
+primTyp (-12) = Just Int64T
+primTyp (-13) = Just Float32T
+primTyp (-14) = Just Float64T
+primTyp (-15) = Just TextT
+primTyp (-16) = Just ReservedT
+primTyp (-17) = Just EmptyT
+primTyp (-24) = Just PrincipalT
+primTyp _ = Nothing
+
+-- | A candid service, as a list of methods with argument and result types
+--
+-- (no support for annotations like query yet)
+data DidMethod a = DidMethod
+ { methodName :: T.Text
+ , methodParams :: [Type a]
+ , methodResults :: [Type a]
+ }
+ deriving (Eq, Show, Functor, Foldable, Traversable)
+type TypeName = T.Text
+type DidService a = [ DidMethod a ]
+type DidDef a = (a, Type a)
+data DidFile = DidFile
+ { defs :: [ DidDef TypeName ]
+ , service :: DidService TypeName
+ }
+ deriving (Eq, Show)
+
+instance Pretty a => Pretty (DidMethod a) where
+ pretty (DidMethod name params results) =
+ pretty name <+> colon <+> pretty params <+> "->" <+> pretty results <> semi
+
+prettyDef :: Pretty a => DidDef a -> Doc ann
+prettyDef (tn, t) = "type" <+> pretty tn <+> "=" <+> pretty t <> semi
+
+instance Pretty DidFile where
+ pretty (DidFile defs s) = vsep $
+ (prettyDef <$> defs) ++
+ [ "service" <+> ":" <+> braces (group (align (vsep $ pretty <$> s))) ]
+
diff --git a/test/SpecTests.hs b/test/SpecTests.hs
new file mode 100644
index 0000000..bff76db
--- /dev/null
+++ b/test/SpecTests.hs
@@ -0,0 +1,100 @@
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+module SpecTests (specTests) where
+
+import qualified Data.Text as T
+import qualified Data.ByteString.Lazy as BS
+import Test.Tasty
+import Test.Tasty.HUnit
+import System.Environment
+import System.Directory
+import System.FilePath
+import System.IO
+import System.Exit
+import Data.Traversable
+import Language.Haskell.TH
+import Language.Haskell.TH.Syntax
+
+import Codec.Candid
+import Codec.Candid.TestExports
+
+-- WARNING: Big Template Haskell mess ahead
+$(do
+ candid_tests <- runIO (lookupEnv "CANDID_TESTS") >>= \case
+ Nothing -> do
+ runIO $ [] <$ putStrLn "CANDID_TESTS not set, will not run candid spec test"
+ Just dir -> do
+ files <- runIO $ listDirectory dir
+ sequence
+ [ do addDependentFile file
+ content <- runIO $ readFile file
+ case parseCandidTests file content of
+ Left err -> runIO $ do
+ hPutStrLn stderr $ "Failed to parse " ++ file ++ ":"
+ hPutStrLn stderr err
+ exitFailure
+ Right x -> return (name, x)
+ | basename <- files
+ , let file = dir </> basename
+ , Just name <- pure $ T.stripSuffix ".test.did" (T.pack basename)
+ -- , name /= "construct" -- for now
+ ]
+ (decls, testGroups) <- fmap unzip $ for candid_tests $ \(name, testfile) -> do
+ (decls, resolve) <- generateCandidDefs (testDefs testfile)
+ tests <- traverse (traverse resolve) (testTests testfile)
+ testGroup <-
+ [| testGroup ("File " ++ $(liftString (T.unpack name))) $(listE
+ [ [| testCase name $( case testAssertion of
+ CanParse i1 -> [|
+ case $(parseInput i1) of
+ Right _ -> return ()
+ Left err -> assertFailure $ "unexpected decoding error:\n" ++ err
+ |]
+ CannotParse i1 -> [|
+ case $(parseInput i1) of
+ Right _ -> assertFailure "unexpected decoding success"
+ Left _ -> return ()
+ |]
+ ParseEq exp i1 i2 -> [|
+ case ($(parseInput i1), $(parseInput i2)) of
+ (Right v1, Right v2) ->
+ if exp then assertBool "values differ" (v1 == v2)
+ else assertBool "values do not differ" (v1 /= v2)
+ (Left err, _) ->
+ assertFailure $ "unexpected decoding error (left arg):\n" ++ err
+ (_, Left err) ->
+ assertFailure $ "unexpected decoding error (right arg):\n" ++ err
+ |]
+ )|]
+ | CandidTest{..} <- tests
+ , let name = "[l" ++ show testLine ++ "]" ++
+ case testDesc of
+ Nothing -> ""
+ Just dsc -> " " ++ T.unpack dsc
+ , let parseInput (FromBinary blob) =
+ [| decode @ $(candidTypeQ testType) (BS.pack $(lift (BS.unpack blob))) |]
+ parseInput (FromTextual txt) =
+ [| parseValues $(liftString (T.unpack txt)) >>= fromCandidVals @ $(candidTypeQ testType) |]
+ ])
+ |]
+ return (decls, testGroup)
+
+ -- no [d| … |] here, it seems
+ let n = mkName "specTests"
+ d1 <- sigD n [t|TestTree|]
+ d2 <- valD (varP n) (normalB [|
+ testGroup "Candid spec tests" $(listE (map return testGroups))
+ |]) []
+ return $ concat decls ++ [d1, d2]
+ )
diff --git a/test/THTests.hs b/test/THTests.hs
new file mode 100644
index 0000000..4876855
--- /dev/null
+++ b/test/THTests.hs
@@ -0,0 +1,51 @@
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE OverloadedLabels #-}
+{-# LANGUAGE QuasiQuotes #-}
+
+module THTests (thTests) where
+
+import qualified Data.Text as T
+import Test.Tasty
+import Test.Tasty.HUnit
+import Data.Row
+
+import Codec.Candid
+
+thTests :: TestTree
+thTests = testGroup "Using TH interface"
+ [ testCase "demo1: direct" $ do
+ x <- greet1 .! #greet $ "World"
+ x @?= "Hello World"
+ , testCase "demo1: via toCandidService" $ do
+ x <- greet2 .! #greet $ "World"
+ x @?= "World"
+ , testCase "demo2" $ do
+ x <- demo2 .! #greet $ ("World", True)
+ x @?= "WorldTrue"
+ , testCase "demo3" $ do
+ x <- demo3 .! #greet $ ("World", True)
+ x @?= "WorldTrue"
+ ]
+
+-- NB: Fields in the wrong order
+type Demo1 m = [candid|service : { "greet": (text) -> (text); "a" : () -> () } |]
+
+greet1 :: Monad m => Rec (Demo1 m)
+greet1 = #a .== (\() -> return ()) .+ #greet .== (\who -> return $ "Hello " <> who)
+
+greet2 :: forall m. Monad m => Rec (Demo1 m)
+greet2 = toCandidService error (\_ x -> return x)
+
+type Demo2 m = [candid| service : { "greet": (text, bool) -> (text); } |]
+
+demo2 :: Monad m => Rec (Demo2 m)
+demo2 = #greet .== \(who, b) -> return $ who <> T.pack (show b)
+
+-- NB type definitions:
+type Demo3 m = [candid| type t = text; service : { "greet": (t, bool) -> (t); } |]
+
+demo3 :: Monad m => Rec (Demo3 m)
+demo3 = demo2
+
diff --git a/test/test.hs b/test/test.hs
new file mode 100644
index 0000000..7cac10e
--- /dev/null
+++ b/test/test.hs
@@ -0,0 +1,400 @@
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE AllowAmbiguousTypes #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DerivingVia #-}
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE OverloadedLabels #-}
+
+{-# OPTIONS_GHC -Wno-orphans #-}
+
+import qualified Data.Text as T
+import qualified Data.ByteString.Lazy as BS
+import qualified Data.ByteString.Lazy.Char8 as B
+import qualified Data.ByteString.Builder as B
+import qualified Data.Vector as V hiding (singleton)
+import Test.Tasty
+import Test.Tasty.Ingredients.Rerun
+import Test.Tasty.HUnit
+import Test.Tasty.SmallCheck
+import Test.SmallCheck.Series
+import Data.Void
+import Data.Either
+import GHC.Int
+import GHC.Word
+import Numeric.Natural
+import Control.Monad
+import GHC.Generics (Generic)
+import Data.Text.Prettyprint.Doc
+import Data.Row
+import Data.Proxy
+import qualified Data.Row.Records as R
+import qualified Data.Row.Variants as V
+
+import Codec.Candid
+import Codec.Candid.TestExports
+
+import THTests (thTests)
+import SpecTests (specTests)
+
+main :: IO ()
+main = defaultMainWithRerun tests
+
+newtype Peano = Peano (Maybe Peano)
+ deriving (Show, Eq)
+ deriving Candid via (Maybe Peano)
+
+peano :: Peano
+peano = Peano $ Just $ Peano $ Just $ Peano $ Just $ Peano Nothing
+
+newtype LinkedList a = LinkedList (Maybe (a, LinkedList a))
+ deriving (Show, Eq)
+ deriving newtype Candid
+
+cons :: a -> LinkedList a -> LinkedList a
+cons x y = LinkedList $ Just (x, y)
+nil :: LinkedList a
+nil = LinkedList Nothing
+
+natList :: LinkedList Natural
+natList = cons 1 (cons 2 (cons 3 (cons 4 nil)))
+
+stringList :: [T.Text]
+stringList = [T.pack "HI", T.pack "Ho"]
+
+newtype ARecord a = ARecord { foo :: a }
+ deriving (Eq, Show, Generic)
+ deriving anyclass (Serial m)
+
+deriving via (AsRecord (ARecord a))
+ instance Candid a => Candid (ARecord a)
+
+data EmptyRecord = EmptyRecord
+ deriving (Eq, Show, Generic, Serial m)
+ deriving Candid via (AsRecord EmptyRecord)
+
+newtype MiddleField a = MiddleField a
+ deriving (Eq, Show)
+
+instance Candid a => Candid (MiddleField a) where
+ type AsCandid (MiddleField a) = Rec ("_1_" .== a)
+ toCandid (MiddleField x) = #_1_ .== x
+ fromCandid r = MiddleField (r .! #_1_)
+
+newtype JustRight a = JustRight a
+ deriving (Eq, Show)
+
+instance Candid a => Candid (JustRight a) where
+ type AsCandid (JustRight a) = Var ("Right" .== a)
+ toCandid (JustRight x) = V.singleton (Label @"Right") x
+ fromCandid = JustRight . snd . V.unSingleton
+
+data SimpleRecord = SimpleRecord { foo :: Bool, bar :: Word8 }
+ deriving (Generic, Eq, Show)
+ deriving (Serial m)
+ deriving Candid via (AsRecord SimpleRecord)
+
+roundTripTest :: forall a. (CandidArg a, Eq a, Show a) => a -> Assertion
+roundTripTest v1 = do
+ let bytes1 = encode v1
+ v2 <- case decode @a bytes1 of
+ Left err -> assertFailure err
+ Right v -> return v
+ assertEqual "values" v1 v2
+
+subTypProp :: forall a b. (CandidArg a, Serial IO a, Show a, CandidArg b) => TestTree
+subTypProp = testProperty desc $ \v ->
+ isRight $ decode @b (encode @a v)
+ where
+ desc = show $ pretty (tieKnot (seqDesc @a)) <+> "<:" <+> pretty (tieKnot (seqDesc @b))
+
+subTypeTest' :: forall a b.
+ (CandidArg a, Eq a, Show a) =>
+ (CandidArg b, Eq b, Show b) =>
+ a -> b -> Assertion
+subTypeTest' v1 v2 = do
+ let bytes1 = encode v1
+ v2' <- case decode @b bytes1 of
+ Left err -> assertFailure err
+ Right v -> return v
+ v2 @=? v2'
+
+subTypeTest :: forall a b.
+ (CandidArg a, Eq a, Show a) =>
+ (CandidArg b, Eq b, Show b) =>
+ a -> b -> Assertion
+subTypeTest v1 v2 = do
+ subTypeTest' v1 v2
+ -- now try the other direction
+ let bytes2 = encode v2
+ case decode @a bytes2 of
+ Left _err -> return ()
+ Right _ -> assertFailure "converse subtype test succeeded"
+
+instance Monad m => Serial m T.Text where
+ series = T.pack <$> series
+
+instance (Monad m, Serial m a) => Serial m (V.Vector a) where
+ series = V.fromList <$> series
+
+instance Monad m => Serial m Void where
+ series = mzero
+
+parseTest :: HasCallStack => String -> DidFile -> TestTree
+parseTest c e = testCase c $
+ case parseDid c of
+ Left err -> assertFailure err
+ Right s -> s @?= e
+
+printTestType :: forall a. (Candid a, HasCallStack) => String -> TestTree
+printTestType e = testCase e $
+ show (pretty (typeDesc @a)) @?= e
+
+printTestSeq :: forall a. (CandidArg a, HasCallStack) => String -> TestTree
+printTestSeq e = testCase e $
+ show (pretty (tieKnot (seqDesc @a))) @?= e
+
+roundTripTestGroup :: String ->
+ (forall a. (CandidArg a, Serial IO a, Show a, Eq a) => a -> Either String a) ->
+ TestTree
+roundTripTestGroup group_desc roundtrip =
+ withSomeTypes ("roundtrip (" <> group_desc <> ")") $ \(Proxy :: Proxy a) ->
+ let desc = show $ pretty (tieKnot (seqDesc @a)) in
+ testProperty desc $ \v ->
+ case roundtrip @a v of
+ Right y | y == v -> Right ("all good" :: String)
+ Right y -> Left $
+ show v ++ " round-tripped to " ++ show y
+ Left err -> Left $
+ show v ++ " failed to decode:\n" ++ err
+
+withSomeTypes ::
+ String ->
+ (forall a. (CandidArg a, Serial IO a, Show a, Eq a) => Proxy a -> TestTree) ->
+ TestTree
+withSomeTypes groupName mkTest =
+ testGroup groupName
+ [ mkTest (Proxy @Bool)
+ , mkTest (Proxy @Natural)
+ , mkTest (Proxy @Word8)
+ , mkTest (Proxy @Word16)
+ , mkTest (Proxy @Word32)
+ , mkTest (Proxy @Word64)
+ , mkTest (Proxy @Integer)
+ , mkTest (Proxy @Int8)
+ , mkTest (Proxy @Int16)
+ , mkTest (Proxy @Int32)
+ , mkTest (Proxy @Int64)
+ , mkTest (Proxy @Float)
+ , mkTest (Proxy @Double)
+ , mkTest (Proxy @T.Text)
+ , mkTest (Proxy @())
+ , mkTest (Proxy @Reserved)
+ , mkTest (Proxy @Principal)
+ , mkTest (Proxy @BS.ByteString)
+ , mkTest (Proxy @(Maybe T.Text))
+ , mkTest (Proxy @(V.Vector T.Text))
+ , mkTest (Proxy @EmptyRecord)
+ , mkTest (Proxy @(ARecord T.Text))
+ , mkTest (Proxy @(Either Bool T.Text))
+ , mkTest (Proxy @SimpleRecord)
+ , mkTest (Proxy @(Rec ("a" .== Bool .+ "b" .== Bool .+ "c" .== Bool)))
+ , mkTest (Proxy @(V.Var ("upgrade" .== () .+ "reinstall" .== () .+ "install" .== ())))
+ ]
+
+tests :: TestTree
+tests = testGroup "tests"
+ [ specTests
+ , testGroup "encode tests"
+ [ testCase "empty" $ encode () @?= B.pack "DIDL\0\0"
+ , testCase "bool" $ encode (Unary True) @?= B.pack "DIDL\0\1\x7e\1"
+ ]
+ , testGroup "decode error message"
+ [ testCase "simple mismatch" $ fromCandidVals @(Unary ()) (toCandidVals True) @?= Left "Cannot coerce true into null"
+ , testCase "missing variant" $ fromCandidVals @(Either () ()) (toCandidVals (V.singleton #foo ())) @?= Left "Unexpected tag foo"
+ , testCase "error in variant" $ fromCandidVals @(Either () ()) (toCandidVals (Left @Bool @() True)) @?= Left "Cannot coerce true into null"
+ ]
+ , testGroup "roundtrip"
+ [ testCase "empty" $ roundTripTest ()
+ , testCase "bool" $ roundTripTest $ Unary True
+ , testCase "simple record 1" $ roundTripTest (ARecord True, False)
+ , testCase "simple record 2" $ roundTripTest (ARecord (100000 :: Natural), False)
+ , testCase "simple variant 1" $ roundTripTest $ Unary (Left True :: Either Bool Bool)
+ , testCase "simple variant 2" $ roundTripTest $ Unary (Right False :: Either Bool Bool)
+ , testCase "nested record 2" $ roundTripTest (ARecord (True,False), False)
+ , testCase "peano" $ roundTripTest $ Unary peano
+ , testCase "lists" $ roundTripTest (natList, stringList)
+ , testCase "custom record" $ roundTripTest $ Unary (SimpleRecord True 42)
+ ]
+ , testGroup "subtypes"
+ [ testCase "nat/int" $ subTypeTest (Unary (42 :: Natural)) (Unary (42 :: Integer))
+ , testCase "null/opt" $ subTypeTest (Unary ()) (Unary (Nothing @Integer))
+ , testCase "rec" $ subTypeTest (ARecord True, True) (EmptyRecord, True)
+ , testCase "tuple" $ subTypeTest ((42::Integer,-42::Integer), 100::Integer) (EmptyRecord, 100::Integer)
+ , testCase "variant" $ subTypeTest' (JustRight (42 :: Natural), True) (Right 42 :: Either Bool Natural, True)
+ , testCase "rec/any" $ subTypeTest (ARecord True, True) (Reserved, True)
+ , testCase "tuple/any" $ subTypeTest ((42::Integer, 42::Natural), True) (Reserved, True)
+ , testCase "tuple/tuple" $ subTypeTest ((42::Integer,-42::Integer,True), 100::Integer) ((42::Integer, -42::Integer), 100::Integer)
+ , testCase "tuple/middle" $ subTypeTest ((42::Integer,-42::Integer,True), 100::Integer) (MiddleField (-42) :: MiddleField Integer, 100::Integer)
+ , testCase "records" $ subTypeTest (Unary (SimpleRecord True 42)) (Unary (ARecord True))
+ ]
+
+ , roundTripTestGroup "Haskell → Candid → Haskell" $ \(v :: a) ->
+ decode @a (encode @a v)
+ , roundTripTestGroup "Haskell → [Value] → Haskell" $ \(v :: a) ->
+ fromCandidVals (toCandidVals @a v)
+ , roundTripTestGroup "Haskell → [Value] → Candid → Haskell" $ \(v :: a) ->
+ encodeDynValues (toCandidVals @a v) >>= decode @a . B.toLazyByteString
+ , roundTripTestGroup "Haskell → [Value] → Textual → [Value] → Haskell" $ \(v :: a) ->
+ parseValues (show (pretty (toCandidVals @a v))) >>= fromCandidVals @a
+ , roundTripTestGroup "Haskell → [Value] → Textual → [Value] → Candid → Haskell" $ \(v :: a) ->
+ parseValues (show (pretty (toCandidVals @a v))) >>= encodeDynValues >>= decode @a . B.toLazyByteString
+
+ , testGroup "subtype smallchecks"
+ [ subTypProp @Natural @Natural
+ , subTypProp @(Rec ("Hi" .== Word8 .+ "_1_" .== Word8)) @Reserved
+ , subTypProp @(Rec ("Hi" .== Word8 .+ "_1_" .== Word8)) @(Rec ("Hi" .== Reserved))
+ , subTypProp @(Rec ("Hi" .== Word8 .+ "_1_" .== Word8)) @(Rec ("Hi" .== Word8))
+ , subTypProp @(Rec ("Hi" .== Word8 .+ "_1_" .== Word8)) @(Rec ("_1_" .== Word8))
+ , subTypProp @(Rec ("Hi" .== Word8 .+ "_1_" .== Word8 .+ "_2_" .== Bool)) @(Rec ("_1_" .== Word8))
+ , subTypProp @(Maybe (Rec ("Hi" .== Word8 .+ "_1_" .== Word8 .+ "_0_" .== Bool))) @(Maybe (Bool,Word8))
+ , subTypProp @(Var ("Hi" .== Word8)) @(Var ("Hi" .== Word8 .+ "Ho" .== T.Text))
+ , subTypProp @(Var ("Ho" .== T.Text)) @(Var ("Hi" .== Word8 .+ "Ho" .== T.Text))
+ , subTypProp @Natural @Reserved
+ , subTypProp @BS.ByteString @Reserved
+ , subTypProp @BS.ByteString @(V.Vector Word8)
+ , subTypProp @(V.Vector Word8) @BS.ByteString
+ , subTypProp @Principal @Reserved
+ ]
+ , testGroup "candid type printing" $
+ [ printTestType @Bool "bool"
+ , printTestType @Integer "int"
+ , printTestType @Natural "nat"
+ , printTestType @Int8 "int8"
+ , printTestType @Word8 "nat8"
+ , printTestType @SimpleRecord "record {bar : nat8; foo : bool}"
+ , printTestType @(JustRight T.Text) "variant {Right : text}"
+ , printTestSeq @() "()"
+ , printTestSeq @(Unary ()) "(null)"
+ , printTestSeq @(Unary (Bool, Bool)) "(record {0 : bool; 1 : bool})"
+ , printTestSeq @((),()) "(null, null)"
+ , printTestSeq @(Bool,Bool) "(bool, bool)"
+ , printTestSeq @(Bool,(Bool, Bool)) "(bool, record {0 : bool; 1 : bool})"
+ , printTestSeq @Bool "(bool)"
+ ]
+ , testGroup "candid value printing" $
+ let t :: Value -> String -> TestTree
+ t v e = testCase e $ show (pretty v) @?= e
+ in
+ [ t (BoolV True) "true"
+ , t (BoolV False) "false"
+ , t (NatV 1) "1"
+ , t (IntV 1) "+1"
+ , t (IntV 0) "+0"
+ , t (IntV (-1)) "-1"
+ , t (Nat8V 1) "(1 : nat8)"
+ , t (RecV [("bar", TextV "baz")]) "record {bar = \"baz\"}"
+ , t (PrincipalV (Principal "")) "service \"aaaaa-aa\""
+ , t (PrincipalV (Principal "\xab\xcd\x01")) "service \"em77e-bvlzu-aq\""
+ , t (PrincipalV (Principal "\xde\xad\xbe\xef")) "service \"psokg-ww6vw-7o6\""
+ ]
+ , testGroup "candid value printing (via binary) " $
+ let t :: forall a. (HasCallStack, CandidArg a) => a -> String -> TestTree
+ t v e = testCase e $ do
+ let bytes = encode v
+ vs <- either assertFailure return $ decodeVals bytes
+ show (pretty vs) @?= e
+ in
+ [ t True "(true)"
+ , t (SimpleRecord False 42) "(record {4895187 = (42 : nat8); 5097222 = false})"
+ , t (JustRight (Just (3 :: Natural))) "(variant {2089909180 = opt 3})"
+ , t (JustRight (3 :: Word8)) "(variant {2089909180 = (3 : nat8)})"
+ , t () "()"
+ , t (Unary ()) "(null)"
+ , t (Unary (True, False)) "(record {true; false})"
+ , t (Unary (True, (True, False))) "(record {true; record {true; false}})"
+ , t (#_0_ .== True .+ #_1_ .== False) "(record {true; false})"
+ ]
+
+ , testGroup "dynamic values (AST)" $
+ let t :: forall a. (HasCallStack, CandidArg a, Eq a, Show a) => String -> a -> TestTree
+ t s e = testCase s $ do
+ bytes <- either assertFailure return $ encodeTextual s
+ x <- either assertFailure return $ decode @a bytes
+ x @?= e
+
+ t' :: HasCallStack => String -> TestTree
+ t' s = testCase ("Bad: " <> s) $ do
+ vs <- either assertFailure return $ parseValues s
+ case encodeDynValues vs of
+ Left _err -> return ()
+ Right _ -> assertFailure "Ill-typed value encoded?"
+ in
+ [ t "true" True
+ , t "false" False
+ , t "1" (1 :: Natural)
+ , t "1 : nat8" (1 :: Word8)
+ , t "record { bar = \"baz\" }" (#bar .== ("baz":: T.Text))
+ , t "vec {}" (V.fromList [] :: V.Vector Void)
+ , t "vec {4; +4}" (V.fromList [4 :: Integer,4])
+ , t "vec {4; null : reserved}" (V.fromList [Reserved, Reserved])
+ , t "vec {record {}; record {0 = true}}" (V.fromList [R.empty, R.empty])
+ , t "vec {variant {a = true}; variant {b = null}}"
+ (V.fromList [IsJust #a True, IsJust #b () :: V.Var ("a" V..== Bool V..+ "b" V..== ())])
+ , t "\"hello\"" ("hello" :: T.Text)
+ , t "blob \"hello\"" ("hello" :: BS.ByteString)
+ , t "blob \"\\00\\ff\"" ("\x00\xff" :: BS.ByteString)
+ , t' "vec {true; 4}"
+ ]
+
+ , testGroup "candid type parsing"
+ [ parseTest "service : {}" $
+ DidFile [] []
+ , parseTest "service : { foo : (text) -> (text) }" $
+ DidFile [] [ DidMethod "foo" [TextT] [TextT] ]
+ , parseTest "service : { foo : (text,) -> (text,); }" $
+ DidFile [] [ DidMethod "foo" [TextT] [TextT] ]
+ , parseTest "service : { foo : (opt text) -> () }" $
+ DidFile [] [ DidMethod "foo" [OptT TextT] [] ]
+ , parseTest "service : { foo : (record { text; blob }) -> () }" $
+ DidFile [] [ DidMethod "foo" [RecT [(hashedField 0, TextT), (hashedField 1, BlobT)]] [] ]
+ , parseTest "service : { foo : (record { x_ : null; 5 : nat8 }) -> () }" $
+ DidFile [] [ DidMethod "foo" [RecT [("x_", NullT), (hashedField 5, Nat8T)]] [] ]
+ , parseTest "service : { foo : (record { x : null; 5 : nat8 }) -> () }" $
+ DidFile [] [ DidMethod "foo" [RecT [("x", NullT), (hashedField 5, Nat8T)]] [] ]
+ , parseTest "type t = int; service : { foo : (t) -> (t) }" $
+ DidFile [("t", IntT)] [ DidMethod "foo" [RefT "t"] [RefT "t"] ]
+ ]
+ , thTests
+ , testProperty "field name escaping round-tripping" $ \e ->
+ let f = either labledField hashedField e in
+ let f' = unescapeFieldName (escapeFieldName f) in
+ f' == f
+ ]
+
+instance Monad m => Serial m BS.ByteString where
+ series = BS.pack <$> series
+
+instance Monad m => Serial m Principal where
+ series = Principal <$> series
+
+instance Monad m => Serial m Reserved where
+ series = Reserved <$ series @m @()
+
+instance (Monad m, Forall r (Serial m), AllUniqueLabels r) => Serial m (Rec r) where
+ series = R.fromLabelsA @(Serial m) (\_l -> series)
+
+instance (Monad m, Forall r (Serial m), AllUniqueLabels r) => Serial m (Var r) where
+ series = V.fromLabels @(Serial m) (\_l -> series)