diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,94 @@ +# 0.9.4 +* [#289](https://github.com/awakesecurity/proto3-suite/pull/289) Support optional fields + * Support optional fields (outside of a `oneof`). Such fields are allowed + by newer versions of the proto3 specification (and even recommended by it). + * Correctly prohibit `map` and `repeated` fields within a `oneof` + (and continue to prohibit `optional` fields within a `oneof`). + * [BREAKING CHANGE in experimental module: When encoding a `oneof` field, the `field` + method now expects `Maybe a` or `Identity a` where it used to expect plain `a`. + Similarly, any instantiation of `FieldForm` for `Singular Alternative` should be + changed to specify `Optional` instead, and must wrap the argument type in `Identity`. + The type-level descriptions of cardinality have been reorganized to better reflect + standard terminology and encoding: `...Repetition...` -> `...Cardinality...`, + `Singular Implicit` -> `Implicit`, `Singular Alternative` -> `Optional`. + The `Omission` type is no longer needed and has been removed.] + * When using `field` to encode an `optional` or `oneof` field that in practice + is always present, you may now replace the `Just` data constructor with + the `Identity` newtype constructor in order to express that fact. When + extending `FieldForm` at type `Optional`, define the instance for `Identity` + because the general `Maybe` instance delegates to `Identity` in the `Just` case. + +# 0.9.3 +* [#284](https://github.com/awakesecurity/proto3-suite/pull/284) Delete Repeated.hs + * [BREAKING CHANGE in experimental module: Rename `Prefix` to `FieldsEncoder`, along with related functions.] + * [BREAKING CHANGE in experimental module: Rename `Fields` to `FieldsEncoding`, along with related functions.] + * Add instances of `FromJSON`, `FromJSONPB`, `ToJSON`, `ToJSONPB` + for `MessageEncoding` and `MessageEncoder`. +* [#290](https://github.com/awakesecurity/proto3-suite/pull/290) + * Support tasty-1.5 + * Drop support for GHC 9.2 +* [#291](https://github.com/awakesecurity/proto3-suite/pull/291) Optimize isDefault instances + +# 0.9.2 +* [#282](https://github.com/awakesecurity/proto3-suite/pull/282) Show MessageEncoder + * [BREAKING CHANGE in experimental module: Rename `toLazyByteString` to `messageEncoderToLazyByteString`.] + * [BREAKING CHANGE in experimental module: Rename `cacheMessage` to `messageCache`.] + * [BREAKING CHANGE in experimental module: Delete `Eq` instance for `MessageEncoding` because it is application-defined whether we should ignore field order during comparison.] + * Add `Show` instance for `MessageEncoder`. + * Add `messageEncoderToByteString` and `unsafeByteStringToMessageEncoder`. +* [#283](https://github.com/awakesecurity/proto3-suite/pull/283) Delete Repeated.hs + * Delete unused experimental source file `src/Proto3/Suite/Form/Encode/Repeated.hs`; + proto3-wire provides the relevant functionality in `Proto3.Wire.Encode.Repeated`. + +# 0.9.1 +* [#275](https://github.com/awakesecurity/proto3-suite/pull/275) the `canonicalize-proto-file` executable no longer depends on the [`range-set-list](https://github.com/phadej/range-set-list#readme) package for normalizing reserved field ranges. +* Relocated orphaned [`Pretty`](https://hackage.haskell.org/package/pretty-1.1.3.6/docs/Text-PrettyPrint-HughesPJClass.html#t:Pretty) instances for AST types to [`Proto3.Suite.DotProto.AST`]. + +# 0.9.0 +* [#272](https://github.com/awakesecurity/proto3-suite/pull/272) removed support for `large-records` and `large-generics`. +* [#274](https://github.com/awakesecurity/proto3-suite/pull/274) Support aeson-2.2. +* [#276](https://github.com/awakesecurity/proto3-suite/pull/276) + * Switch dependency from `ghc` to `ghc-lib-parser` + * Drop support for GHC 9.0. + +# 0.8.3 +* Fix overlong encoding of packed "sint32" fields containing elements in + [-0x80000000, -0x40000001] or [0x40000000, 0x7FFFFFFF], which increased + message size and hindered forward compatibility of "sint32" with "sint64". +* Add "--stringType" as a preferred spelling of "--string-type" + because its style matches that of other options. +* Add compiler error "RedefinedFields". +* Export codeFromEnumerated and codeToEnumerated. +* Add an experimental feature to encode without using + intermediate data structures; see Proto3.Suite.Form and + the new compile-proto-file option --typeLevelFormat + +# 0.8.2 +* Support GHC 9.10. +* Test with nixpkgs-24.11. + +# 0.8.1 +* Fix support for dhall-1.42. +* Support dhall on GHC 9.8. +* Fix aeson upper bound in library target (was correct in test target). +* Fix default compiler version in shell.nix. +* Test with GHC 9.8.2 instead of GHC 9.8.1 and GHC 9.6.5 instead of GHC 9.6.2. +* Test with nixpkgs-24.05 but always using aeson-2.1.2.1. + +# 0.8.0 +* [BREAKING CHANGE: Use "ghc" library in place of "haskell-src".] + The "ghc" library is now used to parse and print Haskell source code. + Switching to "ghc" adds support for language features beyond Haskell 98 + and should improve diagnostic messages for sources specified with + "--extraInstanceFile". Breakage should be limited to users of: + * Proto3.Suite.DotProto.Generate + * Proto3.Suite.DotProto.Generate.LargeRecord + * Proto3.Suite.DotProto.Generate.Syntax +* Drop support for GHC 8.10. +* On Darwin, drop support for GHC 9.0. +* Add support for GHC 9.6 (without large-records). +* Add support for GHC 9.8 (without large-records, dhall). + # 0.7.0 * Support GHC 9.2, 9.4. * Support proto files without a package declaration. diff --git a/proto3-suite.cabal b/proto3-suite.cabal --- a/proto3-suite.cabal +++ b/proto3-suite.cabal @@ -1,6 +1,6 @@ cabal-version: 2.2 name: proto3-suite -version: 0.7.0 +version: 0.9.4 synopsis: A higher-level API to the proto3-wire library description: This library provides a higher-level API to @@ -17,12 +17,19 @@ license: Apache-2.0 author: Arista Networks maintainer: Arista Networks -copyright: 2017-2020 Awake Security, 2021-2022 Arista Networks +copyright: 2017-2020 Awake Security, 2021-2025 Arista Networks category: Codec build-type: Simple -data-files: test-files/*.bin tests/encode.sh tests/decode.sh -extra-source-files: CHANGELOG.md, gen/.gitignore +data-files: + test-files/*.bin + tests/encode.sh + tests/decode.sh + +extra-source-files: + CHANGELOG.md, + gen/.gitignore + flag dhall Description: Turn on Dhall interpret and inject codegen Default: False @@ -38,21 +45,42 @@ Default: False Manual: True -flag large-records - Description: Generate records with smaller core code size using the large-records library +flag attoparsec-aeson + Description: Depend upon the Haskell package "attoparsec-aeson". Default: True - Manual: True + Manual: False + -- "Manual: False" to automatically skip "attoparsec-aeson" if it is not available +flag development + Description: Enable development-specific options. + Default: False + Manual: True + source-repository head type: git location: https://github.com/awakesecurity/proto3-suite common common + default-language: Haskell2010 default-extensions: - DeriveDataTypeable DeriveGeneric + BlockArguments ExplicitNamespaces DeriveDataTypeable DeriveGeneric + ImportQualifiedPost ViewPatterns + if flag(development) + ghc-options: + -Werror + + build-depends: + base >=4.15 && <5.0 + , proto3-wire >= 1.4.6 && < 1.5 + + ghc-options: + -O2 + -Wall + library - import: common + import: common + hs-source-dirs: src if flag(dhall) exposed-modules: Proto3.Suite.DhallPB @@ -60,89 +88,91 @@ cpp-options: -DDHALL if flag(swagger) - exposed-modules: Proto3.Suite.DotProto.Generate.Swagger - Proto3.Suite.DotProto.Generate.Swagger.Wrappers - build-depends: swagger2 >=2.1.6 && <2.9 - cpp-options: -DSWAGGER + build-depends: + swagger2 >=2.1.6 && <2.9 + + cpp-options: + -DSWAGGER + + exposed-modules: + Proto3.Suite.DotProto.Generate.Swagger + Proto3.Suite.DotProto.Generate.Swagger.Wrappers + if flag(swagger-wrapper-format) - hs-source-dirs: src/swagger-wrapper-format + hs-source-dirs: src/swagger-wrapper-format else - hs-source-dirs: src/no-swagger-wrapper-format + hs-source-dirs: src/no-swagger-wrapper-format - if flag(large-records) - -- large-records support uses newer Dhall APIs. So we need at least 1.34. - build-depends: dhall >=1.34 && < 1.43, - large-generics, - large-records - cpp-options: -DLARGE_RECORDS + exposed-modules: + Proto3.Suite + Proto3.Suite.Class + Proto3.Suite.DotProto + Proto3.Suite.DotProto.AST + Proto3.Suite.DotProto.AST.Lens + Proto3.Suite.DotProto.Generate + Proto3.Suite.DotProto.Generate.Record + Proto3.Suite.DotProto.Generate.Syntax + Proto3.Suite.DotProto.Parsing + Proto3.Suite.DotProto.Rendering + Proto3.Suite.Form + Proto3.Suite.Form.Encode + Proto3.Suite.JSONPB + Proto3.Suite.Tutorial + Proto3.Suite.Types - exposed-modules: Proto3.Suite - Proto3.Suite.Class - Proto3.Suite.DotProto - Proto3.Suite.DotProto.Generate - Proto3.Suite.DotProto.Generate.LargeRecord - Proto3.Suite.DotProto.Generate.Record - Proto3.Suite.DotProto.Generate.Syntax - Proto3.Suite.DotProto.AST - Proto3.Suite.DotProto.AST.Lens - Proto3.Suite.DotProto.Parsing - Proto3.Suite.DotProto.Rendering - Proto3.Suite.JSONPB - Proto3.Suite.Tutorial - Proto3.Suite.Types + Google.Protobuf.Timestamp + Google.Protobuf.Wrappers.Polymorphic - Google.Protobuf.Timestamp - Google.Protobuf.Wrappers.Polymorphic + Proto3.Suite.DotProto.Internal + Proto3.Suite.Haskell.Parser + Proto3.Suite.JSONPB.Class - Proto3.Suite.DotProto.Internal - Proto3.Suite.JSONPB.Class + other-modules: + Proto3.Suite.Form.Encode.Core + Turtle.Compat - other-modules: Turtle.Compat + build-depends: + aeson >= 1.1.1.0 && < 2.3 + , aeson-pretty >= 0.8.10 && < 0.9 + , attoparsec >= 0.13.0.1 && < 0.15 + , base64-bytestring >= 1.0.0.1 && < 1.3 + , binary >=0.8.3 && <= 0.9 + , bytestring >=0.10.6.0 && <0.13 + , deepseq >=1.4 && <1.6 + , cereal >= 0.5.1 && <0.6 + , containers >=0.5 && <0.8 + , contravariant >=1.4 && <1.6 + , filepath >= 1.5.2 && < 1.6 + , foldl >= 1.4.18 && < 1.5 + , ghc-lib-parser >=9.2.8 && <9.13 + , hashable >= 1.4.7 && < 1.5 + , insert-ordered-containers >= 0.2.7 && < 0.3 + , lens >= 5.3.5 && < 5.4 + , mtl >=2.2 && <2.4 + , neat-interpolation >= 0.5.1 && < 0.6 + , parsec >= 3.1.9 && <3.2 + , parsers >= 0.12 && <0.13 + , pretty ==1.1.* + , pretty-show >= 1.6.12 && < 2 + , QuickCheck >=2.10 && <2.17 + , quickcheck-instances >=0.3.26 && < 0.4 + , safe ==0.3.* + , split >= 0.2.5 && < 0.3 + , system-filepath >= 0.4.14 && < 0.5 + , template-haskell >=2.17 && <2.24 + , text >= 0.2 && <2.2 + , text-short >=0.1.3 && <0.2 + , time >= 1.12.2 && < 1.13 + , transformers >=0.4 && <0.7 + , turtle < 1.6.0 || >= 1.6.1 && < 1.7 + , vector >=0.11 && <0.14 - build-depends: aeson >= 1.1.1.0 && < 2.2, - aeson-pretty, - attoparsec >= 0.13.0.1, - base >=4.8 && <5.0, - base64-bytestring >= 1.0.0.1 && < 1.3, - binary >=0.8.3, - bytestring >=0.10.6.0 && <0.12.0, - deepseq ==1.4.*, - cereal >= 0.5.1 && <0.6, - containers >=0.5 && < 0.7, - contravariant >=1.4 && <1.6, - filepath, - foldl, - hashable, - haskell-src ==1.0.*, - insert-ordered-containers, - lens, - mtl ==2.2.*, - neat-interpolation, - parsec >= 3.1.9 && <3.2.0, - parsers >= 0.12 && <0.13, - pretty ==1.1.*, - pretty-show >= 1.6.12 && < 2.0, - proto3-wire >= 1.2.2 && < 1.5, - QuickCheck >=2.10 && <2.15, - quickcheck-instances >=0.3.26 && < 0.4, - safe ==0.3.*, - split, - system-filepath, - time, - text >= 0.2 && <2.1, - text-short >=0.1.3 && <0.2, - transformers >=0.4 && <0.6, - turtle < 1.6.0 || >= 1.6.1 && < 1.7.0, - vector >=0.11 && < 0.13 - if !impl(ghc >= 8.0) - build-depends: semigroups >= 0.18 && < 0.20 - hs-source-dirs: src - default-language: Haskell2010 - ghc-options: -O2 -Wall + if flag(attoparsec-aeson) + build-depends: + attoparsec-aeson >= 2.2.0.0 && < 2.3 test-suite tests import: common - default-language: Haskell2010 type: exitcode-stdio-1.0 main-is: Main.hs @@ -150,6 +180,8 @@ gen tests + cpp-options: -DTYPE_LEVEL_FORMAT + if flag(dhall) other-modules: TestDhall build-depends: dhall >=1.13 && < 1.43 @@ -161,92 +193,94 @@ if flag(swagger-wrapper-format) cpp-options: -DSWAGGER_WRAPPER_FORMAT - if flag(large-records) - build-depends: large-generics, - large-records - cpp-options: -DLARGE_RECORDS - autogen-modules: TestProto TestProtoImport + TestProtoNegativeEnum + TestProtoNestedMessage TestProtoOneof TestProtoOneofImport + TestProtoOptional TestProtoWrappers - TestProtoNestedMessage other-modules: ArbitraryGeneratedTestTypes TestCodeGen TestProto TestProtoImport - TestProtoOneof - TestProtoOneofImport - TestProtoWrappers --TestProtoLeadingDot + TestProtoNegativeEnum TestProtoNestedMessage + TestProtoOneof + TestProtoOneofImport + TestProtoOptional --TestProtoProtocPlugin + TestProtoWrappers Test.Proto.Generate.Name Test.Proto.Generate.Name.Gen + Test.Proto.Parse + Test.Proto.Parse.Core + Test.Proto.Interval Test.Proto.Parse.Gen Test.Proto.Parse.Option + Test.Proto.ToEncoder build-depends: - aeson >= 1.1.1.0 && < 2.2 + aeson , attoparsec >= 0.13.0.1 - , base >=4.8 && <5.0 , base64-bytestring >= 1.0.0.1 && < 1.3 - , bytestring >=0.10.6.0 && <0.12.0 + , bytestring >=0.10.6.0 && <0.13 , cereal >= 0.5.1 && <0.6 - , containers >=0.5 && < 0.7 - , deepseq ==1.4.* + , containers >=0.5 && <0.8 + , deepseq >=1.4 && <1.6 , doctest , generic-arbitrary + , ghc-lib-parser >= 9.10.2 && < 9.11 , hedgehog - , mtl ==2.2.* + , mtl >=2.2 && <2.4 , parsec >= 3.1.9 && <3.2.0 , pretty ==1.1.* , pretty-show >= 1.6.12 && < 2.0 , proto3-suite - , proto3-wire >= 1.2 && < 1.5 - , QuickCheck >=2.10 && <2.15 + , QuickCheck >=2.10 && <2.17 , record-hasfield - , tasty >= 0.11 && <1.5 + , tasty >= 0.11 && <1.6 , tasty-hedgehog , tasty-hunit >= 0.9 && <0.11 - , tasty-quickcheck >= 0.8.4 && <0.11 - , text >= 0.2 && <2.1 + , tasty-quickcheck >= 0.8.4 && <0.12 + , text >= 0.2 && <2.2 , text-short >=0.1.3 && <0.2 - , transformers >=0.4 && <0.6 - , turtle - , vector >=0.11 && < 0.13 - - if !impl(ghc >= 8.0) - build-depends: semigroups >= 0.18 && < 0.20 - ghc-options: -O2 -Wall + , transformers >=0.4 && <0.7 + , turtle < 1.6.0 || >= 1.6.1 && < 1.7 + , vector >=0.11 && <0.14 executable compile-proto-file - main-is: Main.hs - hs-source-dirs: tools/compile-proto-file - default-language: Haskell2010 - build-depends: base >=4.12 && <5.0 - , optparse-applicative - , proto3-suite - , system-filepath - , text - , turtle - ghc-options: -O2 -Wall + main-is: Main.hs + hs-source-dirs: tools/compile-proto-file + default-language: Haskell2010 + build-depends: + base >=4.15 && <5.0 + , ghc-lib-parser >= 9.10.2 && < 9.11 + , optparse-applicative >= 0.18.1 && < 0.19 + , proto3-suite + , system-filepath >= 0.4.14 && < 0.5 + , text >= 2.1.1 && < 2.2 + , turtle < 1.6.0 || >= 1.6.1 && < 1.7 + + ghc-options: + -O2 + -Wall + executable canonicalize-proto-file - main-is: Main.hs - hs-source-dirs: tools/canonicalize-proto-file - default-language: Haskell2010 - build-depends: base >=4.11.0.0 && <5.0 - , containers >=0.5 && <0.7 - , mtl ==2.2.* - , optparse-generic - , proto3-suite - , proto3-wire >= 1.2 && <1.5 - , range-set-list >=0.1.2 && <0.2 - , system-filepath - , turtle - ghc-options: -O2 -Wall + import: common + main-is: Main.hs + hs-source-dirs: tools/canonicalize-proto-file + + build-depends: + containers >=0.5 && <0.8 + , mtl >=2.2 && <2.4 + , optparse-generic >= 1.5.2 && < 1.6 + , proto3-suite + , system-filepath >= 0.4.14 && < 0.5 + , turtle < 1.6.0 || >= 1.6.1 && < 1.7 diff --git a/src/Google/Protobuf/Wrappers/Polymorphic.hs b/src/Google/Protobuf/Wrappers/Polymorphic.hs --- a/src/Google/Protobuf/Wrappers/Polymorphic.hs +++ b/src/Google/Protobuf/Wrappers/Polymorphic.hs @@ -5,6 +5,7 @@ {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +-- | Haskell types used to express standard protobuf wrapper message types. module Google.Protobuf.Wrappers.Polymorphic ( Wrapped(..) ) where diff --git a/src/Proto3/Suite/Class.hs b/src/Proto3/Suite/Class.hs --- a/src/Proto3/Suite/Class.hs +++ b/src/Proto3/Suite/Class.hs @@ -34,7 +34,7 @@ -- -- = Strings -- --- Use 'TL.Text' instead of 'String' for string types inside messages. +-- Use 'TL.Text' instead of `Prelude.String` for string types inside messages. -- -- = Example -- @@ -88,6 +88,7 @@ , fromB64 , coerceOver , unsafeCoerceOver + , ZigZag(..) -- * Documentation , Named(..) @@ -99,11 +100,15 @@ , GenericMessage(..) ) where +#if !MIN_VERSION_base(4,18,0) import Control.Applicative +#endif import Control.Monad +import Data.Bits (Bits, FiniteBits) import qualified Data.ByteString as B import qualified Data.ByteString.Base64 as B64 import qualified Data.ByteString.Lazy as BL +import qualified Data.ByteString.Short as BS import Data.Coerce (Coercible, coerce) import qualified Data.Foldable as Foldable import Data.Functor (($>)) @@ -118,6 +123,7 @@ import qualified Data.Text.Short as TS import qualified Data.Traversable as TR import Data.Vector (Vector) +import qualified Data.Vector as V import Data.Word (Word32, Word64) import GHC.Exts (fromList, Proxy#, proxy#) import GHC.Generics @@ -139,19 +145,6 @@ import qualified Data.Record.Generic.Rep as LG #endif --- | Pass through those values that are outside the enum range; --- this is for forward compatibility as enumerations are extended. -codeFromEnumerated :: ProtoEnum e => Enumerated e -> Int32 -codeFromEnumerated = either id fromProtoEnum . enumerated -{-# INLINE codeFromEnumerated #-} - --- | Values inside the enum range are in Right, the rest in Left; --- this is for forward compatibility as enumerations are extended. -codeToEnumerated :: ProtoEnum e => Int32 -> Enumerated e -codeToEnumerated code = - Enumerated $ maybe (Left code) Right (toProtoEnumMay code) -{-# INLINE codeToEnumerated #-} - -- | A class for types with default values per the protocol buffers spec. class HasDefault a where -- | The default value for this type. @@ -203,29 +196,40 @@ instance HasDefault T.Text where def = mempty + isDefault = T.null deriving via T.Text instance HasDefault (Proto3.Suite.Types.String T.Text) instance HasDefault TL.Text where def = mempty + isDefault = TL.null deriving via TL.Text instance HasDefault (Proto3.Suite.Types.String TL.Text) instance HasDefault TS.ShortText where def = mempty + isDefault = TS.null deriving via TS.ShortText instance HasDefault (Proto3.Suite.Types.String TS.ShortText) instance HasDefault B.ByteString where def = mempty + isDefault = B.null deriving via B.ByteString instance HasDefault (Proto3.Suite.Types.Bytes B.ByteString) instance HasDefault BL.ByteString where def = mempty + isDefault = BL.null deriving via BL.ByteString instance HasDefault (Proto3.Suite.Types.Bytes BL.ByteString) +instance HasDefault BS.ShortByteString where + def = mempty + isDefault = BS.null + +deriving via BS.ShortByteString instance HasDefault (Proto3.Suite.Types.Bytes BS.ShortByteString) + instance ProtoEnum e => HasDefault (Enumerated e) where def = codeToEnumerated 0 isDefault = (== 0) . codeFromEnumerated @@ -234,15 +238,15 @@ instance HasDefault (UnpackedVec a) where def = mempty - isDefault = null . unpackedvec + isDefault = V.null . unpackedvec instance HasDefault (PackedVec a) where def = mempty - isDefault = null . packedvec + isDefault = V.null . packedvec instance HasDefault (NestedVec a) where def = mempty - isDefault = null . nestedvec + isDefault = V.null . nestedvec instance HasDefault (Nested a) where def = Nested Nothing @@ -256,7 +260,7 @@ -- 'PackedVec'/'UnpackedVec' instance HasDefault (Vector a) where def = mempty - isDefault = null + isDefault = V.null -- | Used in generated records to represent an unwrapped 'Nested' instance HasDefault (Maybe a) where @@ -544,6 +548,14 @@ deriving via BL.ByteString instance Primitive (Proto3.Suite.Types.Bytes BL.ByteString) +instance Primitive BS.ShortByteString where + encodePrimitive !num = Encode.shortByteString num + {-# INLINE encodePrimitive #-} + decodePrimitive = Decode.shortByteString + primType _ = Bytes + +deriving via BS.ShortByteString instance Primitive (Proto3.Suite.Types.Bytes BS.ShortByteString) + instance forall e. (Named e, ProtoEnum e) => Primitive (Enumerated e) where encodePrimitive !num = either (Encode.int32 num) (Encode.enum num) . enumerated {-# INLINE encodePrimitive #-} @@ -553,7 +565,7 @@ Decode.enum primType _ = Named (Single (nameOf (proxy# :: Proxy# e))) -instance (Primitive a) => Primitive (ForceEmit a) where +instance Primitive a => Primitive (ForceEmit a) where encodePrimitive !num = encodePrimitive num . forceEmit {-# INLINE encodePrimitive #-} decodePrimitive = coerce @(Parser RawPrimitive a) @(Parser RawPrimitive (ForceEmit a)) decodePrimitive @@ -622,6 +634,8 @@ deriving via B.ByteString instance MessageField (Proto3.Suite.Types.Bytes B.ByteString) instance MessageField BL.ByteString deriving via BL.ByteString instance MessageField (Proto3.Suite.Types.Bytes BL.ByteString) +instance MessageField BS.ShortByteString +deriving via BS.ShortByteString instance MessageField (Proto3.Suite.Types.Bytes BS.ShortByteString) instance (Named e, ProtoEnum e) => MessageField (Enumerated e) instance (Ord k, Primitive k, MessageField k, Primitive v, MessageField v) => MessageField (M.Map k v) where @@ -660,6 +674,12 @@ encodeMessageField !num = encodePrimitive num {-# INLINE encodeMessageField #-} +instance Primitive a => MessageField (Maybe (ForceEmit a)) where + encodeMessageField !num = foldMap (encodePrimitive num) + {-# INLINE encodeMessageField #-} + decodeMessageField = Decode.optional decodePrimitive + protoType _ = messageField (Optional $ primType (proxy# :: Proxy# (ForceEmit a))) Nothing + instance (Named a, Message a) => MessageField (Nested a) where encodeMessageField !num = go op where @@ -741,39 +761,26 @@ instance MessageField (PackedVec (Signed Int32)) where encodeMessageField !fn = - omittingDefault (Encode.packedVarintsV zigZag fn) . coerce @_ @(Vector Int32) + omittingDefault (Encode.packedVarintsV zigZag fn) . packedvec where - zigZag = fromIntegral . Encode.zigZagEncode + zigZag = fromIntegral @Word32 @Word64 . zigZagEncode @Int32 {-# INLINE encodeMessageField #-} -- Let 'Encode.packedVarintsV' figure out how much to inline. - decodeMessageField = decodePacked (fmap (fmap zagZig) Decode.packedVarints) - where - -- This type signature is important: `Decode.zigZagDecode` will not undo - -- `Encode.zigZagEncode` if given a signed value with the high order bit - -- set. So we don't allow GHC to infer a signed input type. - zagZig :: Word32 -> Signed Int32 - zagZig = Signed . fromIntegral . Decode.zigZagDecode + decodeMessageField = decodePacked (fmap (fmap zigZagDecode) Decode.packedVarints) protoType _ = messageField (Repeated SInt32) (Just PackedField) instance MessageField (PackedVec (Signed Int64)) where encodeMessageField !fn = - omittingDefault (Encode.packedVarintsV zigZag fn) . coerce @_ @(Vector Int64) + omittingDefault (Encode.packedVarintsV zigZag fn) . packedvec where - zigZag = fromIntegral . Encode.zigZagEncode + zigZag = zigZagEncode @Int64 {-# INLINE encodeMessageField #-} -- Let 'Encode.packedVarintsV' figure out how much to inline. - decodeMessageField = decodePacked (fmap (fmap zagZig) Decode.packedVarints) - where - -- This type signature is important: `Decode.zigZagDecode` will not undo - -- `Encode.zigZagEncode` if given a signed value with the high order bit - -- set. So we don't allow GHC to infer a signed input type. - zagZig :: Word64 -> Signed Int64 - zagZig = Signed . fromIntegral . Decode.zigZagDecode + decodeMessageField = decodePacked (fmap (fmap zigZagDecode) Decode.packedVarints) protoType _ = messageField (Repeated SInt64) (Just PackedField) - instance MessageField (PackedVec (Fixed Word32)) where encodeMessageField !fn = omittingDefault (Encode.packedFixed32V id fn) . coerce @_ @(Vector Word32) @@ -825,12 +832,16 @@ instance (MessageField e, KnownSymbol comments) => MessageField (e // comments) where encodeMessageField !fn = encodeMessageField fn . unCommented {-# INLINE encodeMessageField #-} + decodeMessageField = coerce @(Parser RawField e) @(Parser RawField (Commented comments e)) decodeMessageField - protoType p = (protoType (lowerProxy1 p)) - { dotProtoFieldComment = symbolVal (lowerProxy2 p) } + + protoType p = field { dotProtoFieldComment = symbolVal (lowerProxy2 p) } where + field :: DotProtoField + field = protoType (lowerProxy1 p) + lowerProxy1 :: forall k f (a :: k). Proxy# (f a) -> Proxy# a lowerProxy1 _ = proxy# @@ -983,6 +994,11 @@ decodeMessage = decodeWrapperMessage dotProto = dotProtoWrapper +instance Message BS.ShortByteString where + encodeMessage = encodeWrapperMessage + decodeMessage = decodeWrapperMessage + dotProto = dotProtoWrapper + -- * Generic Instances class GenericMessage (f :: Type -> Type) where @@ -1020,7 +1036,9 @@ adjust (genericDotProto (proxy# :: Proxy# g)) where offset = fromIntegral $ natVal (Proxy @(GenericFieldCount f)) + adjust = map adjustPart + adjustPart part = part { dotProtoFieldNumber = FieldNumber . (offset +) . getFieldNumber . dotProtoFieldNumber @@ -1059,3 +1077,63 @@ genericEncodeMessage num (M1 x) = genericEncodeMessage num x genericDecodeMessage num = M1 <$> genericDecodeMessage num genericDotProto _ = genericDotProto (proxy# :: Proxy# f) + +class ZigZag a + where + -- | The unsigned integral type used to hold the value + -- after ZigZag encoding but before varint encoding, and + -- after varint decoding but before ZigZag decoding. + -- + -- NOTE: The two integral types must have the same width both to + -- correctly encode large @sint32@ values and, during decoding, + -- to compensate for overlong encodings emitted by versions of + -- this library before v0.8.2. Those older versions incorrectly + -- sign-extended ZigZag-encoded @sint32@ values in packed fields. + type ZigZagEncoded a :: Type + + -- | Importantly, the resulting unsigned integer has the same + -- width as the input type, so that any integral promotion before + -- or during varint encoding will zero-pad instead of sign-extend. + -- + -- Sign extension would result in a more bulky encoding + -- and would violate the compatibility guarantee in + -- that + -- an @sint32@ value can be decoded as if it had type @sint64@. + zigZagEncode :: Signed a -> ZigZagEncoded a + default zigZagEncode :: + (Num a, FiniteBits a, Integral a, Num (ZigZagEncoded a)) => + Signed a -> ZigZagEncoded a + zigZagEncode = fromIntegral . Encode.zigZagEncode . signed + {-# INLINE zigZagEncode #-} + + -- | Importantly, the given unsigned integer has the same width as the result type. + -- If the encoder was a version of this library before v0.8.2, and the field was + -- packed, it would have incorrectly sign-extended between the ZigZag encoding step + -- and the varint encoding step, rather than zero-padding. By narrowing before we + -- ZigZag decode, we exclude the incorrect bits. + -- + -- Maintaining compatibility with versions of this library before v0.8.2 + -- does have a curious side effect. When an @sint64@ value outside the + -- range of @sint32@ is decoded as type @sint32@, the sign will be + -- preserved and the magnitude decreased, rather than the more typical + -- conversion that outputs the remainder after division by @2^32@, as + -- would happen with 'fromIntegral @Int64 @Int32'. One could argue that + -- our behavior is surprising and unusual. However, both narrowings + -- lose information, and neither is supported by protobuf: + -- says, + -- "However, changing a field's message type will break + -- unless the new message is a superset of the old one." + zigZagDecode :: ZigZagEncoded a -> Signed a + default zigZagDecode :: + (Num (ZigZagEncoded a), Bits (ZigZagEncoded a), Integral (ZigZagEncoded a), Num a) => + ZigZagEncoded a -> Signed a + zigZagDecode = Signed . fromIntegral . Decode.zigZagDecode + {-# INLINE zigZagDecode #-} + +instance ZigZag Int32 + where + type ZigZagEncoded Int32 = Word32 + +instance ZigZag Int64 + where + type ZigZagEncoded Int64 = Word64 diff --git a/src/Proto3/Suite/DhallPB.hs b/src/Proto3/Suite/DhallPB.hs --- a/src/Proto3/Suite/DhallPB.hs +++ b/src/Proto3/Suite/DhallPB.hs @@ -30,12 +30,14 @@ import GHC.Float (double2Float, float2Double) import Proto3.Suite.Types (Enumerated (..), Fixed (..)) +#if !(MIN_VERSION_dhall(1,42,0)) import qualified Data.ByteString import qualified Data.ByteString.Base64 import qualified Data.ByteString.Base64.Lazy import qualified Data.ByteString.Lazy import qualified Data.Text.Encoding import qualified Data.Text.Lazy.Encoding +#endif import qualified Dhall #if !(MIN_VERSION_dhall(1,27,0)) @@ -63,6 +65,8 @@ instance Dhall.FromDhall a => Dhall.FromDhall (Either Int32 a) +#if !(MIN_VERSION_dhall(1,42,0)) + -------------------------------------------------------------------------------- -- Interpret the strict and lazy ByteString types -- @@ -80,6 +84,8 @@ where b64Decode = Data.ByteString.Base64.decodeLenient . Data.Text.Encoding.encodeUtf8 +#endif + -------------------------------------------------------------------------------- -- Interpret integer scalar types @@ -182,6 +188,8 @@ instance Dhall.ToDhall Float where injectWith = fmap (contramap float2Double) Dhall.injectWith +#if !(MIN_VERSION_dhall(1,42,0)) + -------------------------------------------------------------------------------- -- Inject strict and lazy ByteStrings -- @@ -204,6 +212,8 @@ -- but we should never encounter that case with this usage -- because we Base64 encode the ByteString first b64Encode = Data.Text.Encoding.decodeUtf8 . Data.ByteString.Base64.encode + +#endif #if !(MIN_VERSION_dhall(1,27,0)) -------------------------------------------------------------------------------- diff --git a/src/Proto3/Suite/DotProto/AST.hs b/src/Proto3/Suite/DotProto/AST.hs --- a/src/Proto3/Suite/DotProto/AST.hs +++ b/src/Proto3/Suite/DotProto/AST.hs @@ -35,6 +35,7 @@ ) where import Control.Applicative +import Data.Char (toLower) import Control.Monad import Data.Data (Data) import Data.Int (Int32) @@ -46,7 +47,11 @@ import Proto3.Wire.Types (FieldNumber (..)) import Test.QuickCheck import Test.QuickCheck.Instances () +import Text.PrettyPrint ((<+>)) +import qualified Text.PrettyPrint as PP +import Text.PrettyPrint.HughesPJClass (Pretty(..)) import Turtle (FilePath) +import Turtle.Compat (encodeString) -- | The name of a message newtype MessageName = MessageName @@ -58,7 +63,7 @@ -- | The name of some field newtype FieldName = FieldName - { getFieldName :: String } + { getFieldName :: String } deriving (Data, Eq, Generic, IsString, Ord) instance Show FieldName where @@ -66,14 +71,14 @@ -- | The name of the package newtype PackageName = PackageName - { getPackageName :: String } + { getPackageName :: String } deriving (Data, Eq, Generic, IsString, Ord) instance Show PackageName where show = show . getPackageName -newtype Path = Path - { components :: NE.NonEmpty String } +newtype Path = Path + { components :: NE.NonEmpty String } deriving (Data, Eq, Generic, Ord, Show) -- Used for testing @@ -87,13 +92,25 @@ | Anonymous -- [recheck] is there a better way to represent unnamed things deriving (Data, Eq, Generic, Ord, Show) +instance Pretty DotProtoIdentifier where + pPrint (Single name) = PP.text name + pPrint (Dots (Path names)) = PP.hcat . PP.punctuate (PP.text ".") $ PP.text <$> NE.toList names + pPrint (Qualified qualifier identifier) = PP.parens (pPrint qualifier) <> PP.text "." <> pPrint identifier + pPrint Anonymous = PP.empty + -- | Top-level import declaration data DotProtoImport = DotProtoImport { dotProtoImportQualifier :: DotProtoImportQualifier , dotProtoImportPath :: FilePath - } + } deriving (Data, Eq, Generic, Ord, Show) +instance Pretty DotProtoImport where + pPrint (DotProtoImport q i) = + PP.text "import" <+> pPrint q <+> strLit fp PP.<> PP.text ";" + where + fp = encodeString i + instance Arbitrary DotProtoImport where arbitrary = do dotProtoImportQualifier <- arbitrary @@ -106,6 +123,11 @@ | DotProtoImportDefault deriving (Bounded, Data, Enum, Eq, Generic, Ord, Show) +instance Pretty DotProtoImportQualifier where + pPrint DotProtoImportDefault = PP.empty + pPrint DotProtoImportPublic = PP.text "public" + pPrint DotProtoImportWeak = PP.text "weak" + instance Arbitrary DotProtoImportQualifier where arbitrary = elements [ DotProtoImportDefault @@ -119,6 +141,10 @@ | DotProtoNoPackage deriving (Data, Eq, Generic, Ord, Show) +instance Pretty DotProtoPackageSpec where + pPrint (DotProtoPackageSpec p) = PP.text "package" <+> pPrint p PP.<> PP.text ";" + pPrint (DotProtoNoPackage) = PP.empty + instance Arbitrary DotProtoPackageSpec where arbitrary = oneof [ return DotProtoNoPackage @@ -132,6 +158,9 @@ , dotProtoOptionValue :: DotProtoValue } deriving (Data, Eq, Generic, Ord, Show) +instance Pretty DotProtoOption where + pPrint (DotProtoOption key value) = pPrint key <+> PP.text "=" <+> pPrint value + instance Arbitrary DotProtoOption where arbitrary = do dotProtoOptionIdentifier <- oneof @@ -168,7 +197,7 @@ { metaModulePath :: Path -- ^ The "module path" associated with the .proto file from which this AST -- was parsed. The "module path" is derived from the `--includeDir`-relative - -- .proto filename passed to 'parseProtoFile'. See + -- .proto filename passed to `Proto3.Suite.DotProto.Parsing.parseProtoFile`. See -- 'Proto3.Suite.DotProto.Internal.toModulePath' for details on how module -- path values are constructed. See -- 'Proto3.Suite.DotProto.Generate.modulePathModName' to see how it is used @@ -199,7 +228,7 @@ protoMeta <- arbitrary return (DotProto {..}) --- | Matches the definition of `constant` in the proto3 language spec +-- | Matches the definition of @constant@ in the proto3 language spec -- These are only used as rvalues data DotProtoValue = Identifier DotProtoIdentifier @@ -209,6 +238,13 @@ | BoolLit Bool deriving (Data, Eq, Generic, Ord, Show) +instance Pretty DotProtoValue where + pPrint (Identifier value) = pPrint value + pPrint (StringLit value) = strLit value + pPrint (IntLit value) = PP.text $ show value + pPrint (FloatLit value) = PP.text $ show value + pPrint (BoolLit value) = PP.text $ toLower <$> show value + instance Arbitrary DotProtoValue where arbitrary = oneof [ fmap Identifier arbitrarySingleIdentifier @@ -238,6 +274,24 @@ -- ^ A named type, referring to another message or enum defined in the same file deriving (Data, Eq, Generic, Ord, Show) +instance Pretty DotProtoPrimType where + pPrint (Named i) = pPrint i + pPrint Int32 = PP.text "int32" + pPrint Int64 = PP.text "int64" + pPrint SInt32 = PP.text "sint32" + pPrint SInt64 = PP.text "sint64" + pPrint UInt32 = PP.text "uint32" + pPrint UInt64 = PP.text "uint64" + pPrint Fixed32 = PP.text "fixed32" + pPrint Fixed64 = PP.text "fixed64" + pPrint SFixed32 = PP.text "sfixed32" + pPrint SFixed64 = PP.text "sfixed64" + pPrint String = PP.text "string" + pPrint Bytes = PP.text "bytes" + pPrint Bool = PP.text "bool" + pPrint Float = PP.text "float" + pPrint Double = PP.text "double" + instance Arbitrary DotProtoPrimType where arbitrary = oneof [ elements @@ -273,11 +327,19 @@ -- are meaningful in every type context. data DotProtoType = Prim DotProtoPrimType + | Optional DotProtoPrimType | Repeated DotProtoPrimType | NestedRepeated DotProtoPrimType | Map DotProtoPrimType DotProtoPrimType deriving (Data, Eq, Generic, Ord, Show) +instance Pretty DotProtoType where + pPrint (Prim ty) = pPrint ty + pPrint (Optional ty) = PP.text "optional" <+> pPrint ty + pPrint (Repeated ty) = PP.text "repeated" <+> pPrint ty + pPrint (NestedRepeated ty) = PP.text "repeated" <+> pPrint ty + pPrint (Map keyty valuety) = PP.text "map<" <> pPrint keyty <> PP.text ", " <> pPrint valuety <> PP.text ">" + instance Arbitrary DotProtoType where arbitrary = oneof [fmap Prim arbitrary] @@ -286,7 +348,7 @@ data DotProtoEnumPart = DotProtoEnumField DotProtoIdentifier DotProtoEnumValue [DotProtoOption] | DotProtoEnumOption DotProtoOption - | DotProtoEnumEmpty + | DotProtoEnumReserved [DotProtoReservedField] deriving (Data, Eq, Generic, Ord, Show) instance Arbitrary DotProtoEnumPart where @@ -307,15 +369,30 @@ | NonStreaming deriving (Bounded, Data, Enum, Eq, Generic, Ord, Show) +instance Pretty Streaming where + pPrint Streaming = PP.text "stream" + pPrint NonStreaming = PP.empty + instance Arbitrary Streaming where arbitrary = elements [Streaming, NonStreaming] data DotProtoServicePart = DotProtoServiceRPCMethod RPCMethod | DotProtoServiceOption DotProtoOption - | DotProtoServiceEmpty deriving (Data, Eq, Generic, Ord, Show) +instance Pretty DotProtoServicePart where + pPrint (DotProtoServiceRPCMethod RPCMethod{..}) + = PP.text "rpc" + <+> pPrint rpcMethodName + <+> PP.parens (pPrint rpcMethodRequestStreaming <+> pPrint rpcMethodRequestType) + <+> PP.text "returns" + <+> PP.parens (pPrint rpcMethodResponseStreaming <+> pPrint rpcMethodResponseType) + <+> case rpcMethodOptions of + [] -> PP.text ";" + _ -> PP.braces . PP.vcat $ serviceOption <$> rpcMethodOptions + pPrint (DotProtoServiceOption option) = serviceOption option + instance Arbitrary DotProtoServicePart where arbitrary = oneof [ DotProtoServiceRPCMethod <$> arbitrary @@ -329,7 +406,7 @@ , rpcMethodResponseType :: DotProtoIdentifier , rpcMethodResponseStreaming :: Streaming , rpcMethodOptions :: [DotProtoOption] - } + } deriving (Data, Eq, Generic, Ord, Show) instance Arbitrary RPCMethod where @@ -386,7 +463,6 @@ , dotProtoFieldOptions :: [DotProtoOption] , dotProtoFieldComment :: String } - | DotProtoEmptyField deriving (Data, Eq, Generic, Ord, Show) instance Arbitrary DotProtoField where @@ -405,6 +481,11 @@ | ReservedIdentifier String deriving (Data, Eq, Generic, Ord, Show) +instance Pretty DotProtoReservedField where + pPrint (SingleField num) = PP.text $ show num + pPrint (FieldRange start end) = (PP.text $ show start) <+> PP.text "to" <+> (PP.text $ show end) + pPrint (ReservedIdentifier i) = PP.text $ show i + instance Arbitrary DotProtoReservedField where arbitrary = oneof [arbitrarySingleField, arbitraryFieldRange] @@ -464,3 +545,15 @@ smallListOf1 :: Gen a -> Gen [a] smallListOf1 x = choose (1, 5) >>= \n -> vectorOf n x + +strLit :: String -> PP.Doc +strLit string = PP.text "\"" <> foldMap escape string <> PP.text "\"" + where + escape '\n' = PP.text "\\n" + escape '\\' = PP.text "\\\\" + escape '\0' = PP.text "\\x00" + escape '"' = PP.text "\\\"" + escape c = PP.text [ c ] + +serviceOption :: DotProtoOption -> PP.Doc +serviceOption o = PP.text "option" <+> pPrint o PP.<> PP.text ";" diff --git a/src/Proto3/Suite/DotProto/Generate.hs b/src/Proto3/Suite/DotProto/Generate.hs --- a/src/Proto3/Suite/DotProto/Generate.hs +++ b/src/Proto3/Suite/DotProto/Generate.hs @@ -4,2054 +4,2322 @@ {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE ViewPatterns #-} - -{-| This module provides functions to generate Haskell declarations for protobuf - messages --} - -module Proto3.Suite.DotProto.Generate - ( CompileError(..) - , StringType(..) - , RecordStyle (..) - , parseStringType - , TypeContext - , CompileArgs(..) - , compileDotProtoFile - , compileDotProtoFileOrDie - , renameProtoFile - , hsModuleForDotProto - , renderHsModuleForDotProto - , readDotProtoWithContext - ) where - -import Control.Applicative -import Control.Lens ((&), ix, over, has, filtered) -import Control.Monad.Except (MonadError(..), runExceptT) -import Control.Monad.IO.Class (MonadIO(..)) -import Data.Char -import Data.Coerce -import Data.Either (partitionEithers) -import Data.List (find, intercalate, nub, sort, sortBy, stripPrefix) -import qualified Data.List.NonEmpty as NE -import Data.List.Split (splitOn) -import Data.List.NonEmpty (NonEmpty (..)) -import qualified Data.Map as M -import Data.Maybe -import Data.Monoid -import Data.Ord (comparing) -import qualified Data.Set as S -import Data.String (fromString) -import qualified Data.Text as T -import Language.Haskell.Parser (ParseResult(..), parseModule) -import Language.Haskell.Pretty -import Language.Haskell.Syntax -import qualified NeatInterpolation as Neat -import Prelude hiding (FilePath) -import Proto3.Suite.DotProto -import Proto3.Suite.DotProto.AST.Lens -import qualified Proto3.Suite.DotProto.Generate.LargeRecord as LargeRecord -import qualified Proto3.Suite.DotProto.Generate.Record as RegularRecord -import Proto3.Suite.DotProto.Generate.Syntax -import Proto3.Suite.DotProto.Internal -import Proto3.Wire.Types (FieldNumber (..)) -import Text.Parsec (Parsec, alphaNum, eof, parse, satisfy, try) -import qualified Text.Parsec as Parsec -import qualified Turtle hiding (encodeString) -import qualified Turtle.Compat as Turtle (encodeString) -import Turtle (FilePath, (), (<.>)) - --- $setup --- >>> :set -XTypeApplications - --------------------------------------------------------------------------------- - --- --- * Public interface --- -data CompileArgs = CompileArgs - { includeDir :: [FilePath] - , extraInstanceFiles :: [FilePath] - , inputProto :: FilePath - , outputDir :: FilePath - , stringType :: StringType - , recordStyle :: RecordStyle - } - -data StringType = StringType String String - -- ^ Qualified module name, then unqualified type name. - -data RecordStyle = RegularRecords | LargeRecords - deriving stock (Eq, Show, Read) - -parseStringType :: String -> Either String StringType -parseStringType str = case splitOn "." str of - xs@(_ : _ : _) -> Right $ StringType (intercalate "." $ init xs) (last xs) - _ -> Left "must be in the form Module.Type" - --- | Generate a Haskell module corresponding to a @.proto@ file -compileDotProtoFile :: CompileArgs -> IO (Either CompileError ()) -compileDotProtoFile CompileArgs{..} = runExceptT $ do - (dotProto, importTypeContext) <- readDotProtoWithContext includeDir inputProto - modulePathPieces <- traverse renameProtoFile (toModuleComponents dotProto) - - let relativePath = foldr combine mempty (map fromString $ NE.toList modulePathPieces) <.> "hs" - combine p1 p2 | p2 == mempty = p1 - combine p1 p2 = p1 p2 - let modulePath = outputDir relativePath - - Turtle.mktree (Turtle.directory modulePath) - - extraInstances <- foldMapM getExtraInstances extraInstanceFiles - haskellModule <- renderHsModuleForDotProto stringType recordStyle extraInstances dotProto importTypeContext - - liftIO (writeFile (Turtle.encodeString modulePath) haskellModule) - where - toModuleComponents :: DotProto -> NonEmpty String - toModuleComponents = components . metaModulePath . protoMeta - --- | Same as 'compileDotProtoFile', except terminates the program with an error --- message on failure. -compileDotProtoFileOrDie :: CompileArgs -> IO () -compileDotProtoFileOrDie args = compileDotProtoFile args >>= \case - Left e -> do - -- TODO: pretty print the error messages - let errText = Turtle.format Turtle.w e - let dotProtoPathText = Turtle.format Turtle.fp (inputProto args) - dieLines [Neat.text| - Error: failed to compile "${dotProtoPathText}": - - ${errText} - |] - _ -> pure () - --- | Renaming protobuf file names to valid Haskell module names. --- --- By convention, protobuf filenames are snake case. 'rnProtoFile' renames --- snake-cased protobuf filenames by: --- --- * Replacing occurrences of one or more underscores followed by an --- alphabetical character with one less underscore. --- --- * Capitalizing the first character following the string of underscores. --- --- ==== __Examples__ --- --- >>> renameProtoFile @(Either CompileError) "abc_xyz" --- Right "AbcXyz" --- --- >>> renameProtoFile @(Either CompileError) "abc_1bc" --- Left (InvalidModuleName "abc_1bc") --- --- >>> renameProtoFile @(Either CompileError) "_" --- Left (InvalidModuleName "_") -renameProtoFile :: MonadError CompileError m => String -> m String -renameProtoFile filename = - case parse parser "" filename of - Left {} -> throwError (InvalidModuleName filename) - Right (nm, ps, sn) -> pure (toUpperFirst nm ++ rename ps ++ sn) - where - rename :: [(String, String)] -> String - rename = foldMap $ \(us, nm) -> - drop 1 us ++ toUpperFirst nm - - parser :: Parsec String () (String, [(String, String)], String) - parser = do - nm <- pName - ps <- Parsec.many (try pNamePart) - sn <- Parsec.many (satisfy (== '_')) - pure (nm, ps, sn) <* eof - - pNamePart :: Parsec String () (String, String) - pNamePart = liftA2 (,) (Parsec.many1 (satisfy (== '_'))) pName - - pName :: Parsec String () String - pName = liftA2 (:) (satisfy isAlpha) (Parsec.many alphaNum) - --- | Compile a 'DotProto' AST into a 'String' representing the Haskell --- source of a module implementing types and instances for the .proto --- messages and enums. -renderHsModuleForDotProto - :: MonadError CompileError m - => StringType - -> RecordStyle - -> ([HsImportDecl],[HsDecl]) -> DotProto -> TypeContext -> m String -renderHsModuleForDotProto stringType recordStyle extraInstanceFiles dotProto importCtxt = do - haskellModule <- hsModuleForDotProto stringType recordStyle extraInstanceFiles dotProto importCtxt - - let languagePragmas = textUnlines $ map (\extn -> "{-# LANGUAGE " <> extn <> " #-}") $ sort extensions - ghcOptionPragmas = textUnlines $ map (\opt -> "{-# OPTIONS_GHC " <> opt <> " #-}") $ sort options - - extensions :: [T.Text] - extensions = - [ "DataKinds" - , "DeriveAnyClass" - , "DeriveGeneric" - , "GADTs" - , "OverloadedStrings" - , "TypeApplications" - ] ++ - case recordStyle of - RegularRecords -> [] - LargeRecords -> [ "ConstraintKinds" - , "FlexibleInstances" - , "MultiParamTypeClasses" - , "ScopedTypeVariables" - , "TypeFamilies" - , "UndecidableInstances" - ] - - options :: [T.Text] - options = [ "-fno-warn-unused-imports" - , "-fno-warn-name-shadowing" - , "-fno-warn-unused-matches" - , "-fno-warn-missing-export-lists" - ] ++ - case recordStyle of - RegularRecords -> [] - LargeRecords -> [ "-fplugin=Data.Record.Plugin" ] - - mkLRAnnotation :: HsDecl -> Maybe T.Text - mkLRAnnotation (HsDataDecl _ _ (HsIdent recName) _ [HsRecDecl _ _ (_fld1:_fld2:_)] _) = - Just ("{-# ANN type " <> T.pack recName <> " largeRecord #-}") - mkLRAnnotation _ = Nothing - - lrAnnotations :: T.Text - lrAnnotations = - case (recordStyle, haskellModule) of - (RegularRecords, _) -> "" - (LargeRecords, HsModule _ _ _ _ moduleDecls) -> - textUnlines (mapMaybe mkLRAnnotation moduleDecls) - - moduleContent :: T.Text - moduleContent = T.pack (prettyPrint haskellModule) - - textUnlines :: [T.Text] -> T.Text - textUnlines = T.intercalate "\n" - - pure $ T.unpack $ [Neat.text| - $languagePragmas - $ghcOptionPragmas - - -- | Generated by Haskell protocol buffer compiler. DO NOT EDIT! - $moduleContent - - $lrAnnotations - |] - --- | Compile a Haskell module AST given a 'DotProto' package AST. --- Instances given in @eis@ override those otherwise generated. -hsModuleForDotProto - :: MonadError CompileError m - => StringType - -- ^ the module and the type for string - -> RecordStyle - -- ^ kind of records to generate - -> ([HsImportDecl], [HsDecl]) - -- ^ Extra user-define instances that override default generated instances - -> DotProto - -- ^ - -> TypeContext - -- ^ - -> m HsModule -hsModuleForDotProto - stringType - recordStyle - (extraImports, extraInstances) - dotProto@DotProto{ protoMeta = DotProtoMeta { metaModulePath = modulePath } - , protoPackage - , protoDefinitions - } - importTypeContext - = do - moduleName <- modulePathModName modulePath - - typeContextImports <- ctxtImports importTypeContext - - let hasService = has (traverse._DotProtoService) protoDefinitions - - let importDeclarations = concat - [ defaultImports recordStyle - ImportCustomisation - { icUsesGrpc = hasService - , icStringType = stringType - } - , extraImports - , typeContextImports ] - - typeContext <- dotProtoTypeContext dotProto - - let toDotProtoDeclaration = - dotProtoDefinitionD stringType recordStyle protoPackage (typeContext <> importTypeContext) - - let extraInstances' = instancesForModule moduleName extraInstances - - decls <- replaceHsInstDecls extraInstances' <$> - foldMapM toDotProtoDeclaration protoDefinitions - - return (module_ moduleName Nothing importDeclarations decls) - -getExtraInstances - :: (MonadIO m, MonadError CompileError m) - => FilePath -> m ([HsImportDecl], [HsDecl]) -getExtraInstances extraInstanceFile = do - - contents <- liftIO (readFile (Turtle.encodeString extraInstanceFile)) - - case parseModule contents of - ParseOk (HsModule _srcloc _mod _es idecls decls) -> do - let isInstDecl HsInstDecl{} = True - isInstDecl _ = False - - return (idecls, filter isInstDecl decls) --TODO give compile result - - ParseFailed srcLoc err -> do - let srcLocText = Turtle.format Turtle.w srcLoc - - let errText = T.pack err - - let message = [Neat.text| - Error: Failed to parse instance file - - ${srcLocText}: ${errText} - |] - - internalError (T.unpack message) - --- | This very specific function will only work for the qualification on the very first type --- in the object of an instance declaration. Those are the only sort of instance declarations --- generated within this code, so it suffices. -instancesForModule :: Module -> [HsDecl] -> [HsDecl] -instancesForModule m = foldr go [] - where go x xs = case x of - HsInstDecl a b c (HsTyCon (Qual tm i):ts) d -> - if m == tm then HsInstDecl a b c (HsTyCon (UnQual i):ts) d:xs else xs - _ -> xs - --- | For each thing in @base@ replaces it if it finds a matching @override@ -replaceHsInstDecls :: [HsDecl] -> [HsDecl] -> [HsDecl] -replaceHsInstDecls overrides base = concatMap mbReplace base - where - -- instances defined separately from data type definition: - mbReplace hid@(HsInstDecl _ _ qn tys _) = - (: []) . fromMaybe hid $ search qn tys - - -- instances listed in "deriving" clause of data type definition: - mbReplace (HsDataDecl loc ctx tyn names def insts) = - let (uncustomized, customized) = partitionEithers (map (deriv tyn) insts) - in HsDataDecl loc ctx tyn names def uncustomized : customized - - -- instances listed in "deriving" clause of newtype definition: - mbReplace (HsNewTypeDecl loc ctx tyn names def insts) = - let (uncustomized, customized) = partitionEithers (map (deriv tyn) insts) - in HsNewTypeDecl loc ctx tyn names def uncustomized : customized - - -- irrelevant declarations remain unchanged: - mbReplace hid = [hid] - - deriv tyn qn = maybe (Left qn) Right $ search qn [HsTyCon (UnQual tyn)] - - search qn tys = find (\x -> Just (unQual qn,tys) == getSig x) overrides - - getSig (HsInstDecl _ _ qn tys _) = Just (unQual qn,tys) - getSig _ = Nothing - - unQual (Qual _ n) = Just n - unQual (UnQual n) = Just n - unQual (Special _) = Nothing - --- | Parses the file at the given path and produces an AST along with a --- 'TypeContext' representing all types from imported @.proto@ files, using the --- first parameter as a list of paths to search for imported files. Terminates --- with exit code 1 when an included file cannot be found in the search path. -readDotProtoWithContext - :: (MonadError CompileError m, MonadIO m) - => [FilePath] - -> FilePath - -> m (DotProto, TypeContext) -readDotProtoWithContext [] toplevelProto = do - -- If we're not given a search path, default to using the current working - -- directory, as `protoc` does - cwd <- Turtle.pwd - readDotProtoWithContext [cwd] toplevelProto - -readDotProtoWithContext searchPaths toplevelProto = do - dp <- importProto searchPaths toplevelProto toplevelProto - let importIt = readImportTypeContext searchPaths toplevelProto (S.singleton toplevelProto) - tc <- foldMapM importIt (protoImports dp) - pure (dp, tc) - --- | Build the type context for an import, resolving transitive imports. -readImportTypeContext - :: (MonadError CompileError m, MonadIO m) - => [FilePath] - -> FilePath - -> S.Set FilePath - -> DotProtoImport - -> m TypeContext -readImportTypeContext searchPaths toplevelFP alreadyRead (DotProtoImport _ path) - | path `S.member` alreadyRead = throwError (CircularImport path) - | otherwise = do - import_ <- importProto searchPaths toplevelFP path - let importPkgSpec = protoPackage import_ - - let fixImportTyInfo tyInfo = - tyInfo { dotProtoTypeInfoPackage = importPkgSpec - , dotProtoTypeInfoModulePath = metaModulePath . protoMeta $ import_ - } - importTypeContext <- fmap fixImportTyInfo <$> dotProtoTypeContext import_ - - let prefixWithPackageName = - case importPkgSpec of - DotProtoPackageSpec packageName -> concatDotProtoIdentifier packageName - DotProtoNoPackage -> pure - - qualifiedTypeContext <- mapKeysM prefixWithPackageName importTypeContext - - let isPublic (DotProtoImport q _) = q == DotProtoImportPublic - transitiveImportsTC <- - foldMapOfM (traverse . filtered isPublic) - (readImportTypeContext searchPaths toplevelFP (S.insert path alreadyRead)) - (protoImports import_) - - pure $ importTypeContext <> qualifiedTypeContext <> transitiveImportsTC - --- | Given a type context, generates the Haskell import statements necessary to --- import all the required types. Excludes module "Google.Protobuf.Wrappers" --- because the generated code does not actually make use of wrapper types --- as such; instead it uses @Maybe a@, where @a@ is the wrapped type. -ctxtImports :: MonadError CompileError m => TypeContext -> m [HsImportDecl] -ctxtImports = - fmap (map mkImport . nub . filter (Module "Google.Protobuf.Wrappers" /=)) - . traverse (modulePathModName . dotProtoTypeInfoModulePath) - . M.elems - where - mkImport modName = importDecl_ modName True Nothing Nothing - --------------------------------------------------------------------------------- --- --- * Helper functions for Haskell code generation --- - --- ** Names - --- | Generate the Haskell type name for a 'DotProtoTypeInfo' for a message / --- enumeration being compiled. NB: We ignore the 'dotProtoTypeInfoPackage' --- field of the 'DotProtoTypeInfo' parameter, instead demanding that we have --- been provided with a valid module path in its 'dotProtoTypeInfoModulePath' --- field. The latter describes the name of the Haskell module being generated. -msgTypeFromDpTypeInfo :: MonadError CompileError m - => TypeContext -> DotProtoTypeInfo -> DotProtoIdentifier -> m HsType -msgTypeFromDpTypeInfo ctxt DotProtoTypeInfo{..} ident = do - modName <- modulePathModName dotProtoTypeInfoModulePath - identName <- qualifiedMessageTypeName ctxt dotProtoTypeInfoParent ident - pure $ HsTyCon (Qual modName (HsIdent identName)) - -modulePathModName :: MonadError CompileError m => Path -> m Module -modulePathModName (Path comps) = Module . intercalate "." <$> traverse typeLikeName (NE.toList comps) - -_pkgIdentModName :: MonadError CompileError m => DotProtoIdentifier -> m Module -_pkgIdentModName (Single s) = Module <$> typeLikeName s -_pkgIdentModName (Dots path) = modulePathModName path -_pkgIdentModName x = throwError (InvalidPackageName x) - - --- ** Dhall - -#ifdef DHALL -hsDhallPB :: String -hsDhallPB = "HsDhallPb" - -dhallPBName :: String -> HsQName -dhallPBName name = Qual (Module hsDhallPB) (HsIdent name) - --- *** Generate Dhall Interpret and Inject generic instances - -fromDhall, toDhall :: String -(fromDhall, toDhall) = -#if MIN_VERSION_dhall(1,27,0) - ("FromDhall", "ToDhall") -#else - ("Interpret", "Inject") -#endif - -dhallInterpretInstDecl :: String -> HsDecl -dhallInterpretInstDecl typeName = - instDecl_ (dhallPBName fromDhall) - [ type_ typeName ] - [ ] - -dhallInjectInstDecl :: String -> HsDecl -dhallInjectInstDecl typeName = - instDecl_ (dhallPBName toDhall) - [ type_ typeName ] - [ ] -#endif - --- ** Helpers to wrap/unwrap types for protobuf (de-)serialization - -data FieldContext = WithinMessage | WithinOneOf - deriving (Eq, Show) - -typeApp :: HsType -> HsExp -typeApp ty = uvar_ ("@("++ pp ty ++ ")") - where - -- Do not add linebreaks to typeapps as that causes parse errors - pp = prettyPrintStyleMode style{mode=OneLineMode} defaultMode - -coerceE :: Bool -> Bool -> HsType -> HsType -> Maybe HsExp -coerceE _ _ from to | from == to = Nothing -coerceE overTyCon unsafe from to = - Just $ HsApp (HsApp coerceF (typeApp from)) (typeApp to) - where - coerceF | unsafe = HsVar (name "unsafeCoerce") - | otherwise = HsVar (name "coerce") - name | overTyCon = protobufName . (<> "Over") - | otherwise = haskellName - -wrapFunE :: MonadError CompileError m => Bool -> FieldContext -> StringType -> TypeContext -> [DotProtoOption] -> DotProtoType -> m (Maybe HsExp) -wrapFunE overTyCon fc stringType ctxt opts dpt = - coerceE overTyCon (isMap dpt) - <$> dptToHsType fc stringType ctxt dpt - <*> dptToHsTypeWrapped fc stringType opts ctxt dpt - -wrapE :: MonadError CompileError m => FieldContext -> StringType -> TypeContext -> [DotProtoOption] -> DotProtoType -> HsExp -> m HsExp -wrapE fc stringType ctxt opts dpt e = - maybeModify e <$> wrapFunE False fc stringType ctxt opts dpt - -unwrapFunE :: MonadError CompileError m => Bool -> FieldContext -> StringType -> TypeContext -> [DotProtoOption] -> DotProtoType -> m (Maybe HsExp) -unwrapFunE overTyCon fc stringType ctxt opts dpt = - coerceE overTyCon (isMap dpt) - <$> dptToHsTypeWrapped fc stringType opts ctxt dpt - <*> dptToHsType fc stringType ctxt dpt - -unwrapE :: MonadError CompileError m => FieldContext -> StringType -> TypeContext -> [DotProtoOption] -> DotProtoType -> HsExp -> m HsExp -unwrapE fc stringType ctxt opts dpt e = do - maybeModify e <$> unwrapFunE True fc stringType ctxt opts dpt - --------------------------------------------------------------------------------- --- --- * Functions to convert 'DotProtoType' into Haskell types --- - --- | Convert a dot proto type to a Haskell type -dptToHsType :: MonadError CompileError m => FieldContext -> StringType -> TypeContext -> DotProtoType -> m HsType -dptToHsType fc = foldDPT (dptToHsContType fc) . dpptToHsType - --- | Convert a dot proto type to a wrapped Haskell type -dptToHsTypeWrapped - :: MonadError CompileError m - => FieldContext - -> StringType - -> [DotProtoOption] - -> TypeContext - -> DotProtoType - -> m HsType -dptToHsTypeWrapped fc stringType opts = - foldDPT - -- The wrapper for the collection type replaces the native haskell - -- collection type, so try that first. - (\ctxt ty -> maybe (dptToHsContType fc ctxt ty) id (dptToHsWrappedContType fc ctxt opts ty)) - -- Always wrap the primitive type. - (dpptToHsTypeWrapped stringType) - --- | Like 'dptToHsTypeWrapped' but without use of --- 'dptToHsContType' or 'dptToHsWrappedContType'. -dpptToHsTypeWrapped - :: MonadError CompileError m - => StringType - -> TypeContext - -> DotProtoPrimType - -> m HsType -dpptToHsTypeWrapped (StringType _ stringType) ctxt = \case - Int32 -> - pure $ primType_ "Int32" - Int64 -> - pure $ primType_ "Int64" - SInt32 -> - pure $ protobufSignedType_ $ primType_ "Int32" - SInt64 -> - pure $ protobufSignedType_ $ primType_ "Int64" - UInt32 -> - pure $ primType_ "Word32" - UInt64 -> - pure $ primType_ "Word64" - Fixed32 -> - pure $ protobufFixedType_ $ primType_ "Word32" - Fixed64 -> - pure $ protobufFixedType_ $ primType_ "Word64" - SFixed32 -> - pure $ protobufSignedType_ $ protobufFixedType_ $ primType_ "Int32" - SFixed64 -> - pure $ protobufSignedType_ $ protobufFixedType_ $ primType_ "Int64" - String -> - pure $ protobufStringType_ stringType - Bytes -> - pure $ protobufBytesType_ "ByteString" - Bool -> - pure $ primType_ "Bool" - Float -> - pure $ primType_ "Float" - Double -> - pure $ primType_ "Double" - Named (Dots (Path ("google" :| ["protobuf", x]))) - | x == "Int32Value" -> - pure $ protobufWrappedType_ $ primType_ "Int32" - | x == "Int64Value" -> - pure $ protobufWrappedType_ $ primType_ "Int64" - | x == "UInt32Value" -> - pure $ protobufWrappedType_ $ primType_ "Word32" - | x == "UInt64Value" -> - pure $ protobufWrappedType_ $ primType_ "Word64" - | x == "StringValue" -> - pure $ protobufWrappedType_ $ protobufStringType_ stringType - | x == "BytesValue" -> - pure $ protobufWrappedType_ $ protobufBytesType_ "ByteString" - | x == "BoolValue" -> - pure $ protobufWrappedType_ $ primType_ "Bool" - | x == "FloatValue" -> - pure $ protobufWrappedType_ $ primType_ "Float" - | x == "DoubleValue" -> - pure $ protobufWrappedType_ $ primType_ "Double" - Named msgName -> - case M.lookup msgName ctxt of - Just ty@(DotProtoTypeInfo { dotProtoTypeInfoKind = DotProtoKindEnum }) -> - HsTyApp (protobufType_ "Enumerated") <$> msgTypeFromDpTypeInfo ctxt ty msgName - Just ty -> msgTypeFromDpTypeInfo ctxt ty msgName - Nothing -> noSuchTypeError msgName - -foldDPT :: MonadError CompileError m - => (TypeContext -> DotProtoType -> HsType -> HsType) - -> (TypeContext -> DotProtoPrimType -> m HsType) - -> TypeContext - -> DotProtoType - -> m HsType -foldDPT dptToHsCont foldPrim ctxt dpt = - let - prim = foldPrim ctxt - go = foldDPT dptToHsCont foldPrim ctxt - cont = dptToHsCont ctxt dpt - in - case dpt of - Prim pType -> cont <$> prim pType - Repeated pType -> cont <$> prim pType - NestedRepeated pType -> cont <$> prim pType - Map k v | validMapKey k -> HsTyApp . cont <$> prim k <*> go (Prim v) -- need to 'Nest' message types - | otherwise -> throwError $ InvalidMapKeyType (show $ pPrint k) - --- | Translate DotProtoType constructors to wrapped Haskell container types --- (for Message serde instances). --- --- When the given 'FieldContext' is 'WithinOneOf' we do not wrap submessages --- in "Maybe" because the entire oneof is already wrapped in a "Maybe". -dptToHsWrappedContType :: FieldContext -> TypeContext -> [DotProtoOption] -> DotProtoType -> Maybe (HsType -> HsType) -dptToHsWrappedContType fc ctxt opts = \case - Prim (Named tyName) - | WithinMessage <- fc, isMessage ctxt tyName - -> Just $ HsTyApp (protobufType_ "Nested") - Repeated (Named tyName) - | isMessage ctxt tyName -> Just $ HsTyApp (protobufType_ "NestedVec") - Repeated ty - | isUnpacked opts -> Just $ HsTyApp (protobufType_ "UnpackedVec") - | isPacked opts -> Just $ HsTyApp (protobufType_ "PackedVec") - | isPackable ctxt ty -> Just $ HsTyApp (protobufType_ "PackedVec") - | otherwise -> Just $ HsTyApp (protobufType_ "UnpackedVec") - _ -> Nothing - --- | Translate DotProtoType to Haskell container types. --- --- When the given 'FieldContext' is 'WithinOneOf' we do not wrap submessages --- in "Maybe" because the entire oneof is already wrapped in a "Maybe". -dptToHsContType :: FieldContext -> TypeContext -> DotProtoType -> HsType -> HsType -dptToHsContType fc ctxt = \case - Prim (Named tyName) | WithinMessage <- fc, isMessage ctxt tyName - -> HsTyApp $ primType_ "Maybe" - Repeated _ -> HsTyApp $ primType_ "Vector" - NestedRepeated _ -> HsTyApp $ primType_ "Vector" - Map _ _ -> HsTyApp $ primType_ "Map" - _ -> id - --- | Convert a dot proto prim type to an unwrapped Haskell type -dpptToHsType :: MonadError CompileError m - => StringType - -> TypeContext - -> DotProtoPrimType - -> m HsType -dpptToHsType (StringType _ stringType) ctxt = \case - Int32 -> pure $ primType_ "Int32" - Int64 -> pure $ primType_ "Int64" - SInt32 -> pure $ primType_ "Int32" - SInt64 -> pure $ primType_ "Int64" - UInt32 -> pure $ primType_ "Word32" - UInt64 -> pure $ primType_ "Word64" - Fixed32 -> pure $ primType_ "Word32" - Fixed64 -> pure $ primType_ "Word64" - SFixed32 -> pure $ primType_ "Int32" - SFixed64 -> pure $ primType_ "Int64" - String -> pure $ primType_ stringType - Bytes -> pure $ primType_ "ByteString" - Bool -> pure $ primType_ "Bool" - Float -> pure $ primType_ "Float" - Double -> pure $ primType_ "Double" - Named (Dots (Path ("google" :| ["protobuf", x]))) - | x == "Int32Value" -> pure $ primType_ "Int32" - | x == "Int64Value" -> pure $ primType_ "Int64" - | x == "UInt32Value" -> pure $ primType_ "Word32" - | x == "UInt64Value" -> pure $ primType_ "Word64" - | x == "StringValue" -> pure $ primType_ stringType - | x == "BytesValue" -> pure $ primType_ "ByteString" - | x == "BoolValue" -> pure $ primType_ "Bool" - | x == "FloatValue" -> pure $ primType_ "Float" - | x == "DoubleValue" -> pure $ primType_ "Double" - Named msgName -> - case M.lookup msgName ctxt of - Just ty@(DotProtoTypeInfo { dotProtoTypeInfoKind = DotProtoKindEnum }) -> - HsTyApp (protobufType_ "Enumerated") <$> msgTypeFromDpTypeInfo ctxt ty msgName - Just ty -> msgTypeFromDpTypeInfo ctxt ty msgName - Nothing -> noSuchTypeError msgName - -validMapKey :: DotProtoPrimType -> Bool -validMapKey = (`elem` [ Int32, Int64, SInt32, SInt64, UInt32, UInt64 - , Fixed32, Fixed64, SFixed32, SFixed64 - , String, Bool]) - - --------------------------------------------------------------------------------- --- --- * Code generation --- - --- ** Generate instances for a 'DotProto' package - -dotProtoDefinitionD :: MonadError CompileError m - => StringType - -> RecordStyle - -> DotProtoPackageSpec - -> TypeContext - -> DotProtoDefinition - -> m [HsDecl] -dotProtoDefinitionD stringType recordStyle pkgSpec ctxt = \case - DotProtoMessage _ messageName messageParts -> - dotProtoMessageD stringType recordStyle ctxt Anonymous messageName messageParts - - DotProtoEnum _ enumName enumParts -> - dotProtoEnumD Anonymous enumName enumParts - - DotProtoService _ serviceName serviceParts -> - dotProtoServiceD stringType pkgSpec ctxt serviceName serviceParts - --- | Generate 'Named' instance for a type in this package -namedInstD :: String -> HsDecl -namedInstD messageName = - instDecl_ (protobufName "Named") - [ type_ messageName ] - [ HsFunBind [nameOfDecl] ] - where - nameOfDecl = match_ (HsIdent "nameOf") [HsPWildCard] - (HsUnGuardedRhs (apply fromStringE - [ str_ messageName ])) - [] - -hasDefaultInstD :: String -> HsDecl -hasDefaultInstD messageName = - instDecl_ (protobufName "HasDefault") - [ type_ messageName ] - [ ] - --- ** Generate types and instances for .proto messages - --- | Generate data types, 'Bounded', 'Enum', 'FromJSONPB', 'Named', 'Message', --- 'ToJSONPB' instances as appropriate for the given 'DotProtoMessagePart's -dotProtoMessageD - :: forall m - . MonadError CompileError m - => StringType - -> RecordStyle - -> TypeContext - -> DotProtoIdentifier - -> DotProtoIdentifier - -> [DotProtoMessagePart] - -> m [HsDecl] -dotProtoMessageD stringType recordStyle ctxt parentIdent messageIdent messageParts = do - messageName <- qualifiedMessageName parentIdent messageIdent - - let mkDataDecl flds = - dataDecl_ messageName - [ recDecl_ (HsIdent messageName) flds ] - defaultMessageDeriving - -#ifdef SWAGGER - let getName = \case - DotProtoMessageField fld -> (: []) <$> getFieldNameForSchemaInstanceDeclaration fld - DotProtoMessageOneOf ident _ -> (: []) . (Nothing, ) <$> dpIdentUnqualName ident - _ -> pure [] -#endif - - messageDataDecl <- mkDataDecl <$> foldMapM (messagePartFieldD messageName) messageParts - - foldMapM id - [ sequence - [ pure messageDataDecl - , pure (nfDataInstD messageDataDecl messageName) - , pure (namedInstD messageName) - , pure (hasDefaultInstD messageName) - , messageInstD stringType ctxt' parentIdent messageIdent messageParts - - , toJSONPBMessageInstD stringType ctxt' parentIdent messageIdent messageParts - , fromJSONPBMessageInstD stringType ctxt' parentIdent messageIdent messageParts - - -- Generate Aeson instances in terms of JSONPB instances - , pure (toJSONInstDecl messageName) - , pure (fromJSONInstDecl messageName) - -#ifdef SWAGGER - -- And the Swagger ToSchema instance corresponding to JSONPB encodings - , toSchemaInstanceDeclaration stringType ctxt' messageName Nothing - =<< foldMapM getName messageParts -#endif - -#ifdef DHALL - -- Generate Dhall instances - , pure (dhallInterpretInstDecl messageName) - , pure (dhallInjectInstDecl messageName) -#endif - ] - - -- Nested regular and oneof message decls - , foldMapOfM (traverse . _DotProtoMessageDefinition) - nestedDecls - messageParts - - , foldMapOfM (traverse . _DotProtoMessageOneOf) - (uncurry $ nestedOneOfDecls messageName) - messageParts - ] - - where - ctxt' :: TypeContext - ctxt' = maybe mempty dotProtoTypeChildContext (M.lookup messageIdent ctxt) - <> ctxt - - nfDataInstD = case recordStyle of - RegularRecords -> RegularRecord.nfDataInstD - LargeRecords -> LargeRecord.nfDataInstD - - messagePartFieldD :: String -> DotProtoMessagePart -> m [([HsName], HsBangType)] - messagePartFieldD messageName (DotProtoMessageField DotProtoField{..}) = do - fullName <- prefixedFieldName messageName =<< dpIdentUnqualName dotProtoFieldName - fullTy <- dptToHsType WithinMessage stringType ctxt' dotProtoFieldType - pure [ ([HsIdent fullName], HsUnBangedTy fullTy ) ] - - messagePartFieldD messageName (DotProtoMessageOneOf fieldName _) = do - fullName <- prefixedFieldName messageName =<< dpIdentUnqualName fieldName - qualTyName <- prefixedConName messageName =<< dpIdentUnqualName fieldName - let fullTy = HsTyApp (HsTyCon (haskellName "Maybe")) . type_ $ qualTyName - pure [ ([HsIdent fullName], HsUnBangedTy fullTy) ] - - messagePartFieldD _ _ = pure [] - - nestedDecls :: DotProtoDefinition -> m [HsDecl] - nestedDecls (DotProtoMessage _ subMsgName subMessageDef) = do - parentIdent' <- concatDotProtoIdentifier parentIdent messageIdent - dotProtoMessageD stringType recordStyle ctxt' parentIdent' subMsgName subMessageDef - - nestedDecls (DotProtoEnum _ subEnumName subEnumDef) = do - parentIdent' <- concatDotProtoIdentifier parentIdent messageIdent - dotProtoEnumD parentIdent' subEnumName subEnumDef - - nestedDecls _ = pure [] - - nestedOneOfDecls :: String -> DotProtoIdentifier -> [DotProtoField] -> m [HsDecl] - nestedOneOfDecls messageName identifier fields = do - fullName <- prefixedConName messageName =<< dpIdentUnqualName identifier - - (cons, idents) <- fmap unzip (mapM (oneOfCons fullName) fields) - -#ifdef SWAGGER - toSchemaInstance <- toSchemaInstanceDeclaration stringType ctxt' fullName (Just idents) - =<< mapM getFieldNameForSchemaInstanceDeclaration fields -#endif - - let nestedDecl = dataDecl_ fullName cons defaultMessageDeriving - pure [ nestedDecl - , nfDataInstD nestedDecl fullName - , namedInstD fullName -#ifdef SWAGGER - , toSchemaInstance -#endif - -#ifdef DHALL - , dhallInterpretInstDecl fullName - , dhallInjectInstDecl fullName -#endif - ] - - oneOfCons :: String -> DotProtoField -> m (HsConDecl, HsName) - oneOfCons fullName DotProtoField{..} = do - consTy <- dptToHsType WithinOneOf stringType ctxt' dotProtoFieldType - consName <- prefixedConName fullName =<< dpIdentUnqualName dotProtoFieldName - let ident = HsIdent consName - pure (conDecl_ ident [HsUnBangedTy consTy], ident) - - oneOfCons _ DotProtoEmptyField = internalError "field type : empty field" - --- *** Generate Protobuf 'Message' instances - -messageInstD - :: forall m - . MonadError CompileError m - => StringType - -> TypeContext - -> DotProtoIdentifier - -> DotProtoIdentifier - -> [DotProtoMessagePart] - -> m HsDecl -messageInstD stringType ctxt parentIdent msgIdent messageParts = do - msgName <- qualifiedMessageName parentIdent msgIdent - qualifiedFields <- getQualifiedFields msgName messageParts - - encodedFields <- mapM encodeMessageField qualifiedFields - decodedFields <- mapM decodeMessageField qualifiedFields - - let encodeMessageDecl = match_ (HsIdent "encodeMessage") - [HsPWildCard, HsPRec (unqual_ msgName) punnedFieldsP] - (HsUnGuardedRhs encodeMessageE) [] - - encodeMessageE = case encodedFields of - [] -> memptyE - (field : fields) -> foldl op (paren field) fields - where op fs f = apply (apply mappendE [fs]) [paren f] - -- NOTE: We use a left fold because this way the leftmost field - -- is the most nested and the rightmost field--the one to be written - -- first by the right-to-left builder--is the one that is least nested. - - punnedFieldsP = map (fp . coerce . recordFieldName) qualifiedFields - where fp nm = HsPFieldPat (unqual_ nm) (HsPVar (HsIdent nm)) - - - let decodeMessageDecl = match_ (HsIdent "decodeMessage") [ HsPWildCard ] - (HsUnGuardedRhs decodeMessageE) [] - - decodeMessageE = foldl (\f -> HsInfixApp f apOp) - (apply pureE [ uvar_ msgName ]) - decodedFields - - let dotProtoDecl = match_ (HsIdent "dotProto") [HsPWildCard] - (HsUnGuardedRhs dotProtoE) [] - - dotProtoE = HsList $ do - DotProtoMessageField DotProtoField{..} <- messageParts - pure $ apply dotProtoFieldC - [ fieldNumberE dotProtoFieldNumber - , dpTypeE dotProtoFieldType - , dpIdentE dotProtoFieldName - , HsList (map optionE dotProtoFieldOptions) - , str_ dotProtoFieldComment - ] - - - pure $ instDecl_ (protobufName "Message") - [ type_ msgName ] - [ HsFunBind [ encodeMessageDecl ] - , HsFunBind [ decodeMessageDecl ] - , HsFunBind [ dotProtoDecl ] - ] - where - encodeMessageField :: QualifiedField -> m HsExp - encodeMessageField QualifiedField{recordFieldName, fieldInfo} = - let recordFieldName' = uvar_ (coerce recordFieldName) in - case fieldInfo of - FieldNormal _fieldName fieldNum dpType options -> do - fieldE <- wrapE WithinMessage stringType ctxt options dpType recordFieldName' - pure $ apply encodeMessageFieldE [ fieldNumberE fieldNum, fieldE ] - - FieldOneOf OneofField{subfields} -> do - alts <- mapM mkAlt subfields - pure $ HsCase recordFieldName' - [ alt_ (HsPApp (haskellName "Nothing") []) - (HsUnGuardedAlt memptyE) - [] - , alt_ (HsPApp (haskellName "Just") [patVar "x"]) - (HsUnGuardedAlt (HsCase (uvar_ "x") alts)) - [] - ] - where - -- Create all pattern match & expr for each constructor: - -- Constructor y -> encodeMessageField num (Nested (Just y)) -- for embedded messages - -- Constructor y -> encodeMessageField num (ForceEmit y) -- for everything else - mkAlt (OneofSubfield fieldNum conName _ dpType options) = do - let isMaybe - | Prim (Named tyName) <- dpType - = isMessage ctxt tyName - | otherwise - = False - - let wrapJust = HsParen . HsApp (HsVar (haskellName "Just")) - - xE <- (if isMaybe then id else fmap forceEmitE) - . wrapE WithinMessage stringType ctxt options dpType - -- For now we use 'WithinMessage' to preserve - -- the historical approach of treating this field - -- as if it were an ordinary non-oneof field that - -- just happens to be present. - . (if isMaybe then wrapJust else id) - $ uvar_ "y" - - pure $ alt_ (HsPApp (unqual_ conName) [patVar "y"]) - (HsUnGuardedAlt (apply encodeMessageFieldE [fieldNumberE fieldNum, xE])) - [] - - - decodeMessageField :: QualifiedField -> m HsExp - decodeMessageField QualifiedField{fieldInfo} = - case fieldInfo of - FieldNormal _fieldName fieldNum dpType options -> - unwrapE WithinMessage stringType ctxt options dpType $ - apply atE [ decodeMessageFieldE, fieldNumberE fieldNum ] - - FieldOneOf OneofField{subfields} -> do - parsers <- mapM subfieldParserE subfields - pure $ apply oneofE [ HsVar (haskellName "Nothing") - , HsList parsers - ] - where - -- create a list of (fieldNumber, Cons <$> parser) - subfieldParserE (OneofSubfield fieldNumber consName _ dpType options) = do - let fE | Prim (Named tyName) <- dpType, isMessage ctxt tyName - = HsParen (HsApp fmapE (uvar_ consName)) - | otherwise - = HsParen (HsInfixApp (HsVar (haskellName "Just")) - composeOp - (uvar_ consName)) - - -- For now we continue the historical practice of parsing - -- submessages within oneofs as if were outside of oneofs, - -- and replacing the "Just . Ctor" with "fmap . Ctor". - -- That is why we do not pass WithinOneOf. - alts <- unwrapE WithinMessage stringType ctxt options dpType decodeMessageFieldE - - pure $ HsTuple - [ fieldNumberE fieldNumber - , HsInfixApp (apply pureE [ fE ]) apOp alts - ] - - --- *** Generate ToJSONPB/FromJSONPB instances - -toJSONPBMessageInstD - :: forall m - . MonadError CompileError m - => StringType - -> TypeContext - -> DotProtoIdentifier - -> DotProtoIdentifier - -> [DotProtoMessagePart] - -> m HsDecl -toJSONPBMessageInstD stringType ctxt parentIdent msgIdent messageParts = do - msgName <- qualifiedMessageName parentIdent msgIdent - qualFields <- getQualifiedFields msgName messageParts - - let applyE nm oneofNm = do - fs <- traverse (encodeMessageField oneofNm) qualFields - pure $ apply (HsVar (jsonpbName nm)) [HsList fs] - - let patBinder = foldQF (const fieldBinder) (oneofSubDisjunctBinder . subfields) - let matchE nm appNm oneofAppNm = do - rhs <- applyE appNm oneofAppNm - pure $ match_ - (HsIdent nm) - [ HsPApp (unqual_ msgName) - (patVar . patBinder <$> qualFields) ] - (HsUnGuardedRhs rhs) - [] - - toJSONPB <- matchE "toJSONPB" "object" "objectOrNull" - toEncoding <- matchE "toEncodingPB" "pairs" "pairsOrNull" - - pure $ instDecl_ (jsonpbName "ToJSONPB") - [ type_ msgName ] - [ HsFunBind [toJSONPB] - , HsFunBind [toEncoding] - ] - - where - encodeMessageField :: String -> QualifiedField -> m HsExp - encodeMessageField oneofNm (QualifiedField _ fieldInfo) = - case fieldInfo of - FieldNormal fldName fldNum dpType options -> - defPairE fldName fldNum dpType options - FieldOneOf oo -> - oneofCaseE oneofNm oo - - -- E.g. - -- "another" .= f2 -- always succeeds (produces default value on missing field) - defPairE fldName fldNum dpType options = do - w <- wrapE WithinMessage stringType ctxt options dpType (uvar_ (fieldBinder fldNum)) - pure $ HsInfixApp (str_ (coerce fldName)) toJSONPBOp w - - -- E.g. - -- HsJSONPB.pair "name" f4 -- fails on missing field - oneOfPairE fldNm varNm options dpType = do - w <- wrapE WithinOneOf stringType ctxt options dpType (uvar_ varNm) - pure $ apply (HsVar (jsonpbName "pair")) [str_ (coerce fldNm), w] - - -- Suppose we have a sum type Foo, nested inside a message Bar. - -- We want to generate the following: - -- - -- > toJSONPB (Bar foo more stuff) = - -- > HsJSONPB.object - -- > [ (let encodeFoo = ( :: Options -> Value) - -- > in \option -> if optEmitNamedOneof option - -- > then ("Foo" .= (PB.objectOrNull [encodeFoo] option)) option - -- > else encodeFoo option - -- > ) - -- > , - -- > , - -- > ] - oneofCaseE :: String -> OneofField -> m HsExp - oneofCaseE retJsonCtor (OneofField typeName subfields) = do - altEs <- traverse altE subfields - pure $ HsParen - $ HsLet [ HsFunBind [ match_ (HsIdent caseName) [] (HsUnGuardedRhs (caseExpr altEs)) [] ] ] - $ HsLambda defaultSrcLoc [patVar optsStr] (HsIf dontInline noInline yesInline) - where - optsStr = "options" - opts = uvar_ optsStr - - caseName = "encode" <> over (ix 0) toUpper typeName - caseBnd = uvar_ caseName - - dontInline = HsApp (HsVar (jsonpbName "optEmitNamedOneof")) opts - - noInline = HsApp (HsParen (HsInfixApp (str_ typeName) - toJSONPBOp - (apply (HsVar (jsonpbName retJsonCtor)) - [ HsList [caseBnd], opts ]))) - opts - - yesInline = HsApp caseBnd opts - - altE sub@(OneofSubfield _ conName pbFldNm dpType options) = do - let patVarNm = oneofSubBinder sub - p <- oneOfPairE pbFldNm patVarNm options dpType - pure $ alt_ (HsPApp (haskellName "Just") - [ HsPParen - (HsPApp (unqual_ conName) [patVar patVarNm]) - ] - ) - (HsUnGuardedAlt p) - [] - - -- E.g. - -- case f4_or_f9 of - -- Just (SomethingPickOneName f4) - -- -> HsJSONPB.pair "name" f4 - -- Just (SomethingPickOneSomeid f9) - -- -> HsJSONPB.pair "someid" f9 - -- Nothing - -- -> mempty - caseExpr altEs = HsParen $ - HsCase disjunctName (altEs <> [fallthroughE]) - where - disjunctName = uvar_ (oneofSubDisjunctBinder subfields) - fallthroughE = - alt_ (HsPApp (haskellName "Nothing") []) - (HsUnGuardedAlt memptyE) - [] - -fromJSONPBMessageInstD - :: forall m - . MonadError CompileError m - => StringType - -> TypeContext - -> DotProtoIdentifier - -> DotProtoIdentifier - -> [DotProtoMessagePart] - -> m HsDecl -fromJSONPBMessageInstD stringType ctxt parentIdent msgIdent messageParts = do - msgName <- qualifiedMessageName parentIdent msgIdent - qualFields <- getQualifiedFields msgName messageParts - - fieldParsers <- traverse parseField qualFields - - let parseJSONPBE = - apply (HsVar (jsonpbName "withObject")) - [ str_ msgName - , HsParen (HsLambda defaultSrcLoc [lambdaPVar] fieldAps) - ] - where - fieldAps = foldl (\f -> HsInfixApp f apOp) - (apply pureE [ uvar_ msgName ]) - fieldParsers - - let parseJSONPBDecl = - match_ (HsIdent "parseJSONPB") [] (HsUnGuardedRhs parseJSONPBE) [] - - pure (instDecl_ (jsonpbName "FromJSONPB") - [ type_ msgName ] - [ HsFunBind [ parseJSONPBDecl ] ]) - where - lambdaPVar = patVar "obj" - lambdaVar = uvar_ "obj" - - parseField (QualifiedField _ (FieldNormal fldName _ dpType options)) = - normalParserE fldName dpType options - parseField (QualifiedField _ (FieldOneOf fld)) = - oneofParserE fld - - -- E.g., for message - -- message Something { oneof name_or_id { string name = _; int32 someid = _; } } - -- - -- ==> - -- - -- (let parseSomethingNameOrId parseObj = - -- in ((obj .: "nameOrId") Hs.>>= - -- (HsJSONPB.withObject "nameOrId" parseSomethingNameOrId)) - -- <|> - -- (parseSomethingNameOrId obj) - -- ) - oneofParserE :: OneofField -> m HsExp - oneofParserE (OneofField oneofType fields) = do - ds <- tryParseDisjunctsE - pure $ HsParen $ - HsLet [ HsFunBind [ match_ (HsIdent letBndStr) [patVar letArgStr ] - (HsUnGuardedRhs ds) [] - ] - ] - (HsInfixApp parseWrapped altOp parseUnwrapped) - where - oneofTyLit = str_ oneofType -- FIXME - - letBndStr = "parse" <> over (ix 0) toUpper oneofType - letBndName = uvar_ letBndStr - letArgStr = "parseObj" - letArgName = uvar_ letArgStr - - parseWrapped = HsParen $ - HsInfixApp (HsParen (HsInfixApp lambdaVar parseJSONPBOp oneofTyLit)) - bindOp - (apply (HsVar (jsonpbName "withObject")) [ oneofTyLit , letBndName ]) - - parseUnwrapped = HsParen (HsApp letBndName lambdaVar) - - -- parseSomethingNameOrId parseObj = - -- Hs.msum - -- [ (Just . SomethingPickOneName) <$> (HsJSONPB.parseField parseObj "name") - -- , (Just . SomethingPickOneSomeid) <$> (HsJSONPB.parseField parseObj "someid") - -- , pure Nothing - -- ] - tryParseDisjunctsE = do - fs <- traverse subParserE fields - pure $ HsApp msumE (HsList (fs <> fallThruE)) - - fallThruE = [ HsApp pureE (HsVar (haskellName "Nothing")) ] - - subParserE OneofSubfield{subfieldConsName, subfieldName, - subfieldType, subfieldOptions} = do - maybeCoercion <- - unwrapFunE False WithinOneOf stringType ctxt subfieldOptions subfieldType - let inject = (HsInfixApp (HsVar (haskellName "Just")) - composeOp - (uvar_ subfieldConsName)) - pure $ HsInfixApp - (maybe inject (HsInfixApp inject composeOp) maybeCoercion) - fmapOp - (apply (HsVar (jsonpbName "parseField")) - [ letArgName - , str_ (coerce subfieldName)]) - - -- E.g. obj .: "someid" - normalParserE :: FieldName -> DotProtoType -> [DotProtoOption] -> m HsExp - normalParserE fldName dpType options = - unwrapE WithinMessage stringType ctxt options dpType $ - HsInfixApp lambdaVar - parseJSONPBOp - (str_(coerce fldName)) - --- *** Generate default Aeson To/FromJSON and Swagger ToSchema instances --- (These are defined in terms of ToJSONPB) - -toJSONInstDecl :: String -> HsDecl -toJSONInstDecl typeName = - instDecl_ (jsonpbName "ToJSON") - [ type_ typeName ] - [ HsFunBind [ match_ (HsIdent "toJSON") [] - (HsUnGuardedRhs (HsVar (jsonpbName "toAesonValue"))) [] - ] - , HsFunBind [ match_ (HsIdent "toEncoding") [] - (HsUnGuardedRhs (HsVar (jsonpbName "toAesonEncoding"))) [] - ] - ] - -fromJSONInstDecl :: String -> HsDecl -fromJSONInstDecl typeName = - instDecl_ (jsonpbName "FromJSON") - [ type_ typeName ] - [ HsFunBind [match_ (HsIdent "parseJSON") [] - (HsUnGuardedRhs (HsVar (jsonpbName "parseJSONPB"))) [] - ] - ] - - --- *** Generate `ToSchema` instance - -getFieldNameForSchemaInstanceDeclaration - :: MonadError CompileError m - => DotProtoField - -> m (Maybe ([DotProtoOption], DotProtoType), String) -getFieldNameForSchemaInstanceDeclaration fld = do - unqual <- dpIdentUnqualName (dotProtoFieldName fld) - let optsType = (dotProtoFieldOptions fld, dotProtoFieldType fld) - pure (Just optsType, unqual) - -toSchemaInstanceDeclaration - :: MonadError CompileError m - => StringType - -> TypeContext - -> String - -- ^ Name of the message type to create an instance for - -> Maybe [HsName] - -- ^ Oneof constructors - -> [(Maybe ([DotProtoOption], DotProtoType), String)] - -- ^ Field names, with every field that is not actually a oneof - -- combining fields paired with its options and protobuf type - -> m HsDecl -toSchemaInstanceDeclaration stringType ctxt messageName maybeConstructors fieldNamesEtc = do - let fieldNames = map snd fieldNamesEtc - - qualifiedFieldNames <- mapM (prefixedFieldName messageName) fieldNames - - let messageConstructor = HsCon (UnQual (HsIdent messageName)) - - let _namedSchemaNameExpression = HsApp justC (str_ messageName) - -#ifdef SWAGGER - -- { _paramSchemaType = HsJSONPB.SwaggerObject - -- } - let paramSchemaUpdates = - [ HsFieldUpdate _paramSchemaType _paramSchemaTypeExpression - ] - where - _paramSchemaType = jsonpbName "_paramSchemaType" - -#if MIN_VERSION_swagger2(2,4,0) - _paramSchemaTypeExpression = HsApp justC (HsVar (jsonpbName "SwaggerObject")) -#else - _paramSchemaTypeExpression = HsVar (jsonpbName "SwaggerObject") -#endif -#else - let paramSchemaUpdates = [] -#endif - - let _schemaParamSchemaExpression = HsRecUpdate memptyE paramSchemaUpdates - - -- [ ("fieldName0", qualifiedFieldName0) - -- , ("fieldName1", qualifiedFieldName1) - -- ... - -- ] - let properties = HsList $ do - (fieldName, qualifiedFieldName) <- zip fieldNames qualifiedFieldNames - return (HsTuple [ str_ fieldName, uvar_ qualifiedFieldName ]) - - let _schemaPropertiesExpression = - HsApp (HsVar (jsonpbName "insOrdFromList")) properties - - -- { _schemaParamSchema = ... - -- , _schemaProperties = ... - -- , ... - -- } - let schemaUpdates = normalUpdates ++ extraUpdates - where - normalUpdates = - [ HsFieldUpdate _schemaParamSchema _schemaParamSchemaExpression - , HsFieldUpdate _schemaProperties _schemaPropertiesExpression - ] - - extraUpdates = - case maybeConstructors of - Just _ -> - [ HsFieldUpdate _schemaMinProperties justOne - , HsFieldUpdate _schemaMaxProperties justOne - ] - Nothing -> - [] - - _schemaParamSchema = jsonpbName "_schemaParamSchema" - _schemaProperties = jsonpbName "_schemaProperties" - _schemaMinProperties = jsonpbName "_schemaMinProperties" - _schemaMaxProperties = jsonpbName "_schemaMaxProperties" - - justOne = HsApp justC (HsLit (HsInt 1)) - - let _namedSchemaSchemaExpression = HsRecUpdate memptyE schemaUpdates - - -- { _namedSchemaName = ... - -- , _namedSchemaSchema = ... - -- } - let namedSchemaUpdates = - [ HsFieldUpdate _namedSchemaName _namedSchemaNameExpression - , HsFieldUpdate _namedSchemaSchema _namedSchemaSchemaExpression - ] - where - _namedSchemaName = jsonpbName "_namedSchemaName" - _namedSchemaSchema = jsonpbName "_namedSchemaSchema" - - let namedSchema = HsRecConstr (jsonpbName "NamedSchema") namedSchemaUpdates - - let toDeclareName fieldName = "declare_" ++ fieldName - - let toArgument fc (maybeOptsType, fieldName) = - maybe pure (uncurry (unwrapE fc stringType ctxt)) maybeOptsType $ - HsApp asProxy declare - where - declare = uvar_ (toDeclareName fieldName) - asProxy = HsVar (jsonpbName "asProxy") - - -- do let declare_fieldName0 = HsJSONPB.declareSchemaRef - -- qualifiedFieldName0 <- declare_fieldName0 Proxy.Proxy - -- let declare_fieldName1 = HsJSONPB.declareSchemaRef - -- qualifiedFieldName1 <- declare_fieldName1 Proxy.Proxy - -- ... - -- let _ = pure MessageName <*> HsJSONPB.asProxy declare_fieldName0 <*> HsJSONPB.asProxy declare_fieldName1 <*> ... - -- return (...) - let expressionForMessage = do - let bindingStatements = do - (fieldName, qualifiedFieldName) <- zip fieldNames qualifiedFieldNames - - let declareIdentifier = HsIdent (toDeclareName fieldName) - - let stmt0 = HsLetStmt [ HsFunBind - [ HsMatch defaultSrcLoc declareIdentifier [] - (HsUnGuardedRhs (HsVar (jsonpbName "declareSchemaRef"))) [] - ] - ] - - let stmt1 = HsGenerator defaultSrcLoc (HsPVar (HsIdent qualifiedFieldName)) - (HsApp (HsVar (UnQual declareIdentifier)) - (HsCon (proxyName "Proxy"))) - [ stmt0, stmt1] - - inferenceStatement <- do - arguments <- traverse (toArgument WithinMessage) fieldNamesEtc - let patternBind = HsPatBind defaultSrcLoc HsPWildCard - (HsUnGuardedRhs (applicativeApply messageConstructor arguments)) [] - pure $ if null fieldNames then [] else [ HsLetStmt [ patternBind ] ] - - let returnStatement = HsQualifier (HsApp returnE (HsParen namedSchema)) - - pure $ HsDo (bindingStatements ++ inferenceStatement ++ [ returnStatement ]) - - -- do let declare_fieldName0 = HsJSONPB.declareSchemaRef - -- let _ = pure ConstructorName0 <*> HsJSONPB.asProxy declare_fieldName0 - -- qualifiedFieldName0 <- declare_fieldName0 Proxy.Proxy - -- let declare_fieldName1 = HsJSONPB.declareSchemaRef - -- let _ = pure ConstructorName1 <*> HsJSONPB.asProxy declare_fieldName1 - -- qualifiedFieldName1 <- declare_fieldName1 Proxy.Proxy - -- ... - -- return (...) - let expressionForOneOf constructors = do - let bindingStatement (fieldNameEtc, qualifiedFieldName, constructor) = do - let declareIdentifier = HsIdent (toDeclareName (snd fieldNameEtc)) - - let stmt0 = HsLetStmt [ HsFunBind - [ HsMatch defaultSrcLoc declareIdentifier [] - (HsUnGuardedRhs (HsVar (jsonpbName "declareSchemaRef"))) [] - ] - ] - let stmt1 = HsGenerator defaultSrcLoc (HsPVar (HsIdent qualifiedFieldName)) - (HsApp (HsVar (UnQual declareIdentifier)) - (HsCon (proxyName "Proxy"))) - inferenceStatement <- do - argument <- toArgument WithinOneOf fieldNameEtc - let patternBind = HsPatBind defaultSrcLoc HsPWildCard - (HsUnGuardedRhs (applicativeApply (HsCon (UnQual constructor)) [ argument ])) [] - pure $ if null fieldNames then [] else [ HsLetStmt [ patternBind ] ] - - pure $ [stmt0, stmt1] ++ inferenceStatement - - bindingStatements <- foldMapM bindingStatement $ - zip3 fieldNamesEtc qualifiedFieldNames constructors - - let returnStatement = HsQualifier (HsApp returnE (HsParen namedSchema)) - - pure $ HsDo (bindingStatements ++ [ returnStatement ]) - - expression <- case maybeConstructors of - Nothing -> expressionForMessage - Just constructors -> expressionForOneOf constructors - - let instanceDeclaration = - instDecl_ className [ classArgument ] [ classDeclaration ] - where - className = jsonpbName "ToSchema" - - classArgument = HsTyCon (UnQual (HsIdent messageName)) - - classDeclaration = HsFunBind [ match ] - where - match = match_ matchName [ HsPWildCard ] rightHandSide [] - where - rightHandSide = HsUnGuardedRhs expression - - matchName = HsIdent "declareNamedSchema" - - return instanceDeclaration - - --- ** Generate types and instances for .proto enums - -dotProtoEnumD - :: MonadError CompileError m - => DotProtoIdentifier - -> DotProtoIdentifier - -> [DotProtoEnumPart] - -> m [HsDecl] -dotProtoEnumD parentIdent enumIdent enumParts = do - enumName <- qualifiedMessageName parentIdent enumIdent - - let enumeratorDecls = - [ (i, conIdent) | DotProtoEnumField conIdent i _options <- enumParts ] - - case enumeratorDecls of - [] -> throwError $ EmptyEnumeration enumName - (i, conIdent) : _ - | i == 0 -> return () - | otherwise -> throwError $ NonzeroFirstEnumeration enumName conIdent i - - enumCons <- sortBy (comparing fst) <$> traverse (traverse (fmap (prefixedEnumFieldName enumName) . dpIdentUnqualName)) enumeratorDecls - - let enumConNames = map snd enumCons - - minBoundD = - [ match_ (HsIdent "minBound") - [] - (HsUnGuardedRhs (uvar_ (head enumConNames))) - [] - ] - - maxBoundD = - [ match_ (HsIdent "maxBound") - [] - (HsUnGuardedRhs (uvar_ (last enumConNames))) - [] - ] - - compareD = - [ match_ (HsIdent "compare") - [ patVar "x", patVar "y" ] - (HsUnGuardedRhs - (HsApp - (HsApp - (HsVar (haskellName "compare")) - (HsParen - (HsApp (HsVar(protobufName "fromProtoEnum")) - (uvar_ "x") - ) - ) - ) - (HsParen - (HsApp (HsVar (protobufName "fromProtoEnum")) - (uvar_ "y") - ) - ) - ) - ) - [] - ] - - fromProtoEnumD = - [ match_ (HsIdent "fromProtoEnum") [ HsPApp (unqual_ conName) [] ] - (HsUnGuardedRhs (intE conIdx)) - [] - | (conIdx, conName) <- enumCons - ] - - toProtoEnumMayD = - [ match_ (HsIdent "toProtoEnumMay") - [ intP conIdx ] - (HsUnGuardedRhs (HsApp justC (uvar_ conName))) - [] - | (conIdx, conName) <- enumCons ] ++ - [ match_ (HsIdent "toProtoEnumMay") - [ HsPWildCard ] - (HsUnGuardedRhs nothingC) - [] - ] - - parseJSONPBDecls :: [HsMatch] - parseJSONPBDecls = foldr ((:) . matchConName) [mismatch] enumConNames - where - matchConName conName = match_ (HsIdent "parseJSONPB") [pat conName] - (HsUnGuardedRhs - (HsApp pureE (uvar_ conName))) - [] - - pat nm = HsPApp (jsonpbName "String") [ HsPLit (HsString (tryStripEnumName nm)) ] - - tryStripEnumName = fromMaybe <*> stripPrefix enumName - - mismatch = match_ (HsIdent "parseJSONPB") [patVar "v"] - (HsUnGuardedRhs - (apply (HsVar (jsonpbName "typeMismatch")) - [ str_ enumName, uvar_ "v" ])) - [] - - - toJSONPBDecl = - match_ (HsIdent "toJSONPB") [ patVar "x", HsPWildCard ] - (HsUnGuardedRhs - (HsApp (HsVar (jsonpbName "enumFieldString")) - (uvar_ "x"))) - [] - - toEncodingPBDecl = - match_ (HsIdent "toEncodingPB") [ patVar "x", HsPWildCard ] - (HsUnGuardedRhs - (HsApp (HsVar (jsonpbName "enumFieldEncoding")) - (uvar_ "x"))) - [] - - pure [ dataDecl_ enumName - [ conDecl_ (HsIdent con) [] | con <- enumConNames ] - defaultEnumDeriving - , namedInstD enumName - , hasDefaultInstD enumName - , instDecl_ (haskellName "Bounded") [ type_ enumName ] - [ HsFunBind minBoundD - , HsFunBind maxBoundD - ] - , instDecl_ (haskellName "Ord") [ type_ enumName ] - [ HsFunBind compareD ] - , instDecl_ (protobufName "ProtoEnum") [ type_ enumName ] - [ HsFunBind toProtoEnumMayD - , HsFunBind fromProtoEnumD - ] - , instDecl_ (jsonpbName "ToJSONPB") [ type_ enumName ] - [ HsFunBind [toJSONPBDecl] - , HsFunBind [toEncodingPBDecl] - ] - , instDecl_ (jsonpbName "FromJSONPB") [ type_ enumName ] - [ HsFunBind parseJSONPBDecls ] - -- Generate Aeson instances in terms of JSONPB instances - , toJSONInstDecl enumName - , fromJSONInstDecl enumName - -#ifdef DHALL - -- Generate Dhall instances - , dhallInterpretInstDecl enumName - , dhallInjectInstDecl enumName -#endif - - -- And the Finite instance, used to infer a Swagger ToSchema instance - -- for this enumerated type. - , instDecl_ (protobufName "Finite") [ type_ enumName ] [] - ] - --- ** Generate code for dot proto services - -dotProtoServiceD - :: MonadError CompileError m - => StringType - -> DotProtoPackageSpec - -> TypeContext - -> DotProtoIdentifier - -> [DotProtoServicePart] - -> m [HsDecl] -dotProtoServiceD stringType pkgSpec ctxt serviceIdent service = do - serviceName <- typeLikeName =<< dpIdentUnqualName serviceIdent - - endpointPrefix <- - case pkgSpec of - DotProtoPackageSpec pkgIdent -> do - packageName <- dpIdentQualName pkgIdent - pure $ "/" ++ packageName ++ "." ++ serviceName ++ "/" - DotProtoNoPackage -> pure $ "/" ++ serviceName ++ "/" - - let serviceFieldD (DotProtoServiceRPCMethod RPCMethod{..}) = do - fullName <- prefixedMethodName serviceName =<< dpIdentUnqualName rpcMethodName - - methodName <- case rpcMethodName of - Single nm -> pure nm - _ -> invalidMethodNameError rpcMethodName - - requestTy <- dpptToHsType stringType ctxt (Named rpcMethodRequestType) - - responseTy <- dpptToHsType stringType ctxt (Named rpcMethodResponseType) - - let streamingType = - case (rpcMethodRequestStreaming, rpcMethodResponseStreaming) of - (Streaming, Streaming) -> biDiStreamingC - (Streaming, NonStreaming) -> clientStreamingC - (NonStreaming, Streaming) -> serverStreamingC - (NonStreaming, NonStreaming) -> normalC - - pure [ ( endpointPrefix ++ methodName - , fullName, rpcMethodRequestStreaming, rpcMethodResponseStreaming - , HsUnBangedTy $ - HsTyFun (tyApp (HsTyVar (HsIdent "request")) - [streamingType, requestTy, responseTy]) - (tyApp ioT - [tyApp (HsTyVar (HsIdent "response")) - [streamingType, responseTy] - ] - ) - ) - ] - - serviceFieldD _ = pure [] - - fieldsD <- foldMapM serviceFieldD service - - serverFuncName <- prefixedFieldName serviceName "server" - clientFuncName <- prefixedFieldName serviceName "client" - - let conDecl = recDecl_ (HsIdent serviceName) - [ ([HsIdent hsName], ty) | (_, hsName, _, _, ty) <- fieldsD ] - - let serverT = tyApp (HsTyCon (unqual_ serviceName)) - [ serverRequestT, serverResponseT ] - - let serviceServerTypeD = - HsTypeSig defaultSrcLoc [ HsIdent serverFuncName ] - (HsQualType [] (HsTyFun serverT (HsTyFun serviceOptionsC ioActionT))) - - let serviceServerD = HsFunBind [serverFuncD] - where - serverFuncD = - match_ (HsIdent serverFuncName) - [ HsPRec (unqual_ serviceName) - [ HsPFieldPat (unqual_ methodName) (HsPVar (HsIdent methodName)) - | (_, methodName, _, _, _) <- fieldsD - ] - , HsPApp (unqual_ "ServiceOptions") - [ patVar "serverHost" - , patVar "serverPort" - , patVar "useCompression" - , patVar "userAgentPrefix" - , patVar "userAgentSuffix" - , patVar "initialMetadata" - , patVar "sslConfig" - , patVar "logger" - , patVar "serverMaxReceiveMessageLength" - , patVar "serverMaxMetadataSize" - ] - ] - (HsUnGuardedRhs (apply serverLoopE [ serverOptsE ])) - [] - - handlerE handlerC adapterE methodName hsName = - apply handlerC [ apply methodNameC [ str_ methodName ] - , apply adapterE [ uvar_ hsName ] - ] - - update u v = HsFieldUpdate (unqual_ u) (uvar_ v) - - serverOptsE = HsRecUpdate defaultOptionsE - [ HsFieldUpdate (grpcName "optNormalHandlers") $ - HsList [ handlerE unaryHandlerC convertServerHandlerE endpointName hsName - | (endpointName, hsName, NonStreaming, NonStreaming, _) <- fieldsD - ] - - , HsFieldUpdate (grpcName "optClientStreamHandlers") $ - HsList [ handlerE clientStreamHandlerC convertServerReaderHandlerE endpointName hsName - | (endpointName, hsName, Streaming, NonStreaming, _) <- fieldsD - ] - - - , HsFieldUpdate (grpcName "optServerStreamHandlers") $ - HsList [ handlerE serverStreamHandlerC convertServerWriterHandlerE endpointName hsName - | (endpointName, hsName, NonStreaming, Streaming, _) <- fieldsD - ] - - - , HsFieldUpdate (grpcName "optBiDiStreamHandlers") $ - HsList [ handlerE biDiStreamHandlerC convertServerRWHandlerE endpointName hsName - | (endpointName, hsName, Streaming, Streaming, _) <- fieldsD - ] - - , update "optServerHost" "serverHost" - , update "optServerPort" "serverPort" - , update "optUseCompression" "useCompression" - , update "optUserAgentPrefix" "userAgentPrefix" - , update "optUserAgentSuffix" "userAgentSuffix" - , update "optInitialMetadata" "initialMetadata" - , update "optSSLConfig" "sslConfig" - , update "optLogger" "logger" - , update "optMaxReceiveMessageLength" "serverMaxReceiveMessageLength" - , update "optMaxMetadataSize" "serverMaxMetadataSize" - ] - - let clientT = tyApp (HsTyCon (unqual_ serviceName)) [ clientRequestT, clientResultT ] - - let serviceClientTypeD = - HsTypeSig defaultSrcLoc [ HsIdent clientFuncName ] - (HsQualType [] (HsTyFun grpcClientT (HsTyApp ioT clientT))) - - let serviceClientD = HsFunBind [ clientFuncD ] - where - clientFuncD = match_ (HsIdent clientFuncName) - [ HsPVar (HsIdent "client") ] - ( HsUnGuardedRhs clientRecE ) [] - - clientRecE = foldl (\f -> HsInfixApp f apOp) - (apply pureE [ uvar_ serviceName ]) - [ HsParen $ HsInfixApp clientRequestE' apOp (registerClientMethodE endpointName) - | (endpointName, _, _, _, _) <- fieldsD - ] - - clientRequestE' = apply pureE [ apply clientRequestE [ uvar_ "client" ] ] - - registerClientMethodE endpoint = - apply clientRegisterMethodE [ uvar_ "client" - , apply methodNameC [ str_ endpoint ] - ] - - pure [ HsDataDecl defaultSrcLoc [] (HsIdent serviceName) - [ HsIdent "request", HsIdent "response" ] - [ conDecl ] defaultServiceDeriving - - , serviceServerTypeD - , serviceServerD - - , serviceClientTypeD - , serviceClientD - ] - --------------------------------------------------------------------------------- - --- --- * Common Haskell expressions, constructors, and operators --- - -unaryHandlerC, clientStreamHandlerC, serverStreamHandlerC, biDiStreamHandlerC, - methodNameC, defaultOptionsE, serverLoopE, convertServerHandlerE, - convertServerReaderHandlerE, convertServerWriterHandlerE, - convertServerRWHandlerE, clientRegisterMethodE, clientRequestE :: HsExp - -unaryHandlerC = HsVar (grpcName "UnaryHandler") -clientStreamHandlerC = HsVar (grpcName "ClientStreamHandler") -serverStreamHandlerC = HsVar (grpcName "ServerStreamHandler") -biDiStreamHandlerC = HsVar (grpcName "BiDiStreamHandler") -methodNameC = HsVar (grpcName "MethodName") -defaultOptionsE = HsVar (grpcName "defaultOptions") -serverLoopE = HsVar (grpcName "serverLoop") -convertServerHandlerE = HsVar (grpcName "convertGeneratedServerHandler") -convertServerReaderHandlerE = HsVar (grpcName "convertGeneratedServerReaderHandler") -convertServerWriterHandlerE = HsVar (grpcName "convertGeneratedServerWriterHandler") -convertServerRWHandlerE = HsVar (grpcName "convertGeneratedServerRWHandler") -clientRegisterMethodE = HsVar (grpcName "clientRegisterMethod") -clientRequestE = HsVar (grpcName "clientRequest") - -biDiStreamingC, serverStreamingC, clientStreamingC, normalC, serviceOptionsC, - ioActionT, serverRequestT, serverResponseT, clientRequestT, clientResultT, - ioT, grpcClientT :: HsType -biDiStreamingC = HsTyCon (Qual (Module "'HsGRPC") (HsIdent "BiDiStreaming")) -serverStreamingC = HsTyCon (Qual (Module "'HsGRPC") (HsIdent "ServerStreaming")) -clientStreamingC = HsTyCon (Qual (Module "'HsGRPC") (HsIdent "ClientStreaming")) -normalC = HsTyCon (Qual (Module "'HsGRPC") (HsIdent "Normal")) -serviceOptionsC = HsTyCon (Qual (Module "HsGRPC") (HsIdent "ServiceOptions")) -serverRequestT = HsTyCon (grpcName "ServerRequest") -serverResponseT = HsTyCon (grpcName "ServerResponse") -clientRequestT = HsTyCon (grpcName "ClientRequest") -clientResultT = HsTyCon (grpcName "ClientResult") -grpcClientT = HsTyCon (grpcName "Client") -ioActionT = tyApp ioT [ HsTyTuple [] ] -ioT = HsTyCon (haskellName "IO") - --- ** Expressions for protobuf-wire types - -forceEmitE :: HsExp -> HsExp -forceEmitE = HsParen . HsApp forceEmitC - -fieldNumberE :: FieldNumber -> HsExp -fieldNumberE = HsParen . HsApp fieldNumberC . intE . getFieldNumber - -dpIdentE :: DotProtoIdentifier -> HsExp -dpIdentE (Single n) = apply singleC [ str_ n ] -dpIdentE (Dots (Path (n NE.:| ns))) - = apply dotsC [ apply pathC [ HsParen (HsInfixApp (str_ n) neConsOp (HsList (map str_ ns))) ] ] -dpIdentE (Qualified a b) = apply qualifiedC [ dpIdentE a, dpIdentE b ] -dpIdentE Anonymous = anonymousC - -dpValueE :: DotProtoValue -> HsExp -dpValueE (Identifier nm) = apply identifierC [ dpIdentE nm ] -dpValueE (StringLit s) = apply stringLitC [ str_ s ] -dpValueE (IntLit i) = apply intLitC [ HsLit (HsInt (fromIntegral i)) ] -dpValueE (FloatLit f) = apply floatLitC [ HsLit (HsFrac (toRational f)) ] -dpValueE (BoolLit True) = apply boolLitC [ trueC ] -dpValueE (BoolLit False) = apply boolLitC [ falseC ] - -optionE :: DotProtoOption -> HsExp -optionE (DotProtoOption name value) = - apply dotProtoOptionC [ dpIdentE name, dpValueE value ] - --- | Translate a dot proto type to its Haskell AST type -dpTypeE :: DotProtoType -> HsExp -dpTypeE (Prim p) = apply primC [ dpPrimTypeE p ] -dpTypeE (Repeated p) = apply repeatedC [ dpPrimTypeE p ] -dpTypeE (NestedRepeated p) = apply nestedRepeatedC [ dpPrimTypeE p ] -dpTypeE (Map k v) = apply mapC [ dpPrimTypeE k, dpPrimTypeE v] - - --- | Translate a dot proto primitive type to a Haskell AST primitive type. -dpPrimTypeE :: DotProtoPrimType -> HsExp -dpPrimTypeE ty = - let wrap = HsVar . protobufASTName in - case ty of - Named n -> apply namedC [ dpIdentE n ] - Int32 -> wrap "Int32" - Int64 -> wrap "Int64" - SInt32 -> wrap "SInt32" - SInt64 -> wrap "SInt64" - UInt32 -> wrap "UInt32" - UInt64 -> wrap "UInt64" - Fixed32 -> wrap "Fixed32" - Fixed64 -> wrap "Fixed64" - SFixed32 -> wrap "SFixed32" - SFixed64 -> wrap "SFixed64" - String -> wrap "String" - Bytes -> wrap "Bytes" - Bool -> wrap "Bool" - Float -> wrap "Float" - Double -> wrap "Double" - -data ImportCustomisation = ImportCustomisation - { icStringType :: StringType - , icUsesGrpc :: Bool - } - -defaultImports :: RecordStyle -> ImportCustomisation -> [HsImportDecl] -defaultImports recordStyle ImportCustomisation{ icUsesGrpc, icStringType = StringType stringModule stringType} = - [ importDecl_ (m "Prelude") & qualified haskellNS & everything - , importDecl_ (m "Proto3.Suite.Class") & qualified protobufNS & everything -#ifdef DHALL - , importDecl_ (m "Proto3.Suite.DhallPB") & qualified (m hsDhallPB) & everything -#endif - , importDecl_ (m "Proto3.Suite.DotProto") & qualified protobufASTNS & everything - , importDecl_ (m "Proto3.Suite.JSONPB") & qualified jsonpbNS & everything - , importDecl_ (m "Proto3.Suite.JSONPB") & unqualified & selecting [s".=", s".:"] - , importDecl_ (m "Proto3.Suite.Types") & qualified protobufNS & everything - , importDecl_ (m "Proto3.Wire") & qualified protobufNS & everything - , importDecl_ (m "Proto3.Wire.Decode") & qualified protobufNS & selecting [i"Parser", i"RawField"] - , importDecl_ (m "Control.Applicative") & qualified haskellNS & everything - , importDecl_ (m "Control.Applicative") & unqualified & selecting [s"<*>", s"<|>", s"<$>"] - , importDecl_ (m "Control.DeepSeq") & qualified haskellNS & everything - , importDecl_ (m "Control.Monad") & qualified haskellNS & everything - , importDecl_ (m "Data.ByteString") & qualified haskellNS & everything - , importDecl_ (m "Data.Coerce") & qualified haskellNS & everything - , importDecl_ (m "Data.Int") & qualified haskellNS & selecting [i"Int16", i"Int32", i"Int64"] - , importDecl_ (m "Data.List.NonEmpty") & qualified haskellNS & selecting [HsIThingAll (HsIdent "NonEmpty")] - , importDecl_ (m "Data.Map") & qualified haskellNS & selecting [i"Map", i"mapKeysMonotonic"] - , importDecl_ (m "Data.Proxy") & qualified proxyNS & everything - , importDecl_ (m "Data.String") & qualified haskellNS & selecting [i"fromString"] - , importDecl_ (m stringModule) & qualified haskellNS & selecting [i stringType] - , importDecl_ (m "Data.Vector") & qualified haskellNS & selecting [i"Vector"] - , importDecl_ (m "Data.Word") & qualified haskellNS & selecting [i"Word16", i"Word32", i"Word64"] - , importDecl_ (m "GHC.Enum") & qualified haskellNS & everything - , importDecl_ (m "GHC.Generics") & qualified haskellNS & everything - , importDecl_ (m "Google.Protobuf.Wrappers.Polymorphic") & qualified protobufNS & selecting [HsIThingAll (HsIdent "Wrapped")] - , importDecl_ (m "Unsafe.Coerce") & qualified haskellNS & everything - ] - <> - (if not icUsesGrpc then [] else - [ importDecl_ (m "Network.GRPC.HighLevel.Generated") & alias grpcNS & everything - , importDecl_ (m "Network.GRPC.HighLevel.Client") & alias grpcNS & everything - , importDecl_ (m "Network.GRPC.HighLevel.Server") & alias grpcNS & hiding [i"serverLoop"] - , importDecl_ (m "Network.GRPC.HighLevel.Server.Unregistered") & alias grpcNS & selecting [i"serverLoop"] - ]) - <> - case recordStyle of - RegularRecords -> [] - LargeRecords -> - [ importDecl_ (m "Data.Record.Generic") & qualified lrNS & everything - -- "large-records" stopped exporting "grnf"; we try - -- to get it directly from "large-generics" if we can. - -- - -- Ideally we would generate CPP conditionals so that - -- the version check happens when the generated code - -- is built, but as yet it is unclear how to do that. - -- - -- As a result, we have to enable the version check - -- based on the package version available when building - -- compile-proto-file, and only if large record support - -- is enabled in the library code. -#ifdef LARGE_RECORDS -#if MIN_VERSION_large_generics(0,2,1) - , importDecl_ (m "Data.Record.Generic.NFData") & qualified lrNS & everything -#endif -#endif - , importDecl_ (m "Data.Record.Generic.Rep") & qualified lrNS & everything - , importDecl_ (m "Data.Record.Generic.Rep.Internal") & qualified lrNS & everything - , importDecl_ (m "Data.Record.Plugin.Runtime") & qualified lrNS & everything - -- - -- says that as of large-records-0.4 the plugin does not generate - -- imports, and that "code must now import Data.Record.Plugin to - -- bring largeRecord into scope (necessary for ANN annotations)." - -- We also seem to need to import some Prelude identifiers. - -- - -- Ideally we would generate CPP conditionals so that - -- the version check happens when the generated code - -- is built, but as yet it is unclear how to do that. - -- - -- As a result, we have to enable the version check - -- based on the package version available when building - -- compile-proto-file, and only if large record support - -- is enabled in the library code. -#ifdef LARGE_RECORDS -#if MIN_VERSION_large_records(0,4,0) - , importDecl_ (m "Data.Record.Plugin") & unqualified & selecting [i"largeRecord"] - , importDecl_ (m "Prelude") & unqualified & selecting [i"Eq", i"Int", i"Ord", i"Show", i"error"] -#endif -#endif - ] - where - m = Module - i = HsIVar . HsIdent - s = HsIVar . HsSymbol - - grpcNS = m "HsGRPC" - jsonpbNS = m "HsJSONPB" - lrNS = m "LR" - protobufNS = m "HsProtobuf" - protobufASTNS = m "HsProtobufAST" - proxyNS = m "Proxy" - - -- staged constructors for importDecl - qualified :: Module -> (Bool -> Maybe Module -> a) -> a - qualified m' f = f True (Just m') - - unqualified :: (Bool -> Maybe Module -> a) -> a - unqualified f = f False Nothing - - -- import unqualified AND also under a namespace - alias :: Module -> (Bool -> Maybe Module -> a) -> a - alias m' f = f False (Just m') - - selecting :: [HsImportSpec] -> (Maybe (Bool, [HsImportSpec]) -> a) -> a - selecting is f = f (Just (False, is)) - - hiding :: [HsImportSpec] -> (Maybe (Bool, [HsImportSpec]) -> a) -> a - hiding is f = f (Just (True, is)) - - everything :: (Maybe (Bool, [HsImportSpec]) -> a) -> a - everything f = f Nothing - -defaultMessageDeriving :: [HsQName] -defaultMessageDeriving = map haskellName [ "Show", "Eq", "Ord", "Generic" ] - -defaultEnumDeriving :: [HsQName] -defaultEnumDeriving = map haskellName [ "Show", "Eq", "Generic", "NFData" ] - -defaultServiceDeriving :: [HsQName] -defaultServiceDeriving = map haskellName [ "Generic" ] +{-# LANGUAGE ImplicitParams #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE ViewPatterns #-} + +{-| This module provides functions to generate Haskell declarations for protobuf + messages +-} + +module Proto3.Suite.DotProto.Generate + ( CompileError(..) + , StringType(..) + , parseStringType + , TypeContext + , CompileArgs(..) + , compileDotProtoFile + , compileDotProtoFileOrDie + , renameProtoFile + , hsModuleForDotProto + , renderHsModuleForDotProto + , readDotProtoWithContext + ) where + +import Control.Applicative +import Control.Lens ((&), ix, over, has, filtered) +import Control.Monad (when) +import Control.Monad.Except (MonadError(..), runExceptT) +import Control.Monad.IO.Class (MonadIO(..)) +import Control.Monad.Writer (WriterT, runWriterT, tell) +import Data.Char +import Data.Coerce +import Data.Either (partitionEithers) +import Data.Foldable (fold) +import Data.Function (on) +import Data.Functor ((<&>)) +import Data.List (find, intercalate, nub, sort, sortBy, stripPrefix) +import qualified Data.List.NonEmpty as NE +import Data.List.Split (splitOn) +import Data.List.NonEmpty (NonEmpty (..)) +import qualified Data.Map as M +import Data.Maybe +import Data.Monoid +import Data.Ord (comparing) +import qualified Data.Set as S +import Data.String (fromString) +import GHC.Hs (HsSigType(..)) +import GHC.Parser.Annotation (noLocA) +import GHC.Types.Name.Occurrence (dataName, tcName, varName) +import qualified Data.Text as T +import qualified GHC.Data.FastString as GHC +import qualified GHC.Data.StringBuffer as GHC +import qualified GHC.Hs as GHC +import qualified GHC.Types.Name as GHC +import qualified GHC.Types.Name.Reader as GHC +import qualified GHC.Types.SrcLoc as GHC +import qualified GHC.Utils.Outputable as GHC +import qualified NeatInterpolation as Neat +import Prelude hiding (FilePath) +import Proto3.Suite.DotProto +import Proto3.Suite.DotProto.AST.Lens +import qualified Proto3.Suite.DotProto.Generate.Record as Record +import Proto3.Suite.DotProto.Generate.Syntax +import Proto3.Suite.Haskell.Parser (Logger, parseModule, renderSDoc) +import Proto3.Suite.DotProto.Internal +import Proto3.Wire.Types (FieldNumber (..)) +import Text.Parsec (Parsec, alphaNum, eof, parse, satisfy, try) +import qualified Text.Parsec as Parsec +import qualified Turtle hiding (encodeString) +import qualified Turtle.Compat as Turtle (encodeString) +import Turtle (FilePath, (), (<.>)) + +#if !MIN_VERSION_ghc_lib_parser(9,6,0) +import qualified GHC.Unit.Module.Name as GHC +import qualified GHC.Types.Basic as GHC (PromotionFlag(..)) +#endif + + +-- $setup +-- >>> :set -XTypeApplications + +-------------------------------------------------------------------------------- + +-- +-- * Public interface +-- +data CompileArgs = CompileArgs + { includeDir :: [FilePath] + , extraInstanceFiles :: [FilePath] + , inputProto :: FilePath + , outputDir :: FilePath + , stringType :: StringType + , typeLevelFormat :: Bool + } + +data StringType = StringType String String + -- ^ Qualified module name, then unqualified type name. + +parseStringType :: String -> Either String StringType +parseStringType str = case splitOn "." str of + xs@(_ : _ : _) -> Right $ StringType (intercalate "." $ init xs) (last xs) + _ -> Left "must be in the form Module.Type" + +-- | Generate a Haskell module corresponding to a @.proto@ file +compileDotProtoFile :: Logger -> CompileArgs -> IO (Either CompileError ()) +compileDotProtoFile logger CompileArgs{..} = runExceptT $ do + (dotProto, importTypeContext) <- readDotProtoWithContext includeDir inputProto + modulePathPieces <- traverse renameProtoFile (toModuleComponents dotProto) + + let relativePath = foldr combine mempty (map fromString $ NE.toList modulePathPieces) <.> "hs" + combine p1 p2 | p2 == mempty = p1 + combine p1 p2 = p1 p2 + let modulePath = outputDir relativePath + + Turtle.mktree (Turtle.directory modulePath) + + extraInstances <- foldMapM (getExtraInstances logger) extraInstanceFiles + haskellModule <- + let ?stringType = stringType + ?typeLevelFormat = typeLevelFormat + in renderHsModuleForDotProto extraInstances dotProto importTypeContext + + liftIO (writeFile (Turtle.encodeString modulePath) haskellModule) + where + toModuleComponents :: DotProto -> NonEmpty String + toModuleComponents = components . metaModulePath . protoMeta + +-- | Same as 'compileDotProtoFile', except terminates the program with an error +-- message on failure. +compileDotProtoFileOrDie :: Logger -> CompileArgs -> IO () +compileDotProtoFileOrDie logger args = compileDotProtoFile logger args >>= \case + Left e -> do + -- TODO: pretty print the error messages + let errText = Turtle.format Turtle.w e + let dotProtoPathText = Turtle.format Turtle.fp (inputProto args) + dieLines [Neat.text| + Error: failed to compile "${dotProtoPathText}": + + ${errText} + |] + _ -> pure () + +-- | Renaming protobuf file names to valid Haskell module names. +-- +-- By convention, protobuf filenames are snake case. 'rnProtoFile' renames +-- snake-cased protobuf filenames by: +-- +-- * Replacing occurrences of one or more underscores followed by an +-- alphabetical character with one less underscore. +-- +-- * Capitalizing the first character following the string of underscores. +-- +-- ==== __Examples__ +-- +-- >>> renameProtoFile @(Either CompileError) "abc_xyz" +-- Right "AbcXyz" +-- +-- >>> renameProtoFile @(Either CompileError) "abc_1bc" +-- Left (InvalidModuleName "abc_1bc") +-- +-- >>> renameProtoFile @(Either CompileError) "_" +-- Left (InvalidModuleName "_") +renameProtoFile :: MonadError CompileError m => String -> m String +renameProtoFile filename = + case parse parser "" filename of + Left {} -> throwError (InvalidModuleName filename) + Right (nm, ps, sn) -> pure (toUpperFirst nm ++ rename ps ++ sn) + where + rename :: [(String, String)] -> String + rename = foldMap $ \(us, nm) -> + drop 1 us ++ toUpperFirst nm + + parser :: Parsec String () (String, [(String, String)], String) + parser = do + nm <- pName + ps <- Parsec.many (try pNamePart) + sn <- Parsec.many (satisfy (== '_')) + pure (nm, ps, sn) <* eof + + pNamePart :: Parsec String () (String, String) + pNamePart = liftA2 (,) (Parsec.many1 (satisfy (== '_'))) pName + + pName :: Parsec String () String + pName = liftA2 (:) (satisfy isAlpha) (Parsec.many alphaNum) + +-- | Compile a 'DotProto' AST into a 'String' representing the Haskell +-- source of a module implementing types and instances for the .proto +-- messages and enums. +renderHsModuleForDotProto :: + ( MonadError CompileError m + , (?stringType :: StringType) + , (?typeLevelFormat :: Bool) + ) => + ([HsImportDecl],[HsDecl]) -> + DotProto -> + TypeContext -> + m String +renderHsModuleForDotProto extraInstanceFiles dotProto importCtxt = do + haskellModule <- hsModuleForDotProto extraInstanceFiles dotProto importCtxt + + let languagePragmas = textUnlines $ map (\extn -> "{-# LANGUAGE " <> extn <> " #-}") $ sort extensions + ghcOptionPragmas = textUnlines $ map (\opt -> "{-# OPTIONS_GHC " <> opt <> " #-}") $ sort options + + extensions :: [T.Text] + extensions = nub $ + [ "DataKinds" + , "DeriveAnyClass" + , "DeriveGeneric" + , "GADTs" + , "NamedFieldPuns" + , "NegativeLiterals" + , "OverloadedStrings" + , "TypeApplications" + , "TypeOperators" + ] ++ + (if ?typeLevelFormat then [ "TypeFamilies", "UndecidableInstances" ] else []) + options :: [T.Text] + options = [ "-fno-warn-unused-imports" + , "-fno-warn-name-shadowing" + , "-fno-warn-unused-matches" + , "-fno-warn-missing-export-lists" + ] + + moduleContent :: T.Text + moduleContent = T.pack $ renderSDoc $ GHC.ppr haskellModule + + textUnlines :: [T.Text] -> T.Text + textUnlines = T.intercalate "\n" + + pure $ T.unpack $ [Neat.text| + $languagePragmas + $ghcOptionPragmas + + -- | Generated by Haskell protocol buffer compiler. DO NOT EDIT! + $moduleContent + |] + +-- | Compile a Haskell module AST given a 'DotProto' package AST. +-- Instances given in @eis@ override those otherwise generated. +hsModuleForDotProto :: + ( MonadError CompileError m + , (?stringType :: StringType) + , (?typeLevelFormat :: Bool) + ) => + -- | Extra user-define instances that override default generated instances + ([HsImportDecl], [HsDecl]) -> + -- | + DotProto -> + -- | + TypeContext -> + m (GHC.HsModule +#if MIN_VERSION_ghc_lib_parser(9,6,0) + GHC.GhcPs +#endif + ) +hsModuleForDotProto + (extraImports, extraInstances) + dotProto@DotProto{ protoMeta = DotProtoMeta { metaModulePath = modulePath } + , protoPackage + , protoDefinitions + } + importTypeContext + = do + moduleName <- modulePathModName modulePath + + typeContextImports <- ctxtImports importTypeContext + + let icUsesGrpc = has (traverse._DotProtoService) protoDefinitions + + let importDeclarations = concat + [ defaultImports icUsesGrpc + , extraImports + , typeContextImports ] + + typeContext <- dotProtoTypeContext dotProto + + let toDotProtoDeclaration = + dotProtoDefinitionD protoPackage (typeContext <> importTypeContext) + + let extraInstances' = instancesForModule moduleName extraInstances + + decls <- replaceHsInstDecls extraInstances' <$> + foldMapM toDotProtoDeclaration protoDefinitions + + pure (module_ moduleName Nothing importDeclarations decls) + +getExtraInstances + :: (MonadIO m, MonadError CompileError m) + => Logger -> FilePath -> m ([HsImportDecl], [HsDecl]) +getExtraInstances logger (Turtle.encodeString -> extraInstanceFile) = do + contents <- liftIO $ GHC.hGetStringBuffer extraInstanceFile + let location = GHC.mkRealSrcLoc (GHC.mkFastString extraInstanceFile) 1 1 + maybeModule <- liftIO $ parseModule logger location contents + case maybeModule of + Nothing -> + internalError (T.unpack "Error: Failed to parse instance file") + Just (GHC.L _ m) -> do + let isInstDecl (GHC.L _ GHC.InstD{}) = True + isInstDecl _ = False + pure (GHC.hsmodImports m, filter isInstDecl (GHC.hsmodDecls m)) + +-- | This very specific function will only work for the qualification on the very first type +-- in the object of an instance declaration. Those are the only sort of instance declarations +-- generated within this code, so it suffices. +instancesForModule :: Module -> [HsDecl] -> [HsDecl] +instancesForModule m = mapMaybe go + where + go ( GHC.L instX + ( GHC.InstD clsInstX + ( GHC.ClsInstD clsInstDeclX clsInstDecl@GHC.ClsInstDecl + { cid_poly_ty = GHC.L tyX (HsSig ext bndrs ty) } ) ) ) + | Just (tc, GHC.L _ (GHC.HsTyVar _ GHC.NotPromoted (GHC.L _ (GHC.Qual tm i))) : ts) <- + splitTyConApp ty, m == tm = + Just ( GHC.L instX + ( GHC.InstD clsInstX + ( GHC.ClsInstD clsInstDeclX clsInstDecl + { GHC.cid_poly_ty = GHC.L tyX (HsSig ext bndrs (tyConApply tc (typeNamed_ (noLocA (GHC.Unqual i)) : ts))) + } ) ) ) + go _ = Nothing + +-- | For each thing in @base@ replaces it if it finds a matching @override@. +-- +-- Current Limitations: The type of the type class instance and the corresponding +-- override must both be monomorphic; otherwise they will not match each other. +-- Furthermore, comparison is based on unqualified names, so please ensure that +-- those unqualified names are unambiguous or false matches may occur. +replaceHsInstDecls :: [HsDecl] -> [HsDecl] -> [HsDecl] +replaceHsInstDecls overrides base = concatMap (mbReplace) base + where + -- instances defined separately from data type definition: + mbReplace :: HsDecl -> [HsDecl] + mbReplace hid@(typeOfInstDecl -> Just classSig) = + [fromMaybe hid (search classSig)] + + -- instances listed in "deriving" clause of data type or newtype definition: + mbReplace ( GHC.L tyClDX + ( GHC.TyClD dataDeclX + ( dataDecl@GHC.DataDecl + { tcdLName = tyn + , tcdDataDefn = dd@GHC.HsDataDefn + { dd_derivs = clauses + } + } ) ) ) = + let ty = typeNamed_ tyn + (uncustomized, customized) = partitionEithers (concatMap (clause ty) clauses) + in ( GHC.L tyClDX + ( GHC.TyClD dataDeclX + ( dataDecl { GHC.tcdDataDefn = dd + { GHC.dd_derivs = uncustomized + } } ) ) ) + : customized + + -- irrelevant declarations remain unchanged: + mbReplace hid = [hid] + + clause :: HsType -> HsDerivingClause -> [Either HsDerivingClause HsDecl] + clause ty (splitDerivingClause -> (strategy, classSigs)) = + let (uncustomized, customized) = partitionEithers (map (deriv ty) classSigs) + in maybe id ((:) . Left) (derivingClause_ strategy uncustomized) (map Right customized) + + deriv :: + HsType -> + (HsOuterSigTyVarBndrs, HsType) -> + Either (HsOuterSigTyVarBndrs, HsType) HsDecl + deriv ty classSig@(bindings, classType) = + maybe (Left classSig) Right (search (bindings, tyApp classType ty)) + + -- | NOTE: 'getSig' must return 'Just' for *both* the goal and the override + -- in order for there to be a match: 'Nothing' for both means no match. + search :: (HsOuterSigTyVarBndrs, HsType) -> Maybe HsDecl + search y = do + desired <- getSig y + find (\x -> Just desired == (getSig =<< typeOfInstDecl x)) overrides + + getSig :: (HsOuterSigTyVarBndrs, HsType) -> Maybe SimpleTypeName + getSig (GHC.HsOuterImplicit _, x) = simpleType x + getSig _ = empty + +-- | A simplified representation of certain Haskell types. +data SimpleTypeName = SimpleTypeName GHC.OccName [SimpleTypeName] + deriving Eq + +-- | Types are difficult to compare in general, but for many +-- of the simpler types we can find a corresponding simple +-- description that is practical for us to compare. +-- +-- WARNING: As legacy behavior we remove all qualifiers, rather than +-- normalizing them in some way that considers equivalence of module +-- qualifiers. This behavior could potentially cause incorrect +-- results if two modules provide the same type name. +simpleType :: HsType -> Maybe SimpleTypeName +simpleType (GHC.L _ (GHC.HsParTy _ x)) = simpleType x +simpleType x = do + (tc, as) <- splitTyConApp x + sas <- traverse simpleType as + pure (SimpleTypeName (unQual tc) sas) + where + unQual :: HsName -> GHC.OccName + unQual (GHC.L _ (GHC.Unqual n)) = n + unQual (GHC.L _ (GHC.Qual _ n)) = n + unQual (GHC.L _ (GHC.Orig _ n)) = n + unQual (GHC.L _ (GHC.Exact n)) = GHC.nameOccName n + +-- | If both types are sufficiently simple, +-- then return the result of an equality test. +-- +-- WARNING: As legacy behavior we remove all qualifiers, rather than +-- normalizing them in some way that considers equivalence of module +-- qualifiers. This behavior could potentially cause incorrect +-- results if two modules provide the same type name. +simpleTypeEq :: HsType -> HsType -> Maybe Bool +simpleTypeEq a b = (==) <$> simpleType a <*> simpleType b + +-- | Parses the file at the given path and produces an AST along with a +-- 'TypeContext' representing all types from imported @.proto@ files, using the +-- first parameter as a list of paths to search for imported files. Terminates +-- with exit code 1 when an included file cannot be found in the search path. +readDotProtoWithContext + :: (MonadError CompileError m, MonadIO m) + => [FilePath] + -> FilePath + -> m (DotProto, TypeContext) +readDotProtoWithContext [] toplevelProto = do + -- If we're not given a search path, default to using the current working + -- directory, as `protoc` does + cwd <- Turtle.pwd + readDotProtoWithContext [cwd] toplevelProto + +readDotProtoWithContext searchPaths toplevelProto = do + dp <- importProto searchPaths toplevelProto toplevelProto + let importIt = readImportTypeContext searchPaths toplevelProto (S.singleton toplevelProto) + tc <- foldMapM importIt (protoImports dp) + pure (dp, tc) + +-- | Build the type context for an import, resolving transitive imports. +readImportTypeContext + :: (MonadError CompileError m, MonadIO m) + => [FilePath] + -> FilePath + -> S.Set FilePath + -> DotProtoImport + -> m TypeContext +readImportTypeContext searchPaths toplevelFP alreadyRead (DotProtoImport _ path) + | path `S.member` alreadyRead = throwError (CircularImport path) + | otherwise = do + import_ <- importProto searchPaths toplevelFP path + let importPkgSpec = protoPackage import_ + + let fixImportTyInfo tyInfo = + tyInfo { dotProtoTypeInfoPackage = importPkgSpec + , dotProtoTypeInfoModulePath = metaModulePath . protoMeta $ import_ + } + importTypeContext <- fmap fixImportTyInfo <$> dotProtoTypeContext import_ + + let prefixWithPackageName = + case importPkgSpec of + DotProtoPackageSpec packageName -> concatDotProtoIdentifier packageName + DotProtoNoPackage -> pure + + qualifiedTypeContext <- mapKeysM prefixWithPackageName importTypeContext + + let isPublic (DotProtoImport q _) = q == DotProtoImportPublic + transitiveImportsTC <- + foldMapOfM (traverse . filtered isPublic) + (readImportTypeContext searchPaths toplevelFP (S.insert path alreadyRead)) + (protoImports import_) + + pure $ importTypeContext <> qualifiedTypeContext <> transitiveImportsTC + +-- | Given a type context, generates the Haskell import statements necessary to +-- import all the required types. Excludes module "Google.Protobuf.Wrappers" +-- because the generated code does not actually make use of wrapper types +-- as such; instead it uses @Maybe a@, where @a@ is the wrapped type. +ctxtImports :: MonadError CompileError m => TypeContext -> m [HsImportDecl] +ctxtImports = + fmap (map mkImport . nub . filter (GHC.mkModuleName "Google.Protobuf.Wrappers" /=)) + . traverse (modulePathModName . dotProtoTypeInfoModulePath) + . M.elems + where + mkImport modName = importDecl_ modName True Nothing Nothing + +-------------------------------------------------------------------------------- +-- +-- * Helper functions for Haskell code generation +-- + +-- ** Names + +-- | Generate the Haskell type name for a 'DotProtoTypeInfo' for a message / +-- enumeration being compiled. NB: We ignore the 'dotProtoTypeInfoPackage' +-- field of the 'DotProtoTypeInfo' parameter, instead demanding that we have +-- been provided with a valid module path in its 'dotProtoTypeInfoModulePath' +-- field. The latter describes the name of the Haskell module being generated. +msgTypeFromDpTypeInfo :: MonadError CompileError m + => TypeContext -> DotProtoTypeInfo -> DotProtoIdentifier -> m HsType +msgTypeFromDpTypeInfo ctxt DotProtoTypeInfo{..} ident = do + modName <- modulePathModName dotProtoTypeInfoModulePath + identName <- qualifiedMessageTypeName ctxt dotProtoTypeInfoParent ident + pure $ typeNamed_ $ qual_ modName tcName identName + +modulePathModName :: MonadError CompileError m => Path -> m Module +modulePathModName (Path comps) = + GHC.mkModuleName . intercalate "." <$> traverse typeLikeName (NE.toList comps) + +_pkgIdentModName :: MonadError CompileError m => DotProtoIdentifier -> m Module +_pkgIdentModName (Single s) = GHC.mkModuleName <$> typeLikeName s +_pkgIdentModName (Dots path) = modulePathModName path +_pkgIdentModName x = throwError (InvalidPackageName x) + + +-- ** Dhall + +#ifdef DHALL +hsDhallPB :: String +hsDhallPB = "HsDhallPb" + +dhallPBName :: GHC.NameSpace -> String -> HsQName +dhallPBName = qual_ (GHC.mkModuleName hsDhallPB) + +-- *** Generate Dhall Interpret and Inject generic instances + +fromDhall, toDhall :: String +(fromDhall, toDhall) = +#if MIN_VERSION_dhall(1,27,0) + ("FromDhall", "ToDhall") +#else + ("Interpret", "Inject") +#endif + +dhallInterpretInstDecl :: String -> HsDecl +dhallInterpretInstDecl typeName = + instDecl_ (dhallPBName tcName fromDhall) + [ type_ typeName ] + [ ] + +dhallInjectInstDecl :: String -> HsDecl +dhallInjectInstDecl typeName = + instDecl_ (dhallPBName tcName toDhall) + [ type_ typeName ] + [ ] +#endif + +-- ** Helpers to wrap/unwrap types for protobuf (de-)serialization + +data FieldContext = WithinMessage | WithinOneOf + deriving (Eq, Show) + +coerceE :: Bool -> Bool -> HsType -> HsType -> Maybe HsExp +coerceE _ _ from to | Just True <- simpleTypeEq from to = Nothing +coerceE overTyCon unsafe from to = + Just $ applyAt coerceF [from, to] + where + coerceF | unsafe = var_ (name "unsafeCoerce") + | otherwise = var_ (name "coerce") + name | overTyCon = protobufName varName . (<> "Over") + | otherwise = haskellName varName + +wrapFunE :: + ( MonadError CompileError m + , (?stringType :: StringType) + ) => + Bool -> + FieldContext -> + TypeContext -> + [DotProtoOption] -> + DotProtoType -> + m (Maybe HsExp) +wrapFunE overTyCon fc ctxt opts dpt = + coerceE overTyCon (isMap dpt) + <$> dptToHsType fc ctxt dpt + <*> dptToHsTypeWrapped fc opts ctxt dpt + +wrapE :: + ( MonadError CompileError m + , (?stringType :: StringType) + ) => + FieldContext -> + TypeContext -> + [DotProtoOption] -> + DotProtoType -> + HsExp -> + m HsExp +wrapE fc ctxt opts dpt e = + maybeModify e <$> wrapFunE False fc ctxt opts dpt + +unwrapFunE :: + ( MonadError CompileError m + , (?stringType :: StringType) + ) => + Bool -> + FieldContext -> + TypeContext -> + [DotProtoOption] -> + DotProtoType -> + m (Maybe HsExp) +unwrapFunE overTyCon fc ctxt opts dpt = + coerceE overTyCon (isMap dpt) + <$> dptToHsTypeWrapped fc opts ctxt dpt + <*> dptToHsType fc ctxt dpt + +unwrapE :: + ( MonadError CompileError m + , (?stringType :: StringType) + ) => + FieldContext -> + TypeContext -> + [DotProtoOption] -> + DotProtoType -> + HsExp -> + m HsExp +unwrapE fc ctxt opts dpt e = do + maybeModify e <$> unwrapFunE True fc ctxt opts dpt + +-------------------------------------------------------------------------------- +-- +-- * Functions to convert 'DotProtoType' into Haskell types +-- + +-- | Convert a dot proto type to a Haskell type +dptToHsType :: + ( MonadError CompileError m + , (?stringType :: StringType) + ) => + FieldContext -> + TypeContext -> + DotProtoType -> + m HsType +dptToHsType fc = foldDPT (dptToHsContType fc) dpptToHsType + +-- | Convert a dot proto type to a wrapped Haskell type +dptToHsTypeWrapped :: + ( MonadError CompileError m + , (?stringType :: StringType) + ) => + FieldContext -> + [DotProtoOption] -> + TypeContext -> + DotProtoType -> + m HsType +dptToHsTypeWrapped fc opts = + foldDPT + -- The wrapper for the collection type replaces the native haskell + -- collection type, so try that first. + (\ctxt ty -> maybe (dptToHsContType fc ctxt ty) id (dptToHsWrappedContType fc ctxt opts ty)) + -- Always wrap the primitive type. + dpptToHsTypeWrapped + +-- | Like 'dptToHsTypeWrapped' but without use of +-- 'dptToHsContType' or 'dptToHsWrappedContType'. +dpptToHsTypeWrapped :: + ( MonadError CompileError m + , (?stringType :: StringType) + ) => + TypeContext -> + DotProtoPrimType -> + m HsType +dpptToHsTypeWrapped ctxt | StringType _ stringType <- ?stringType = \case + Int32 -> + pure $ primType_ "Int32" + Int64 -> + pure $ primType_ "Int64" + SInt32 -> + pure $ protobufSignedType_ $ primType_ "Int32" + SInt64 -> + pure $ protobufSignedType_ $ primType_ "Int64" + UInt32 -> + pure $ primType_ "Word32" + UInt64 -> + pure $ primType_ "Word64" + Fixed32 -> + pure $ protobufFixedType_ $ primType_ "Word32" + Fixed64 -> + pure $ protobufFixedType_ $ primType_ "Word64" + SFixed32 -> + pure $ protobufSignedType_ $ protobufFixedType_ $ primType_ "Int32" + SFixed64 -> + pure $ protobufSignedType_ $ protobufFixedType_ $ primType_ "Int64" + String -> + pure $ protobufStringType_ stringType + Bytes -> + pure $ protobufBytesType_ "ByteString" + Bool -> + pure $ primType_ "Bool" + Float -> + pure $ primType_ "Float" + Double -> + pure $ primType_ "Double" + Named (Dots (Path ("google" :| ["protobuf", x]))) + | x == "Int32Value" -> + pure $ protobufWrappedType_ $ primType_ "Int32" + | x == "Int64Value" -> + pure $ protobufWrappedType_ $ primType_ "Int64" + | x == "UInt32Value" -> + pure $ protobufWrappedType_ $ primType_ "Word32" + | x == "UInt64Value" -> + pure $ protobufWrappedType_ $ primType_ "Word64" + | x == "StringValue" -> + pure $ protobufWrappedType_ $ protobufStringType_ stringType + | x == "BytesValue" -> + pure $ protobufWrappedType_ $ protobufBytesType_ "ByteString" + | x == "BoolValue" -> + pure $ protobufWrappedType_ $ primType_ "Bool" + | x == "FloatValue" -> + pure $ protobufWrappedType_ $ primType_ "Float" + | x == "DoubleValue" -> + pure $ protobufWrappedType_ $ primType_ "Double" + Named msgName -> + case M.lookup msgName ctxt of + Just ty@(DotProtoTypeInfo { dotProtoTypeInfoKind = DotProtoKindEnum }) -> + tyApp (protobufType_ "Enumerated") <$> msgTypeFromDpTypeInfo ctxt ty msgName + Just ty -> msgTypeFromDpTypeInfo ctxt ty msgName + Nothing -> noSuchTypeError msgName + +foldDPT :: MonadError CompileError m + => (TypeContext -> DotProtoType -> HsType -> HsType) + -> (TypeContext -> DotProtoPrimType -> m HsType) + -> TypeContext + -> DotProtoType + -> m HsType +foldDPT dptToHsCont foldPrim ctxt dpt = + let + prim = foldPrim ctxt + go = foldDPT dptToHsCont foldPrim ctxt + cont = dptToHsCont ctxt dpt + in + case dpt of + Prim pType -> cont <$> prim pType + Optional pType -> cont <$> prim pType + Repeated pType -> cont <$> prim pType + NestedRepeated pType -> cont <$> prim pType + Map k v | validMapKey k -> tyApp . cont <$> prim k <*> go (Prim v) -- need to 'Nest' message types + | otherwise -> throwError $ InvalidMapKeyType (show $ pPrint k) + +-- | Translate DotProtoType constructors to wrapped Haskell container types +-- (for Message serde instances). +-- +-- When the given 'FieldContext' is 'WithinOneOf' we do not wrap submessages +-- in "Maybe" because the entire oneof is already wrapped in a "Maybe". +dptToHsWrappedContType :: FieldContext -> TypeContext -> [DotProtoOption] -> DotProtoType -> Maybe (HsType -> HsType) +dptToHsWrappedContType fc ctxt opts = \case + Prim (Named tyName) + | WithinMessage <- fc, isMessage ctxt tyName + -> Just $ tyApp (protobufType_ "Nested") + Optional (Named tyName) + | isMessage ctxt tyName -> Just $ tyApp (protobufType_ "Nested") + Optional _ -> Just $ tyApp maybeT . tyApp forceEmitT + Repeated (Named tyName) + | isMessage ctxt tyName -> Just $ tyApp (protobufType_ "NestedVec") + Repeated ty + | isUnpacked opts -> Just $ tyApp (protobufType_ "UnpackedVec") + | isPacked opts -> Just $ tyApp (protobufType_ "PackedVec") + | isPackable ctxt ty -> Just $ tyApp (protobufType_ "PackedVec") + | otherwise -> Just $ tyApp (protobufType_ "UnpackedVec") + _ -> Nothing + +-- | Translate DotProtoType to Haskell container types. +-- +-- When the given 'FieldContext' is 'WithinOneOf' we do not wrap submessages +-- in "Maybe" because the entire oneof is already wrapped in a "Maybe". +dptToHsContType :: FieldContext -> TypeContext -> DotProtoType -> HsType -> HsType +dptToHsContType fc ctxt = \case + Prim (Named tyName) | WithinMessage <- fc, isMessage ctxt tyName + -> tyApp $ primType_ "Maybe" + Optional _ -> tyApp $ primType_ "Maybe" + Repeated _ -> tyApp $ primType_ "Vector" + NestedRepeated _ -> tyApp $ primType_ "Vector" + Map _ _ -> tyApp $ primType_ "Map" + _ -> id + +-- | Convert a dot proto prim type to an unwrapped Haskell type +dpptToHsType :: + ( MonadError CompileError m + , (?stringType :: StringType) + ) => + TypeContext -> + DotProtoPrimType -> + m HsType +dpptToHsType ctxt | StringType _ stringType <- ?stringType = \case + Int32 -> pure $ primType_ "Int32" + Int64 -> pure $ primType_ "Int64" + SInt32 -> pure $ primType_ "Int32" + SInt64 -> pure $ primType_ "Int64" + UInt32 -> pure $ primType_ "Word32" + UInt64 -> pure $ primType_ "Word64" + Fixed32 -> pure $ primType_ "Word32" + Fixed64 -> pure $ primType_ "Word64" + SFixed32 -> pure $ primType_ "Int32" + SFixed64 -> pure $ primType_ "Int64" + String -> pure $ primType_ stringType + Bytes -> pure $ primType_ "ByteString" + Bool -> pure $ primType_ "Bool" + Float -> pure $ primType_ "Float" + Double -> pure $ primType_ "Double" + Named (Dots (Path ("google" :| ["protobuf", x]))) + | x == "Int32Value" -> pure $ primType_ "Int32" + | x == "Int64Value" -> pure $ primType_ "Int64" + | x == "UInt32Value" -> pure $ primType_ "Word32" + | x == "UInt64Value" -> pure $ primType_ "Word64" + | x == "StringValue" -> pure $ primType_ stringType + | x == "BytesValue" -> pure $ primType_ "ByteString" + | x == "BoolValue" -> pure $ primType_ "Bool" + | x == "FloatValue" -> pure $ primType_ "Float" + | x == "DoubleValue" -> pure $ primType_ "Double" + Named msgName -> + case M.lookup msgName ctxt of + Just ty@(DotProtoTypeInfo { dotProtoTypeInfoKind = DotProtoKindEnum }) -> + tyApp (protobufType_ "Enumerated") <$> msgTypeFromDpTypeInfo ctxt ty msgName + Just ty -> msgTypeFromDpTypeInfo ctxt ty msgName + Nothing -> noSuchTypeError msgName + +validMapKey :: DotProtoPrimType -> Bool +validMapKey = (`elem` [ Int32, Int64, SInt32, SInt64, UInt32, UInt64 + , Fixed32, Fixed64, SFixed32, SFixed64 + , String, Bool]) + +-- | Convert a dot proto type to a Haskell type of kind `Proto3.Suite.Form.Cardinality`. +-- It is ASSUMED that the field with this type is NOT part of a @oneof@. +dptToFormCardinality :: + MonadError CompileError m => [DotProtoOption] -> TypeContext -> DotProtoType -> m HsType +dptToFormCardinality opts ctxt = \case + Prim (Named tyName) + | isMessage ctxt tyName -> pure formOptionalT + Prim _ -> pure formImplicitT + Optional _ -> pure formOptionalT + Repeated (Named tyName) + | isMessage ctxt tyName -> pure unpacked + Repeated pType + | isUnpacked opts -> pure unpacked + | isPacked opts -> pure packed + | isPackable ctxt pType -> pure packed + | otherwise -> pure unpacked + NestedRepeated pType -> internalError $ "unexpected NestedRepeated on " ++ show pType + Map k _ + | validMapKey k -> pure unpacked + | otherwise -> throwError $ InvalidMapKeyType (show $ pPrint k) + where + packed = tyApp formRepeatedT formPackedT + unpacked = tyApp formRepeatedT formUnpackedT + +-- | Convert a dot proto type to a Haskell type of kind `Proto3.Suite.Form.ProtoType`, +-- with `Proto3.Suite.Form.Optional` serving the role elsewhere served by wrapper types +-- and by `Proto3.Suite.Types.ForceEmit`. +dptToFormType :: MonadError CompileError m => TypeContext -> DotProtoType -> m HsType +dptToFormType ctxt = \case + Prim pType -> dpptToFormType ctxt pType + Optional pType -> dpptToFormType ctxt pType + Repeated pType -> dpptToFormType ctxt pType + NestedRepeated pType -> internalError $ "unexpected NestedRepeated on " ++ show pType + Map k v + | validMapKey k -> do + k2 <- dpptToFormType ctxt k + v2 <- dptToFormType ctxt (Prim v) + pure $ tyApply formMapT [k2, v2] + | otherwise -> + throwError $ InvalidMapKeyType (show $ pPrint k) + +-- | Like 'dptToFormType' but for primitive types. +dpptToFormType :: + forall m . + MonadError CompileError m => + TypeContext -> + DotProtoPrimType -> + m HsType +dpptToFormType ctxt = \case + Int32 -> + pure formInt32T + Int64 -> + pure formInt64T + SInt32 -> + pure formSInt32T + SInt64 -> + pure formSInt64T + UInt32 -> + pure formUInt32T + UInt64 -> + pure formUInt64T + Fixed32 -> + pure formFixed32T + Fixed64 -> + pure formFixed64T + SFixed32 -> + pure formSFixed32T + SFixed64 -> + pure formSFixed64T + String -> + pure formStringT + Bytes -> + pure formBytesT + Bool -> + pure formBoolT + Float -> + pure formFloatT + Double -> + pure formDoubleT + Named (Dots (Path ("google" :| ["protobuf", x]))) + | x == "Int32Value" -> + wrapper formInt32T + | x == "Int64Value" -> + wrapper formInt64T + | x == "UInt32Value" -> + wrapper formUInt32T + | x == "UInt64Value" -> + wrapper formUInt64T + | x == "StringValue" -> + wrapper formStringT + | x == "BytesValue" -> + wrapper formBytesT + | x == "BoolValue" -> + wrapper formBoolT + | x == "FloatValue" -> + wrapper formFloatT + | x == "DoubleValue" -> + wrapper formDoubleT + Named msgName -> + case M.lookup msgName ctxt of + Just ty@(DotProtoTypeInfo { dotProtoTypeInfoKind = DotProtoKindEnum }) -> + tyApp formEnumerationT <$> msgTypeFromDpTypeInfo ctxt ty msgName + Just ty -> tyApp formMessageT <$> msgTypeFromDpTypeInfo ctxt ty msgName + Nothing -> noSuchTypeError msgName + where + wrapper :: HsType -> m HsType + wrapper = pure . tyApp formMessageT . tyApp formWrapperT + +-------------------------------------------------------------------------------- +-- +-- * Code generation +-- + +-- ** Generate instances for a 'DotProto' package + +dotProtoDefinitionD :: + ( MonadError CompileError m + , (?stringType :: StringType) + , (?typeLevelFormat :: Bool) + ) => + DotProtoPackageSpec -> + TypeContext -> + DotProtoDefinition -> + m [HsDecl] +dotProtoDefinitionD pkgSpec ctxt = \case + DotProtoMessage _ messageName messageParts -> + dotProtoMessageD ctxt Anonymous messageName messageParts + + DotProtoEnum _ enumName enumParts -> + dotProtoEnumD Anonymous enumName enumParts + + DotProtoService _ serviceName serviceParts -> + dotProtoServiceD pkgSpec ctxt serviceName serviceParts + +-- | Generate 'Named' instance for a type in this package +namedInstD :: String -> HsDecl +namedInstD messageName = + instDecl_ (protobufName tcName "Named") + [ type_ messageName ] + [ functionS_ "nameOf" [nameOf] ] + where + nameOf = ([wild_], apply fromStringE [ str_ messageName ]) + +hasDefaultInstD :: String -> HsDecl +hasDefaultInstD messageName = + instDecl_ (protobufName tcName "HasDefault") + [ type_ messageName ] + [ ] + +-- ** Generate types and instances for .proto messages + +-- | Generate data types, 'Bounded', 'Enum', 'FromJSONPB', 'Named', 'Message', +-- 'ToJSONPB' instances as appropriate for the given 'DotProtoMessagePart's +dotProtoMessageD :: + forall m . + ( MonadError CompileError m + , (?stringType :: StringType) + , (?typeLevelFormat :: Bool) + ) => + TypeContext -> + DotProtoIdentifier -> + DotProtoIdentifier -> + [DotProtoMessagePart] -> + m [HsDecl] +dotProtoMessageD ctxt parentIdent messageIdent messageParts = do + messageName <- qualifiedMessageName parentIdent messageIdent + + let mkDataDecl flds = + dataDecl_ messageName + [] + [ recDecl_ (unqual_ varName messageName) flds ] + defaultMessageDeriving + +#ifdef SWAGGER + let getName = \case + DotProtoMessageField fld -> (: []) <$> getFieldNameForSchemaInstanceDeclaration fld + DotProtoMessageOneOf ident _ -> (: []) . (Nothing, ) <$> dpIdentUnqualName ident + _ -> pure [] +#endif + + messageDataDecl <- mkDataDecl <$> foldMapM (messagePartFieldD messageName) messageParts + + foldMapM id + [ sequence + [ pure messageDataDecl + , pure (Record.nfDataInstD messageDataDecl messageName) + , pure (namedInstD messageName) + , pure (hasDefaultInstD messageName) + , messageInstD ctxt' parentIdent messageIdent messageParts + + , toJSONPBMessageInstD ctxt' parentIdent messageIdent messageParts + , fromJSONPBMessageInstD ctxt' parentIdent messageIdent messageParts + + -- Generate Aeson instances in terms of JSONPB instances + , pure (toJSONInstDecl messageName) + , pure (fromJSONInstDecl messageName) + +#ifdef SWAGGER + -- And the Swagger ToSchema instance corresponding to JSONPB encodings + , toSchemaInstanceDeclaration ctxt' messageName Nothing + =<< foldMapM getName messageParts +#endif + +#ifdef DHALL + -- Generate Dhall instances + , pure (dhallInterpretInstDecl messageName) + , pure (dhallInjectInstDecl messageName) +#endif + ] + + , if ?typeLevelFormat + then typeLevelInstsD ctxt' parentIdent messageIdent messageParts + else pure [] + + -- Nested regular and oneof message decls + , foldMapOfM (traverse . _DotProtoMessageDefinition) + nestedDecls + messageParts + + , foldMapOfM (traverse . _DotProtoMessageOneOf) + (uncurry $ nestedOneOfDecls messageName) + messageParts + ] + + where + ctxt' :: TypeContext + ctxt' = maybe mempty dotProtoTypeChildContext (M.lookup messageIdent ctxt) + <> ctxt + + messagePartFieldD :: String -> DotProtoMessagePart -> m [([HsName], HsBangType)] + messagePartFieldD messageName (DotProtoMessageField DotProtoField{..}) = do + fullName <- prefixedFieldName messageName =<< dpIdentUnqualName dotProtoFieldName + fullTy <- dptToHsType WithinMessage ctxt' dotProtoFieldType + pure [ ([unqual_ varName fullName], unbangedTy_ fullTy) ] + + messagePartFieldD messageName (DotProtoMessageOneOf fieldName _) = do + fullName <- prefixedFieldName messageName =<< dpIdentUnqualName fieldName + qualTyName <- prefixedConName messageName =<< dpIdentUnqualName fieldName + let fullTy = tyConApp (haskellName tcName "Maybe") . type_ $ qualTyName + pure [ ([unqual_ varName fullName], unbangedTy_ fullTy) ] + + messagePartFieldD _ _ = pure [] + + nestedDecls :: DotProtoDefinition -> m [HsDecl] + nestedDecls (DotProtoMessage _ subMsgName subMessageDef) = do + parentIdent' <- concatDotProtoIdentifier parentIdent messageIdent + dotProtoMessageD ctxt' parentIdent' subMsgName subMessageDef + + nestedDecls (DotProtoEnum _ subEnumName subEnumDef) = do + parentIdent' <- concatDotProtoIdentifier parentIdent messageIdent + dotProtoEnumD parentIdent' subEnumName subEnumDef + + nestedDecls _ = pure [] + + nestedOneOfDecls :: String -> DotProtoIdentifier -> [DotProtoField] -> m [HsDecl] + nestedOneOfDecls messageName identifier fields = do + fullName <- prefixedConName messageName =<< dpIdentUnqualName identifier + + (cons, _idents) <- fmap unzip (mapM (oneOfCons fullName) fields) + +#ifdef SWAGGER + toSchemaInstance <- toSchemaInstanceDeclaration ctxt' fullName (Just _idents) + =<< mapM getFieldNameForSchemaInstanceDeclaration fields +#endif + + let nestedDecl = dataDecl_ fullName [] cons defaultMessageDeriving + pure [ nestedDecl + , Record.nfDataInstD nestedDecl fullName + , namedInstD fullName +#ifdef SWAGGER + , toSchemaInstance +#endif + +#ifdef DHALL + , dhallInterpretInstDecl fullName + , dhallInjectInstDecl fullName +#endif + ] + + oneOfCons :: String -> DotProtoField -> m (HsConDecl, HsName) + oneOfCons fullName DotProtoField{..} = do + consTy <- dptToHsType WithinOneOf ctxt' dotProtoFieldType + consName <- prefixedConName fullName =<< dpIdentUnqualName dotProtoFieldName + let ident = unqual_ dataName consName + pure (conDecl_ ident [unbangedTy_ consTy], ident) + +-- *** Generate type family instances providing type-level information about protobuf formats. + +type FieldOccurrences = (Histogram FieldName, Histogram FieldNumber) + +data FieldSpec = FieldSpec + { fieldSpecName :: FieldName + , fieldSpecNumber :: FieldNumber + , fieldSpecOneOf :: Maybe FieldName + , fieldSpecCardinality :: HsType + , fieldSpecProtoType :: HsType + } + +typeLevelInstsD :: + forall m . + ( MonadError CompileError m + , (?stringType :: StringType) + ) => + TypeContext -> + DotProtoIdentifier-> + DotProtoIdentifier -> + [DotProtoMessagePart]-> + m [HsDecl] +typeLevelInstsD ctxt parentIdent msgIdent messageParts = do + msgName <- qualifiedMessageName parentIdent msgIdent + + qualifiedFields <- getQualifiedFields msgName messageParts + + (fieldSpecLists, (fieldNames, fieldNumbers)) <- + runWriterT (mapM mkFieldSpecs qualifiedFields) + + let (sort -> oneOfs, sortBy (compare `on` fieldSpecName) -> fieldSpecs) = fold fieldSpecLists + repeatedFieldNames = mulipleOccurrencesOnly fieldNames + repeatedFieldNumbers = mulipleOccurrencesOnly fieldNumbers + + when (repeatedFieldNames /= mempty || repeatedFieldNumbers /= mempty) $ + throwError $ RedefinedFields repeatedFieldNames repeatedFieldNumbers + + when (let Histogram m = fieldNames in M.member "" m) $ + internalError $ "empty field name within message " ++ show msgIdent + + let msgNameT = type_ msgName + msgNumberOf = unqual_ tcName (msgName ++ "_NumberOf") + msgProtoTypeOf = unqual_ tcName (msgName ++ "_ProtoTypeOf") + msgOneOfOf = unqual_ tcName (msgName ++ "_OneOfOf") + msgCardinalityOf = unqual_ tcName (msgName ++ "_CardinalityOf") + fieldNameVar = tvarn_ "name" + fieldNameVarT = typeNamed_ fieldNameVar + fieldNameVarB = kindedTyVar_ synDef fieldNameVar symbolT + err msg = + [(Nothing, [fieldNameVarT], tyApp typeErrorT (tyApply msg [msgNameT, fieldNameVarT]))] + toSym = symT . getFieldName + fieldNameT = toSym . fieldSpecName + fieldNumberT = natTLit . getFieldNumber . fieldSpecNumber + oneOfT = maybe (symT "") toSym . fieldSpecOneOf + + let onFields :: (FieldSpec -> HsType) -> [(Maybe [HsTyVarBndrU], [HsType], HsType)] + onFields rhs = fieldSpecs <&> \f -> (Nothing, [ fieldNameT f ], rhs f) + + onOneOfs :: (FieldName -> HsType) -> [(Maybe [HsTyVarBndrU], [HsType], HsType)] + onOneOfs rhs = oneOfs <&> \o -> (Nothing, [ toSym o ], rhs o) + + let namesOf :: HsDecl + numberOf, protoTypeOf, oneOfOf, cardinalityOf :: [HsDecl] + namesOf = tyFamInstDecl_ formNamesOf Nothing [ msgNameT ] + (listT_ (map fieldNameT fieldSpecs)) + numberOf = + [ tyFamInstDecl_ formNumberOf Nothing [ msgNameT, fieldNameVarT ] + (tyApp (typeNamed_ msgNumberOf) fieldNameVarT) + , closedTyFamDecl_ msgNumberOf [ fieldNameVarB ] natT + (onFields fieldNumberT ++ err formFieldNotFound) + ] + protoTypeOf = + [ tyFamInstDecl_ formProtoTypeOf Nothing [ msgNameT, fieldNameVarT ] + (tyApp (typeNamed_ msgProtoTypeOf) fieldNameVarT) + , closedTyFamDecl_ msgProtoTypeOf [ fieldNameVarB ] formProtoTypeT + (onFields fieldSpecProtoType ++ err formFieldNotFound) + ] + oneOfOf = + [ tyFamInstDecl_ formOneOfOf Nothing [ msgNameT, fieldNameVarT ] + (tyApp (typeNamed_ msgOneOfOf) fieldNameVarT) + , closedTyFamDecl_ msgOneOfOf [ fieldNameVarB ] symbolT + (onFields oneOfT ++ onOneOfs toSym ++ err formFieldOrOneOfNotFound) + ] + cardinalityOf = + [ tyFamInstDecl_ formCardinalityOf Nothing [ msgNameT, fieldNameVarT ] + (tyApp (typeNamed_ msgCardinalityOf) fieldNameVarT) + , closedTyFamDecl_ msgCardinalityOf [ fieldNameVarB ] formCardinalityT + ( onFields fieldSpecCardinality ++ + onOneOfs (const formOptionalT) ++ + err formFieldOrOneOfNotFound + ) + ] + + pure $ namesOf : numberOf ++ protoTypeOf ++ oneOfOf ++ cardinalityOf + where + mkFieldSpecs :: QualifiedField -> WriterT FieldOccurrences m ([FieldName], [FieldSpec]) + mkFieldSpecs QualifiedField{fieldInfo} = case fieldInfo of + FieldNormal fieldName fieldNum dpType options -> do + tell (oneOccurrence fieldName, oneOccurrence fieldNum) + cardinality <- dptToFormCardinality options ctxt dpType + protoType <- dptToFormType ctxt dpType + pure ( [], [ FieldSpec + { fieldSpecName = fieldName + , fieldSpecNumber = fieldNum + , fieldSpecOneOf = Nothing + , fieldSpecCardinality = cardinality + , fieldSpecProtoType = protoType + } ] ) + + FieldOneOf oneofName OneofField{subfields} -> do + tell (oneOccurrence oneofName, mempty) + ([oneofName], ) <$> mapM mkSubfieldSpec subfields + where + mkSubfieldSpec :: OneofSubfield -> WriterT FieldOccurrences m FieldSpec + mkSubfieldSpec (OneofSubfield + { subfieldNumber = subfieldNum + , subfieldName = subfieldName + , subfieldType = dpType + }) = do + tell (oneOccurrence subfieldName, oneOccurrence subfieldNum) + protoType <- dptToFormType ctxt dpType + pure FieldSpec + { fieldSpecName = subfieldName + , fieldSpecNumber = subfieldNum + , fieldSpecOneOf = Just oneofName + , fieldSpecCardinality = formOptionalT + , fieldSpecProtoType = protoType + } + +-- *** Generate Protobuf 'Message' type class instances + +messageInstD :: + forall m . + ( MonadError CompileError m + , (?stringType :: StringType) + ) => + TypeContext -> + DotProtoIdentifier -> + DotProtoIdentifier -> + [DotProtoMessagePart] -> + m HsDecl +messageInstD ctxt parentIdent msgIdent messageParts = do + msgName <- qualifiedMessageName parentIdent msgIdent + qualifiedFields <- getQualifiedFields msgName messageParts + + encodedFields <- mapM encodeMessageField qualifiedFields + decodedFields <- mapM decodeMessageField qualifiedFields + + let encodeMessageBind :: HsBind + encodeMessageBind = + functionS_ "encodeMessage" [([wild_, recordPattern], encodeMessageE)] + + encodeMessageE :: HsExp + encodeMessageE = case encodedFields of + [] -> memptyE + (field : fields) -> foldl op (paren field) fields + where op fs f = apply (apply mappendE [fs]) [paren f] + -- NOTE: We use a left fold because this way the leftmost field + -- is the most nested and the rightmost field--the one to be written + -- first by the right-to-left builder--is the one that is least nested. + + recordPattern :: HsPat + recordPattern = recPat (unqual_ dataName msgName) punnedFieldsP + + punnedFieldsP :: [GHC.LHsRecField GHC.GhcPs HsPat] + punnedFieldsP = map (fp . coerce . recordFieldName) qualifiedFields + where + fp = fieldPunPat . unqual_ varName + + let decodeMessageBind :: HsBind + decodeMessageBind = functionS_ "decodeMessage" [([wild_], decodeMessageE)] + + decodeMessageE :: HsExp + decodeMessageE = foldl (\f -> opApp f apOp) + (apply pureE [ uvar_ msgName ]) + decodedFields + + let dotProtoBind :: HsBind + dotProtoBind = functionS_ "dotProto" [([wild_], dotProtoE)] + + dotProtoE :: HsExp + dotProtoE = list_ $ do + DotProtoMessageField DotProtoField{..} <- messageParts + pure $ apply dotProtoFieldC + [ fieldNumberE dotProtoFieldNumber + , dpTypeE dotProtoFieldType + , dpIdentE dotProtoFieldName + , list_ (map optionE dotProtoFieldOptions) + , str_ dotProtoFieldComment + ] + + pure $ instDecl_ (protobufName tcName "Message") + [ type_ msgName ] + [ encodeMessageBind + , decodeMessageBind + , dotProtoBind + ] + where + encodeMessageField :: QualifiedField -> m HsExp + encodeMessageField QualifiedField{recordFieldName, fieldInfo} = + let recordFieldName' = uvar_ (coerce recordFieldName) in + case fieldInfo of + FieldNormal _fieldName fieldNum dpType options -> do + fieldE <- wrapE WithinMessage ctxt options dpType recordFieldName' + pure $ apply encodeMessageFieldE [ fieldNumberE fieldNum, fieldE ] + + FieldOneOf _ OneofField{subfields} -> do + alts <- mapM mkAlt subfields + pure $ case_ recordFieldName' + [ alt_ (conPat nothingN []) memptyE + , alt_ (conPat justN [patVar "x"]) (case_ (uvar_ "x") alts) + ] + where + -- Create all pattern match & expr for each constructor: + -- Constructor y -> encodeMessageField num (Nested (Just y)) -- for embedded messages + -- Constructor y -> encodeMessageField num (ForceEmit y) -- for everything else + mkAlt (OneofSubfield + { subfieldNumber = fieldNum + , subfieldConsName = conName + , subfieldType = dpType + , subfieldOptions = options + }) = do + let isMaybe + | Prim (Named tyName) <- dpType + = isMessage ctxt tyName + | otherwise + = False + + let wrapJust = paren . app justC + + xE <- (if isMaybe then id else fmap forceEmitE) + . wrapE WithinMessage ctxt options dpType + -- For now we use 'WithinMessage' to preserve + -- the historical approach of treating this field + -- as if it were an ordinary non-oneof field that + -- just happens to be present, then forcing it to + -- be emitted. + . (if isMaybe then wrapJust else id) + $ uvar_ "y" + + pure $ alt_ (conPat (unqual_ dataName conName) [patVar "y"]) + (apply encodeMessageFieldE [fieldNumberE fieldNum, xE]) + + decodeMessageField :: QualifiedField -> m HsExp + decodeMessageField QualifiedField{fieldInfo} = + case fieldInfo of + FieldNormal _fieldName fieldNum dpType options -> + unwrapE WithinMessage ctxt options dpType $ + apply atE [ decodeMessageFieldE, fieldNumberE fieldNum ] + + FieldOneOf _ OneofField{subfields} -> do + parsers <- mapM subfieldParserE subfields + pure $ apply oneofE [ nothingC, list_ parsers ] + where + -- create a list of (fieldNumber, Cons <$> parser) + subfieldParserE (OneofSubfield + { subfieldNumber = fieldNumber + , subfieldConsName = consName + , subfieldType = dpType + , subfieldOptions = options + }) = do + let fE | Prim (Named tyName) <- dpType, isMessage ctxt tyName = + paren (app fmapE (uvar_ consName)) + | otherwise = + paren (opApp justC composeOp (uvar_ consName)) + + -- For now we continue the historical practice of parsing + -- submessages within oneofs as if were outside of oneofs, + -- and replacing the "Just . Ctor" with "fmap . Ctor". + -- That is why we do not pass WithinOneOf. + alts <- unwrapE WithinMessage ctxt options dpType decodeMessageFieldE + + pure $ tuple_ + [ fieldNumberE fieldNumber + , opApp (apply pureE [ fE ]) apOp alts + ] + + +-- *** Generate ToJSONPB/FromJSONPB instances + +toJSONPBMessageInstD :: + forall m . + ( MonadError CompileError m + , (?stringType :: StringType) + ) => + TypeContext -> + DotProtoIdentifier -> + DotProtoIdentifier -> + [DotProtoMessagePart] -> + m HsDecl +toJSONPBMessageInstD ctxt parentIdent msgIdent messageParts = do + msgName <- qualifiedMessageName parentIdent msgIdent + qualFields <- getQualifiedFields msgName messageParts + + let applyE nm oneofNm = do + fs <- traverse (encodeMessageField oneofNm) qualFields + pure $ apply (var_ (jsonpbName varName nm)) [list_ fs] + + let patBinder = foldQF (const fieldBinder) (oneofSubDisjunctBinder . subfields) + let matchE nm appNm oneofAppNm = do + rhs <- applyE appNm oneofAppNm + pure $ functionS_ nm + [ ( [conPat (unqual_ dataName msgName) (patVar . patBinder <$> qualFields)] + , rhs + ) + ] + + toJSONPB <- matchE "toJSONPB" "object" "objectOrNull" + toEncoding <- matchE "toEncodingPB" "pairs" "pairsOrNull" + + pure $ instDecl_ (jsonpbName tcName "ToJSONPB") + [ type_ msgName ] + [ toJSONPB + , toEncoding + ] + + where + encodeMessageField :: String -> QualifiedField -> m HsExp + encodeMessageField oneofNm (QualifiedField _ fieldInfo) = + case fieldInfo of + FieldNormal fldName fldNum dpType options -> + defPairE fldName fldNum dpType options + FieldOneOf _ oo -> + oneofCaseE oneofNm oo + + -- E.g. + -- "another" .= f2 -- always succeeds (produces default value on missing field) + defPairE fldName fldNum dpType options = do + w <- wrapE WithinMessage ctxt options dpType (uvar_ (fieldBinder fldNum)) + pure $ opApp (str_ (coerce fldName)) toJSONPBOp w + + -- E.g. + -- HsJSONPB.pair "name" f4 -- fails on missing field + oneOfPairE fldNm varNm options dpType = do + w <- wrapE WithinOneOf ctxt options dpType (uvar_ varNm) + pure $ apply (var_ (jsonpbName varName "pair")) [str_ (coerce fldNm), w] + + -- Suppose we have a sum type Foo, nested inside a message Bar. + -- We want to generate the following: + -- + -- > toJSONPB (Bar foo more stuff) = + -- > HsJSONPB.object + -- > [ (let encodeFoo = ( :: Options -> Value) + -- > in \option -> if optEmitNamedOneof option + -- > then ("Foo" .= (PB.objectOrNull [encodeFoo] option)) option + -- > else encodeFoo option + -- > ) + -- > , + -- > , + -- > ] + oneofCaseE :: String -> OneofField -> m HsExp + oneofCaseE retJsonCtor (OneofField typeName subfields) = do + altEs <- traverse altE subfields + pure $ paren + $ let_ [ functionS_ caseName [([], caseExpr altEs)] ] + $ lambda_ [patVar optsStr] (if_ dontInline noInline yesInline) + where + optsStr = "options" + opts = uvar_ optsStr + + caseName = "encode" <> over (ix 0) toUpper typeName + caseBnd = uvar_ caseName + + dontInline = app (var_ (jsonpbName varName "optEmitNamedOneof")) opts + + noInline = app (paren (opApp (str_ typeName) + toJSONPBOp + (apply (var_ (jsonpbName varName retJsonCtor)) + [ list_ [caseBnd], opts ]))) + opts + + yesInline = app caseBnd opts + + altE sub@(OneofSubfield + { subfieldConsName = conName + , subfieldName = pbFldNm + , subfieldType = dpType + , subfieldOptions = options + }) = do + let patVarNm = oneofSubBinder sub + p <- oneOfPairE pbFldNm patVarNm options dpType + pure $ + alt_ (conPat justN [parenPat (conPat (unqual_ dataName conName) [patVar patVarNm])]) p + + -- E.g. + -- case f4_or_f9 of + -- Just (SomethingPickOneName f4) + -- -> HsJSONPB.pair "name" f4 + -- Just (SomethingPickOneSomeid f9) + -- -> HsJSONPB.pair "someid" f9 + -- Nothing + -- -> mempty + caseExpr altEs = paren $ + case_ disjunctName (altEs <> [fallthroughE]) + where + disjunctName = uvar_ (oneofSubDisjunctBinder subfields) + fallthroughE = alt_ (conPat nothingN []) memptyE + +fromJSONPBMessageInstD :: + forall m . + ( MonadError CompileError m + , (?stringType :: StringType) + ) => + TypeContext -> + DotProtoIdentifier -> + DotProtoIdentifier -> + [DotProtoMessagePart] -> + m HsDecl +fromJSONPBMessageInstD ctxt parentIdent msgIdent messageParts = do + msgName <- qualifiedMessageName parentIdent msgIdent + qualFields <- getQualifiedFields msgName messageParts + + fieldParsers <- traverse parseField qualFields + + let parseJSONPBE = + apply (var_ (jsonpbName varName "withObject")) + [ str_ msgName + , paren (lambda_ [lambdaPVar] fieldAps) + ] + where + fieldAps = foldl (\f -> opApp f apOp) + (apply pureE [ uvar_ msgName ]) + fieldParsers + + let parseJSONPBBind = functionS_ "parseJSONPB" [([], parseJSONPBE)] + + pure (instDecl_ (jsonpbName tcName "FromJSONPB") + [ type_ msgName ] + [ parseJSONPBBind ]) + where + lambdaPVar = patVar "obj" + lambdaVar = uvar_ "obj" + + parseField (QualifiedField _ (FieldNormal fldName _ dpType options)) = + normalParserE fldName dpType options + parseField (QualifiedField _ (FieldOneOf _ fld)) = + oneofParserE fld + + -- E.g., for message + -- message Something { oneof name_or_id { string name = _; int32 someid = _; } } + -- + -- ==> + -- + -- (let parseSomethingNameOrId parseObj = + -- in ((obj .: "nameOrId") Hs.>>= + -- (HsJSONPB.withObject "nameOrId" parseSomethingNameOrId)) + -- <|> + -- (parseSomethingNameOrId obj) + -- ) + oneofParserE :: OneofField -> m HsExp + oneofParserE (OneofField oneofType fields) = do + ds <- tryParseDisjunctsE + pure $ paren $ + let_ [ functionS_ letBndStr [([patVar letArgStr], ds)] ] + (opApp parseWrapped altOp parseUnwrapped) + where + oneofTyLit = str_ oneofType -- FIXME + + letBndStr = "parse" <> over (ix 0) toUpper oneofType + letBndName = uvar_ letBndStr + letArgStr = "parseObj" + letArgName = uvar_ letArgStr + + parseWrapped = paren $ + opApp (opApp lambdaVar parseJSONPBOp oneofTyLit) + bindOp + (apply (var_ (jsonpbName varName "withObject")) [ oneofTyLit , letBndName ]) + + parseUnwrapped = paren (app letBndName lambdaVar) + + -- parseSomethingNameOrId parseObj = + -- Hs.msum + -- [ (Just . SomethingPickOneName) <$> (HsJSONPB.parseField parseObj "name") + -- , (Just . SomethingPickOneSomeid) <$> (HsJSONPB.parseField parseObj "someid") + -- , pure Nothing + -- ] + tryParseDisjunctsE = do + fs <- traverse subParserE fields + pure $ app msumE (list_ (fs <> fallThruE)) + + fallThruE = [ app pureE nothingC ] + + subParserE OneofSubfield{subfieldConsName, subfieldName, + subfieldType, subfieldOptions} = do + maybeCoercion <- + unwrapFunE False WithinOneOf ctxt subfieldOptions subfieldType + let inject = opApp justC composeOp (uvar_ subfieldConsName) + pure $ opApp + (maybe inject (opApp inject composeOp) maybeCoercion) + fmapOp + (apply (var_ (jsonpbName varName "parseField")) + [ letArgName + , str_ (coerce subfieldName)]) + + -- E.g. obj .: "someid" + normalParserE :: FieldName -> DotProtoType -> [DotProtoOption] -> m HsExp + normalParserE fldName dpType options = + unwrapE WithinMessage ctxt options dpType $ + opApp lambdaVar + parseJSONPBOp + (str_(coerce fldName)) + +-- *** Generate default Aeson To/FromJSON and Swagger ToSchema instances +-- (These are defined in terms of ToJSONPB) + +toJSONInstDecl :: String -> HsDecl +toJSONInstDecl typeName = + instDecl_ (jsonpbName tcName "ToJSON") + [ type_ typeName ] + [ functionS_ "toJSON" + [([], var_ (jsonpbName varName "toAesonValue"))] + , functionS_ "toEncoding" + [([], var_ (jsonpbName varName "toAesonEncoding"))] + ] + +fromJSONInstDecl :: String -> HsDecl +fromJSONInstDecl typeName = + instDecl_ (jsonpbName tcName "FromJSON") + [ type_ typeName ] + [ functionS_ "parseJSON" + [([], var_ (jsonpbName varName "parseJSONPB"))] + ] + + +-- *** Generate `ToSchema` instance + +#ifdef SWAGGER +getFieldNameForSchemaInstanceDeclaration + :: MonadError CompileError m + => DotProtoField + -> m (Maybe ([DotProtoOption], DotProtoType), String) +getFieldNameForSchemaInstanceDeclaration fld = do + unqual <- dpIdentUnqualName (dotProtoFieldName fld) + let optsType = (dotProtoFieldOptions fld, dotProtoFieldType fld) + pure (Just optsType, unqual) + +toSchemaInstanceDeclaration :: + ( MonadError CompileError m + , (?stringType :: StringType) + ) => + TypeContext -> + -- | Name of the message type to create an instance for + String -> + -- | Oneof constructors + Maybe [HsName] -> + -- | Field names, with every field that is not actually a oneof + -- combining fields paired with its options and protobuf type + [(Maybe ([DotProtoOption], DotProtoType), String)] -> + m HsDecl +toSchemaInstanceDeclaration ctxt messageName maybeConstructors fieldNamesEtc = do + let fieldNames = map snd fieldNamesEtc + + qualifiedFieldNames <- mapM (prefixedFieldName messageName) fieldNames + + let messageConstructor = uvar_ messageName + + let _namedSchemaNameExpression = app justC (str_ messageName) + +#ifdef SWAGGER + -- { _paramSchemaType = HsJSONPB.SwaggerObject + -- } + let paramSchemaUpdates = + [ fieldUpd_ _paramSchemaType _paramSchemaTypeExpression + ] + where + _paramSchemaType = jsonpbName varName "_paramSchemaType" + +#if MIN_VERSION_swagger2(2,4,0) + _paramSchemaTypeExpression = app justC (var_ (jsonpbName dataName "SwaggerObject")) +#else + _paramSchemaTypeExpression = var_ (jsonpbName dataName "SwaggerObject") +#endif +#else + let paramSchemaUpdates = [] +#endif + + let _schemaParamSchemaExpression = recordUpd_ memptyE paramSchemaUpdates + + -- [ ("fieldName0", qualifiedFieldName0) + -- , ("fieldName1", qualifiedFieldName1) + -- ... + -- ] + let properties = list_ $ do + (fieldName, qualifiedFieldName) <- zip fieldNames qualifiedFieldNames + pure (tuple_ [ str_ fieldName, uvar_ qualifiedFieldName ]) + + let _schemaPropertiesExpression = + app (var_ (jsonpbName varName "insOrdFromList")) properties + + -- { _schemaParamSchema = ... + -- , _schemaProperties = ... + -- , ... + -- } + let schemaUpdates = normalUpdates ++ extraUpdates + where + normalUpdates = + [ fieldUpd_ _schemaParamSchema _schemaParamSchemaExpression + , fieldUpd_ _schemaProperties _schemaPropertiesExpression + ] + + extraUpdates = + case maybeConstructors of + Just _ -> + [ fieldUpd_ _schemaMinProperties justOne + , fieldUpd_ _schemaMaxProperties justOne + ] + Nothing -> + [] + + _schemaParamSchema = jsonpbName varName "_schemaParamSchema" + _schemaProperties = jsonpbName varName "_schemaProperties" + _schemaMinProperties = jsonpbName varName "_schemaMinProperties" + _schemaMaxProperties = jsonpbName varName "_schemaMaxProperties" + + justOne = app justC (intE (1 :: Integer)) + + let _namedSchemaSchemaExpression = recordUpd_ memptyE schemaUpdates + + -- { _namedSchemaName = ... + -- , _namedSchemaSchema = ... + -- } + let namedSchemaBinds = + [ fieldBind_ _namedSchemaName _namedSchemaNameExpression + , fieldBind_ _namedSchemaSchema _namedSchemaSchemaExpression + ] + where + _namedSchemaName = jsonpbName varName "_namedSchemaName" + _namedSchemaSchema = jsonpbName varName "_namedSchemaSchema" + + let namedSchema = recordCtor_ (jsonpbName dataName "NamedSchema") namedSchemaBinds + + let toDeclareName fieldName = "declare_" ++ fieldName + + let toArgument fc (maybeOptsType, fieldName) = + maybe pure (uncurry (unwrapE fc ctxt)) maybeOptsType $ + app asProxy declare + where + declare = uvar_ (toDeclareName fieldName) + asProxy = var_ (jsonpbName varName "asProxy") + + -- do let declare_fieldName0 = HsJSONPB.declareSchemaRef + -- qualifiedFieldName0 <- declare_fieldName0 Proxy.Proxy + -- let declare_fieldName1 = HsJSONPB.declareSchemaRef + -- qualifiedFieldName1 <- declare_fieldName1 Proxy.Proxy + -- ... + -- let _ = pure MessageName <*> HsJSONPB.asProxy declare_fieldName0 <*> HsJSONPB.asProxy declare_fieldName1 <*> ... + -- return (...) + let expressionForMessage = do + let bindingStatements = do + (fieldName, qualifiedFieldName) <- zip fieldNames qualifiedFieldNames + + let declareIdentifier = unqual_ varName (toDeclareName fieldName) + + let stmt0 = letStmt_ + [ function_ declareIdentifier + [([], var_ (jsonpbName varName "declareSchemaRef"))] ] + + let stmt1 = bindStmt_ (patVar qualifiedFieldName) + (app (var_ declareIdentifier) + (var_ (proxyName dataName "Proxy"))) + [ stmt0, stmt1] + + inferenceStatement <- do + arguments <- traverse (toArgument WithinMessage) fieldNamesEtc + let patternBind = patBind_ wild_ (applicativeApply messageConstructor arguments) + pure $ if null fieldNames then [] else [ letStmt_ [ patternBind ] ] + + let returnStatement = lastStmt_ (app returnE (paren namedSchema)) + + pure $ do_ (bindingStatements ++ inferenceStatement ++ [ returnStatement ]) + + -- do let declare_fieldName0 = HsJSONPB.declareSchemaRef + -- let _ = pure ConstructorName0 <*> HsJSONPB.asProxy declare_fieldName0 + -- qualifiedFieldName0 <- declare_fieldName0 Proxy.Proxy + -- let declare_fieldName1 = HsJSONPB.declareSchemaRef + -- let _ = pure ConstructorName1 <*> HsJSONPB.asProxy declare_fieldName1 + -- qualifiedFieldName1 <- declare_fieldName1 Proxy.Proxy + -- ... + -- return (...) + let expressionForOneOf constructors = do + let bindingStatement (fieldNameEtc, qualifiedFieldName, constructor) = do + let declareIdentifier = unqual_ varName (toDeclareName (snd fieldNameEtc)) + + let stmt0 = letStmt_ + [ function_ declareIdentifier + [([], var_ (jsonpbName varName "declareSchemaRef"))] ] + + let stmt1 = bindStmt_ (patVar qualifiedFieldName) + (app (var_ declareIdentifier) + (var_ (proxyName dataName "Proxy"))) + + inferenceStatement <- do + argument <- toArgument WithinOneOf fieldNameEtc + let patternBind = patBind_ wild_ (applicativeApply (var_ constructor) [ argument ]) + pure $ if null fieldNames then [] else [ letStmt_ [ patternBind ] ] + + pure $ [stmt0, stmt1] ++ inferenceStatement + + bindingStatements <- foldMapM bindingStatement $ + zip3 fieldNamesEtc qualifiedFieldNames constructors + + let returnStatement = lastStmt_ (app returnE (paren namedSchema)) + + pure $ do_ (bindingStatements ++ [ returnStatement ]) + + expression <- case maybeConstructors of + Nothing -> expressionForMessage + Just constructors -> expressionForOneOf constructors + + let instanceDeclaration = + instDecl_ className [ classArgument ] [ classDeclaration ] + where + className = jsonpbName tcName "ToSchema" + + classArgument = type_ messageName + + classDeclaration = + functionS_ "declareNamedSchema" [([ wild_ ], expression)] + + pure instanceDeclaration +#endif + + +-- ** Generate types and instances for .proto enums + +dotProtoEnumD + :: MonadError CompileError m + => DotProtoIdentifier + -> DotProtoIdentifier + -> [DotProtoEnumPart] + -> m [HsDecl] +dotProtoEnumD parentIdent enumIdent enumParts = do + enumName <- qualifiedMessageName parentIdent enumIdent + + let enumeratorDecls = + [ (i, conIdent) | DotProtoEnumField conIdent i _options <- enumParts ] + + enumeratorDeclsNE <- case enumeratorDecls of + [] -> throwError $ EmptyEnumeration enumName + h@(i, conIdent) : t + | i == 0 -> pure (h :| t) + | otherwise -> throwError $ NonzeroFirstEnumeration enumName conIdent i + + enumCons <- NE.sortBy (comparing fst) <$> + traverse (traverse (fmap (prefixedEnumFieldName enumName) . dpIdentUnqualName)) + enumeratorDeclsNE + + let enumConNames = fmap snd enumCons + + minBoundD :: HsBind + minBoundD = functionS_ "minBound" [([], uvar_ (NE.head enumConNames))] + + maxBoundD :: HsBind + maxBoundD = functionS_ "maxBound" [([], uvar_ (NE.last enumConNames))] + + compareD :: HsBind + compareD = functionS_ "compare" + [ ( [ patVar "x", patVar "y" ] + , app + (app + (var_ (haskellName varName "compare")) + (paren + (app (var_ (protobufName varName "fromProtoEnum")) + (uvar_ "x") + ) + ) + ) + (paren + (app (var_ (protobufName varName "fromProtoEnum")) + (uvar_ "y") + ) + ) + ) + ] + + fromProtoEnumD :: HsBind + fromProtoEnumD = functionS_ "fromProtoEnum" + [ ([ conPat (unqual_ dataName conName) [] ], intE conIdx) + | (conIdx, conName) <- NE.toList enumCons + ] + + toProtoEnumMayD :: HsBind + toProtoEnumMayD = functionS_ "toProtoEnumMay" $ + [ ([ intP conIdx ], app justC (uvar_ conName)) + | (conIdx, conName) <- NE.toList enumCons ] ++ + [ ([ wild_ ], nothingC) ] + + parseJSONPBDecl :: HsBind + parseJSONPBDecl = functionS_ "parseJSONPB" $ + foldr ((:) . matchConName) [mismatch] enumConNames + where + matchConName conName = ([pat conName], app pureE (uvar_ conName)) + + pat nm = conPat (jsonpbName dataName "String") [ strPat (tryStripEnumName nm) ] + + tryStripEnumName = fromMaybe <*> stripPrefix enumName + + mismatch = + ( [patVar "v"] + , apply (var_ (jsonpbName varName "typeMismatch")) + [ str_ enumName, uvar_ "v" ] + ) + + toJSONPBDecl :: HsBind + toJSONPBDecl = + functionS_ "toJSONPB" + [( [ patVar "x", wild_ ] + , app (var_ (jsonpbName varName "enumFieldString")) (uvar_ "x") + )] + + toEncodingPBDecl :: HsBind + toEncodingPBDecl = + functionS_ "toEncodingPB" + [([ patVar "x", wild_ ] + , app (var_ (jsonpbName varName "enumFieldEncoding")) (uvar_ "x") + )] + + pure [ dataDecl_ enumName + [] + [ conDecl_ (unqual_ dataName con) [] | con <- NE.toList enumConNames ] + defaultEnumDeriving + , namedInstD enumName + , hasDefaultInstD enumName + , instDecl_ (haskellName tcName "Bounded") [ type_ enumName ] + [ minBoundD + , maxBoundD + ] + , instDecl_ (haskellName tcName "Ord") [ type_ enumName ] + [ compareD ] + , instDecl_ (protobufName tcName "ProtoEnum") [ type_ enumName ] + [ toProtoEnumMayD + , fromProtoEnumD + ] + , instDecl_ (jsonpbName tcName "ToJSONPB") [ type_ enumName ] + [ toJSONPBDecl + , toEncodingPBDecl + ] + , instDecl_ (jsonpbName tcName "FromJSONPB") [ type_ enumName ] + [ parseJSONPBDecl ] + -- Generate Aeson instances in terms of JSONPB instances + , toJSONInstDecl enumName + , fromJSONInstDecl enumName + +#ifdef DHALL + -- Generate Dhall instances + , dhallInterpretInstDecl enumName + , dhallInjectInstDecl enumName +#endif + + -- And the Finite instance, used to infer a Swagger ToSchema instance + -- for this enumerated type. + , instDecl_ (protobufName tcName "Finite") [ type_ enumName ] [] + ] + +-- ** Generate code for dot proto services + +dotProtoServiceD :: + ( MonadError CompileError m + , (?stringType :: StringType) + ) => + DotProtoPackageSpec -> + TypeContext -> + DotProtoIdentifier -> + [DotProtoServicePart] -> + m [HsDecl] +dotProtoServiceD pkgSpec ctxt serviceIdent service = do + serviceName <- typeLikeName =<< dpIdentUnqualName serviceIdent + + endpointPrefix <- + case pkgSpec of + DotProtoPackageSpec pkgIdent -> do + packageName <- dpIdentQualName pkgIdent + pure $ "/" ++ packageName ++ "." ++ serviceName ++ "/" + DotProtoNoPackage -> pure $ "/" ++ serviceName ++ "/" + + let serviceFieldD (DotProtoServiceRPCMethod RPCMethod{..}) = do + fullName <- prefixedMethodName serviceName =<< dpIdentUnqualName rpcMethodName + + methodName <- case rpcMethodName of + Single nm -> pure nm + _ -> invalidMethodNameError rpcMethodName + + requestTy <- dpptToHsType ctxt (Named rpcMethodRequestType) + + responseTy <- dpptToHsType ctxt (Named rpcMethodResponseType) + + let streamingType = + case (rpcMethodRequestStreaming, rpcMethodResponseStreaming) of + (Streaming, Streaming) -> biDiStreamingC + (Streaming, NonStreaming) -> clientStreamingC + (NonStreaming, Streaming) -> serverStreamingC + (NonStreaming, NonStreaming) -> normalC + + pure [ ( endpointPrefix ++ methodName + , fullName, rpcMethodRequestStreaming, rpcMethodResponseStreaming + , unbangedTy_ $ + funTy (tyApply (tvar_ "request") [streamingType, requestTy, responseTy]) + (tyApply ioT [tyApply (tvar_ "response") [streamingType, responseTy]]) + ) + ] + + serviceFieldD _ = pure [] + + fieldsD <- foldMapM serviceFieldD service + + serverFuncName <- prefixedFieldName serviceName "server" + clientFuncName <- prefixedFieldName serviceName "client" + + let conDecl = recDecl_ (unqual_ dataName serviceName) + [ ([unqual_ varName hsName], ty) | (_, hsName, _, _, ty) <- fieldsD ] + + let serverT = tyApply (typeNamed_ (unqual_ tcName serviceName)) + [ serverRequestT, serverResponseT ] + + let serviceServerTypeD = + typeSig_ [ unqual_ varName serverFuncName ] implicitOuterSigTyVarBinders_ + (funTy serverT (funTy serviceOptionsC ioActionT)) + + let serviceServerD = valDecl_ $ + functionS_ serverFuncName [(serverFuncPats, serverFuncRhs)] + where + serverFuncPats = + [ recPat (unqual_ dataName serviceName) + [ fieldPunPat (unqual_ varName methodName) + | (_, methodName, _, _, _) <- fieldsD + ] + , conPat (unqual_ dataName "ServiceOptions") + [ patVar "serverHost" + , patVar "serverPort" + , patVar "useCompression" + , patVar "userAgentPrefix" + , patVar "userAgentSuffix" + , patVar "initialMetadata" + , patVar "sslConfig" + , patVar "logger" + , patVar "serverMaxReceiveMessageLength" + , patVar "serverMaxMetadataSize" + ] + ] + + serverFuncRhs = apply serverLoopE [ serverOptsE ] + + handlerE handlerC adapterE methodName hsName = + apply handlerC [ apply methodNameC [ str_ methodName ] + , apply adapterE [ uvar_ hsName ] + ] + + update u v = fieldUpd_ (unqual_ varName u) (uvar_ v) + + serverOptsE = recordUpd_ defaultOptionsE + [ fieldUpd_ (grpcName varName "optNormalHandlers") $ + list_ [ handlerE unaryHandlerC convertServerHandlerE endpointName hsName + | (endpointName, hsName, NonStreaming, NonStreaming, _) <- fieldsD + ] + + , fieldUpd_ (grpcName varName "optClientStreamHandlers") $ + list_ [ handlerE clientStreamHandlerC convertServerReaderHandlerE endpointName hsName + | (endpointName, hsName, Streaming, NonStreaming, _) <- fieldsD + ] + + , fieldUpd_ (grpcName varName "optServerStreamHandlers") $ + list_ [ handlerE serverStreamHandlerC convertServerWriterHandlerE endpointName hsName + | (endpointName, hsName, NonStreaming, Streaming, _) <- fieldsD + ] + + , fieldUpd_ (grpcName varName "optBiDiStreamHandlers") $ + list_ [ handlerE biDiStreamHandlerC convertServerRWHandlerE endpointName hsName + | (endpointName, hsName, Streaming, Streaming, _) <- fieldsD + ] + + , update "optServerHost" "serverHost" + , update "optServerPort" "serverPort" + , update "optUseCompression" "useCompression" + , update "optUserAgentPrefix" "userAgentPrefix" + , update "optUserAgentSuffix" "userAgentSuffix" + , update "optInitialMetadata" "initialMetadata" + , update "optSSLConfig" "sslConfig" + , update "optLogger" "logger" + , update "optMaxReceiveMessageLength" "serverMaxReceiveMessageLength" + , update "optMaxMetadataSize" "serverMaxMetadataSize" + ] + + let clientT = tyApply (type_ serviceName) [ clientRequestT, clientResultT ] + + let serviceClientTypeD = + typeSig_ [ unqual_ varName clientFuncName ] implicitOuterSigTyVarBinders_ + (funTy grpcClientT (tyApp ioT clientT)) + + let serviceClientD = valDecl_ $ + functionS_ clientFuncName [([patVar "client"], clientRecE)] + where + clientRecE = foldl + (\f -> opApp f apOp) + (apply pureE [ uvar_ serviceName ]) + [ paren (opApp clientRequestE' apOp (registerClientMethodE endpointName)) + | (endpointName, _, _, _, _) <- fieldsD + ] + + clientRequestE' = apply pureE [ apply clientRequestE [ uvar_ "client" ] ] + + registerClientMethodE endpoint = + apply clientRegisterMethodE [ uvar_ "client" + , apply methodNameC [ str_ endpoint ] + ] + + pure [ dataDecl_ serviceName + [ userTyVar_ synDef (unqual_ GHC.tvName "request") + , userTyVar_ synDef (unqual_ GHC.tvName "response") + ] + [ conDecl ] + defaultServiceDeriving + + , serviceServerTypeD + , serviceServerD + + , serviceClientTypeD + , serviceClientD + ] + +-------------------------------------------------------------------------------- + +-- +-- * Common Haskell expressions, constructors, and operators +-- + +unaryHandlerC, clientStreamHandlerC, serverStreamHandlerC, biDiStreamHandlerC, + methodNameC, defaultOptionsE, serverLoopE, convertServerHandlerE, + convertServerReaderHandlerE, convertServerWriterHandlerE, + convertServerRWHandlerE, clientRegisterMethodE, clientRequestE :: HsExp + +unaryHandlerC = var_ (grpcName dataName "UnaryHandler") +clientStreamHandlerC = var_ (grpcName dataName "ClientStreamHandler") +serverStreamHandlerC = var_ (grpcName dataName "ServerStreamHandler") +biDiStreamHandlerC = var_ (grpcName dataName "BiDiStreamHandler") +methodNameC = var_ (grpcName tcName "MethodName") +defaultOptionsE = var_ (grpcName varName "defaultOptions") +serverLoopE = var_ (grpcName varName "serverLoop") +convertServerHandlerE = var_ (grpcName varName "convertGeneratedServerHandler") +convertServerReaderHandlerE = var_ (grpcName varName "convertGeneratedServerReaderHandler") +convertServerWriterHandlerE = var_ (grpcName varName "convertGeneratedServerWriterHandler") +convertServerRWHandlerE = var_ (grpcName varName "convertGeneratedServerRWHandler") +clientRegisterMethodE = var_ (grpcName varName "clientRegisterMethod") +clientRequestE = var_ (grpcName varName "clientRequest") + +biDiStreamingC, serverStreamingC, clientStreamingC, normalC, serviceOptionsC, + ioActionT, serverRequestT, serverResponseT, clientRequestT, clientResultT, + ioT, grpcClientT :: HsType +biDiStreamingC = typeNamed_ (qual_ grpcModule dataName "BiDiStreaming") +serverStreamingC = typeNamed_ (qual_ grpcModule dataName "ServerStreaming") +clientStreamingC = typeNamed_ (qual_ grpcModule dataName "ClientStreaming") +normalC = typeNamed_ (qual_ grpcModule dataName "Normal") +serviceOptionsC = typeNamed_ (qual_ grpcModule tcName "ServiceOptions") +serverRequestT = typeNamed_ (grpcName tcName "ServerRequest") +serverResponseT = typeNamed_ (grpcName tcName "ServerResponse") +clientRequestT = typeNamed_ (grpcName tcName "ClientRequest") +clientResultT = typeNamed_ (grpcName tcName "ClientResult") +grpcClientT = typeNamed_ (grpcName tcName "Client") +ioActionT = tyApp ioT (tupleType_ []) +ioT = typeNamed_ (haskellName tcName "IO") + +grpcModule :: GHC.ModuleName +grpcModule = GHC.mkModuleName "HsGRPC" + +-- ** Expressions for protobuf-wire types + +forceEmitE :: HsExp -> HsExp +forceEmitE = paren . app forceEmitC + +fieldNumberE :: FieldNumber -> HsExp +fieldNumberE = paren . app fieldNumberC . intE . getFieldNumber + +dpIdentE :: DotProtoIdentifier -> HsExp +dpIdentE (Single n) = apply singleC [ str_ n ] +dpIdentE (Dots (Path (n NE.:| ns))) = + apply dotsC [ apply pathC [ paren (opApp (str_ n) neConsOp (list_ (map str_ ns))) ] ] +dpIdentE (Qualified a b) = apply qualifiedC [ dpIdentE a, dpIdentE b ] +dpIdentE Anonymous = anonymousC + +dpValueE :: DotProtoValue -> HsExp +dpValueE (Identifier nm) = apply identifierC [ dpIdentE nm ] +dpValueE (StringLit s) = apply stringLitC [ str_ s ] +dpValueE (IntLit i) = apply intLitC [ intE i ] +dpValueE (FloatLit f) = apply floatLitC [ floatE f ] +dpValueE (BoolLit True) = apply boolLitC [ trueC ] +dpValueE (BoolLit False) = apply boolLitC [ falseC ] + +optionE :: DotProtoOption -> HsExp +optionE (DotProtoOption name value) = + apply dotProtoOptionC [ dpIdentE name, dpValueE value ] + +-- | Translate a dot proto type to its Haskell AST type +dpTypeE :: DotProtoType -> HsExp +dpTypeE (Prim p) = apply primC [ dpPrimTypeE p ] +dpTypeE (Optional p) = apply optionalC [ dpPrimTypeE p ] +dpTypeE (Repeated p) = apply repeatedC [ dpPrimTypeE p ] +dpTypeE (NestedRepeated p) = apply nestedRepeatedC [ dpPrimTypeE p ] +dpTypeE (Map k v) = apply mapC [ dpPrimTypeE k, dpPrimTypeE v] + + +-- | Translate a dot proto primitive type to a Haskell AST primitive type. +dpPrimTypeE :: DotProtoPrimType -> HsExp +dpPrimTypeE ty = + let wrap = var_ . protobufASTName dataName in + case ty of + Named n -> apply namedC [ dpIdentE n ] + Int32 -> wrap "Int32" + Int64 -> wrap "Int64" + SInt32 -> wrap "SInt32" + SInt64 -> wrap "SInt64" + UInt32 -> wrap "UInt32" + UInt64 -> wrap "UInt64" + Fixed32 -> wrap "Fixed32" + Fixed64 -> wrap "Fixed64" + SFixed32 -> wrap "SFixed32" + SFixed64 -> wrap "SFixed64" + String -> wrap "String" + Bytes -> wrap "Bytes" + Bool -> wrap "Bool" + Float -> wrap "Float" + Double -> wrap "Double" + +defaultImports :: + ( (?stringType :: StringType) + , (?typeLevelFormat :: Bool) + ) => + -- | Uses GRPC? + Bool -> + [HsImportDecl] +defaultImports icUsesGrpc | StringType stringModule stringType <- ?stringType = + [ importDecl_ (m "Prelude") & qualified haskellNS & everything + , importDecl_ (m "Proto3.Suite.Class") & qualified protobufNS & everything +#ifdef DHALL + , importDecl_ (m "Proto3.Suite.DhallPB") & qualified (m hsDhallPB) & everything +#endif + , importDecl_ (m "Proto3.Suite.DotProto") & qualified protobufASTNS & everything + , importDecl_ (m "Proto3.Suite.JSONPB") & qualified jsonpbNS & everything + , importDecl_ (m "Proto3.Suite.JSONPB") & unqualified & selecting [s".=", s".:"] + , importDecl_ (m "Proto3.Suite.Types") & qualified protobufNS & everything + , importDecl_ (m "Proto3.Wire") & qualified protobufNS & everything + , importDecl_ (m "Proto3.Wire.Decode") & qualified protobufNS & selecting [i"Parser", i"RawField"] + , importDecl_ (m "Control.Applicative") & qualified haskellNS & everything + , importDecl_ (m "Control.Applicative") & unqualified & selecting [s"<*>", s"<|>", s"<$>"] + , importDecl_ (m "Control.DeepSeq") & qualified haskellNS & everything + , importDecl_ (m "Control.Monad") & qualified haskellNS & everything + , importDecl_ (m "Data.ByteString") & qualified haskellNS & everything + , importDecl_ (m "Data.Coerce") & qualified haskellNS & everything + , importDecl_ (m "Data.Int") & qualified haskellNS & selecting [i"Int16", i"Int32", i"Int64"] + , importDecl_ (m "Data.List.NonEmpty") & qualified haskellNS & selecting [ieNameAll_ (unqual_ tcName "NonEmpty")] + , importDecl_ (m "Data.Map") & qualified haskellNS & selecting [i"Map", i"mapKeysMonotonic"] + , importDecl_ (m "Data.Proxy") & qualified proxyNS & everything + , importDecl_ (m "Data.String") & qualified haskellNS & selecting [i"fromString"] + , importDecl_ (m stringModule) & qualified haskellNS & selecting [i stringType] + , importDecl_ (m "Data.Vector") & qualified haskellNS & selecting [i"Vector"] + , importDecl_ (m "Data.Word") & qualified haskellNS & selecting [i"Word16", i"Word32", i"Word64"] + , importDecl_ (m "GHC.Enum") & qualified haskellNS & everything + , importDecl_ (m "GHC.Generics") & qualified haskellNS & everything + , importDecl_ (m "Google.Protobuf.Wrappers.Polymorphic") & qualified protobufNS & selecting [ieNameAll_ (unqual_ tcName "Wrapped")] + , importDecl_ (m "Unsafe.Coerce") & qualified haskellNS & everything + ] + <> + (if not icUsesGrpc then [] else + [ importDecl_ (m "Network.GRPC.HighLevel.Generated") & alias grpcNS & everything + , importDecl_ (m "Network.GRPC.HighLevel.Client") & alias grpcNS & everything + , importDecl_ (m "Network.GRPC.HighLevel.Server") & alias grpcNS & hiding [i"serverLoop"] + , importDecl_ (m "Network.GRPC.HighLevel.Server.Unregistered") & alias grpcNS & selecting [i"serverLoop"] + ]) + <> + ( if not ?typeLevelFormat then [] else + [ importDecl_ (m "Proto3.Suite.Form") & qualified protobufFormNS & everything + , importDecl_ (m "GHC.TypeLits") & qualified haskellNS & selecting [i"Nat", i"Symbol", i"TypeError"] + ]) + where + m = GHC.mkModuleName + i n = ieName_ (unqual_ (if foldr (const . isLower) True n then varName else tcName) n) + s n = ieName_ (unqual_ varName n) + + grpcNS = m "HsGRPC" + jsonpbNS = m "HsJSONPB" + protobufNS = m "HsProtobuf" + protobufASTNS = m "HsProtobufAST" + proxyNS = m "Proxy" + + -- staged constructors for importDecl + qualified :: Module -> (Bool -> Maybe Module -> a) -> a + qualified m' f = f True (Just m') + + unqualified :: (Bool -> Maybe Module -> a) -> a + unqualified f = f False Nothing + + -- import unqualified AND also under a namespace + alias :: Module -> (Bool -> Maybe Module -> a) -> a + alias m' f = f False (Just m') + + selecting :: [HsImportSpec] -> (Maybe (Bool, [HsImportSpec]) -> a) -> a + selecting is f = f (Just (False, is)) + + hiding :: [HsImportSpec] -> (Maybe (Bool, [HsImportSpec]) -> a) -> a + hiding is f = f (Just (True, is)) + + everything :: (Maybe (Bool, [HsImportSpec]) -> a) -> a + everything f = f Nothing + +defaultMessageDeriving :: [HsQName] +defaultMessageDeriving = map (haskellName tcName) [ "Show", "Eq", "Ord", "Generic" ] + +defaultEnumDeriving :: [HsQName] +defaultEnumDeriving = map (haskellName tcName) [ "Show", "Eq", "Generic", "NFData" ] + +defaultServiceDeriving :: [HsQName] +defaultServiceDeriving = map (haskellName tcName) [ "Generic" ] diff --git a/src/Proto3/Suite/DotProto/Generate/LargeRecord.hs b/src/Proto3/Suite/DotProto/Generate/LargeRecord.hs deleted file mode 100644 --- a/src/Proto3/Suite/DotProto/Generate/LargeRecord.hs +++ /dev/null @@ -1,22 +0,0 @@ -{- | This module provides functions to generate Haskell records using - the large-records library. --} -module Proto3.Suite.DotProto.Generate.LargeRecord where - -import Language.Haskell.Syntax -import Proto3.Suite.DotProto.Generate.Syntax - -isLargeRecord :: HsDecl -> Bool -isLargeRecord (HsDataDecl _ _ _ _ [HsRecDecl _ _ (_fld1:_fld2:_)] _) = True -isLargeRecord _ = False - --- | Generate 'NFData' instance for a type using large-generics -nfDataInstD :: HsDecl -> String -> HsDecl -nfDataInstD typeDecl typeName = - instDecl_ (haskellName "NFData") - [ type_ typeName ] - [ HsFunBind [rnfDecl] | isLargeRecord typeDecl ] - where - rnfDecl = match_ (HsIdent "rnf") [] - (HsUnGuardedRhs (HsVar (lrName "grnf"))) - [] diff --git a/src/Proto3/Suite/DotProto/Generate/Record.hs b/src/Proto3/Suite/DotProto/Generate/Record.hs --- a/src/Proto3/Suite/DotProto/Generate/Record.hs +++ b/src/Proto3/Suite/DotProto/Generate/Record.hs @@ -1,14 +1,12 @@ -{- | This module provides functions to generate regular Haskell records - without using the large-records library. --} +-- | This module provides functions to generate Haskell records module Proto3.Suite.DotProto.Generate.Record where -import Language.Haskell.Syntax +import GHC.Types.Name.Occurrence (tcName) import Proto3.Suite.DotProto.Generate.Syntax --- | Generate 'NFData' instance for a type using GHC generics +-- | Generate `Control.DeepSeq.NFData` instance for a type using GHC generics nfDataInstD :: HsDecl -> String -> HsDecl nfDataInstD _ typeName = - instDecl_ (haskellName "NFData") - [ type_ typeName ] - [] + instDecl_ (haskellName tcName "NFData") + [ type_ typeName ] + [] diff --git a/src/Proto3/Suite/DotProto/Generate/Swagger.hs b/src/Proto3/Suite/DotProto/Generate/Swagger.hs --- a/src/Proto3/Suite/DotProto/Generate/Swagger.hs +++ b/src/Proto3/Suite/DotProto/Generate/Swagger.hs @@ -59,6 +59,10 @@ -- Zig-zag encoding issues do not matter to JSONPB. deriving newtype instance ToSchema a => ToSchema (Signed a) +-- `Proto3.Suite.Types.ForceEmit` affects the binary format, not the JSONPB schema, but +-- that might change if we find a way to express the meaning of omission in such a schema. +deriving newtype instance ToSchema a => ToSchema (Proto3.Suite.Types.ForceEmit a) + -- Packed/unpacked distinctions do not matter to JSONPB. deriving via (V.Vector a) instance ToSchema a => ToSchema (NestedVec a) deriving via (V.Vector a) instance ToSchema a => ToSchema (PackedVec a) diff --git a/src/Proto3/Suite/DotProto/Generate/Syntax.hs b/src/Proto3/Suite/DotProto/Generate/Syntax.hs --- a/src/Proto3/Suite/DotProto/Generate/Syntax.hs +++ b/src/Proto3/Suite/DotProto/Generate/Syntax.hs @@ -1,178 +1,1213 @@ -{-| Utilities to manipulate Haskell AST -} -module Proto3.Suite.DotProto.Generate.Syntax where - -import Language.Haskell.Syntax - -haskellName, jsonpbName, grpcName, lrName, protobufName, protobufASTName, proxyName :: String -> HsQName -haskellName name = Qual (Module "Hs") (HsIdent name) -jsonpbName name = Qual (Module "HsJSONPB") (HsIdent name) -grpcName name = Qual (Module "HsGRPC") (HsIdent name) -lrName name = Qual (Module "LR") (HsIdent name) -protobufName name = Qual (Module "HsProtobuf") (HsIdent name) -protobufASTName name = Qual (Module "HsProtobufAST") (HsIdent name) -proxyName name = Qual (Module "Proxy") (HsIdent name) - -haskellNS :: Module -haskellNS = Module "Hs" - --------------------------------------------------------------------------------- --- --- * Wrappers around haskell-src-exts constructors --- - -apply :: HsExp -> [HsExp] -> HsExp -apply f = paren . foldl HsApp f - -maybeModify :: HsExp -> Maybe HsExp -> HsExp -maybeModify x Nothing = x -maybeModify x (Just f) = paren (HsApp f (paren x)) - -paren :: HsExp -> HsExp -paren e@(HsParen _) = e -paren e = HsParen e - -applicativeApply :: HsExp -> [HsExp] -> HsExp -applicativeApply f = foldl snoc nil - where - nil = HsApp pureE f - - snoc g x = HsInfixApp g apOp x - -tyApp :: HsType -> [HsType] -> HsType -tyApp = foldl HsTyApp - -module_ :: Module -> Maybe [HsExportSpec] -> [HsImportDecl] -> [HsDecl] -> HsModule -module_ = HsModule defaultSrcLoc - -importDecl_ :: Module -> Bool -> Maybe Module -> Maybe (Bool, [HsImportSpec]) -> HsImportDecl -importDecl_ = HsImportDecl defaultSrcLoc - -dataDecl_ :: String -> [HsConDecl] -> [HsQName] -> HsDecl -dataDecl_ messageName [constructor@(HsRecDecl _ _ [_])] = - HsNewTypeDecl defaultSrcLoc [] (HsIdent messageName) [] constructor -dataDecl_ messageName constructors = - HsDataDecl defaultSrcLoc [] (HsIdent messageName) [] constructors - -recDecl_ :: HsName -> [([HsName], HsBangType)] -> HsConDecl -recDecl_ = HsRecDecl defaultSrcLoc - -conDecl_ :: HsName -> [HsBangType] -> HsConDecl -conDecl_ = HsConDecl defaultSrcLoc - -instDecl_ :: HsQName -> [HsType] -> [HsDecl] -> HsDecl -instDecl_ = HsInstDecl defaultSrcLoc [] - -match_ :: HsName -> [HsPat] -> HsRhs -> [HsDecl] -> HsMatch -match_ = HsMatch defaultSrcLoc - -unqual_ :: String -> HsQName -unqual_ = UnQual . HsIdent - -uvar_ :: String -> HsExp -uvar_ = HsVar . unqual_ - -protobufType_, primType_, protobufStringType_, protobufBytesType_ :: String -> HsType -protobufType_ = HsTyCon . protobufName -primType_ = HsTyCon . haskellName -protobufStringType_ = HsTyApp (protobufType_ "String") . HsTyCon . haskellName -protobufBytesType_ = HsTyApp (protobufType_ "Bytes") . HsTyCon . haskellName - -protobufFixedType_, protobufSignedType_, protobufWrappedType_ :: HsType -> HsType -protobufFixedType_ = HsTyApp (protobufType_ "Fixed") -protobufSignedType_ = HsTyApp (protobufType_ "Signed") -protobufWrappedType_ = HsTyApp (HsTyCon (protobufName "Wrapped")) - -type_ :: String -> HsType -type_ = HsTyCon . unqual_ - -patVar :: String -> HsPat -patVar = HsPVar . HsIdent - -alt_ :: HsPat -> HsGuardedAlts -> [HsDecl] -> HsAlt -alt_ = HsAlt defaultSrcLoc - -str_ :: String -> HsExp -str_ = HsLit . HsString - --- | For some reason, haskell-src-exts needs this 'SrcLoc' parameter --- for some data constructors. Its value does not affect --- pretty-printed output -defaultSrcLoc :: SrcLoc -defaultSrcLoc = SrcLoc "" 0 0 - --------------------------------------------------------------------------------- --- --- * Common Haskell expressions, constructors, and operators --- - -dotProtoFieldC, primC, repeatedC, nestedRepeatedC, namedC, mapC, - fieldNumberC, singleC, dotsC, pathC, qualifiedC, anonymousC, dotProtoOptionC, - identifierC, stringLitC, intLitC, floatLitC, boolLitC, trueC, falseC, nothingC, - justC, forceEmitC, encodeMessageFieldE, fromStringE, decodeMessageFieldE, - pureE, returnE, mappendE, memptyE, msumE, atE, oneofE, fmapE :: HsExp - -dotProtoFieldC = HsVar (protobufASTName "DotProtoField") -primC = HsVar (protobufASTName "Prim") -repeatedC = HsVar (protobufASTName "Repeated") -nestedRepeatedC = HsVar (protobufASTName "NestedRepeated") -namedC = HsVar (protobufASTName "Named") -mapC = HsVar (protobufASTName "Map") -fieldNumberC = HsVar (protobufName "FieldNumber") -singleC = HsVar (protobufASTName "Single") -pathC = HsVar (protobufASTName "Path") -dotsC = HsVar (protobufASTName "Dots") -qualifiedC = HsVar (protobufASTName "Qualified") -anonymousC = HsVar (protobufASTName "Anonymous") -dotProtoOptionC = HsVar (protobufASTName "DotProtoOption") -identifierC = HsVar (protobufASTName "Identifier") -stringLitC = HsVar (protobufASTName "StringLit") -intLitC = HsVar (protobufASTName "IntLit") -floatLitC = HsVar (protobufASTName "FloatLit") -boolLitC = HsVar (protobufASTName "BoolLit") -forceEmitC = HsVar (protobufName "ForceEmit") -encodeMessageFieldE = HsVar (protobufName "encodeMessageField") -decodeMessageFieldE = HsVar (protobufName "decodeMessageField") -atE = HsVar (protobufName "at") -oneofE = HsVar (protobufName "oneof") - -trueC = HsVar (haskellName "True") -falseC = HsVar (haskellName "False") -nothingC = HsVar (haskellName "Nothing") -justC = HsVar (haskellName "Just") -fromStringE = HsVar (haskellName "fromString") -pureE = HsVar (haskellName "pure") -returnE = HsVar (haskellName "return") -mappendE = HsVar (haskellName "mappend") -memptyE = HsVar (haskellName "mempty") -msumE = HsVar (haskellName "msum") -fmapE = HsVar (haskellName "fmap") - -apOp :: HsQOp -apOp = HsQVarOp (UnQual (HsSymbol "<*>")) - -fmapOp :: HsQOp -fmapOp = HsQVarOp (UnQual (HsSymbol "<$>")) - -composeOp :: HsQOp -composeOp = HsQVarOp (Qual haskellNS (HsSymbol ".")) - -bindOp :: HsQOp -bindOp = HsQVarOp (Qual haskellNS (HsSymbol ">>=")) - -altOp :: HsQOp -altOp = HsQVarOp (UnQual (HsSymbol "<|>")) - -toJSONPBOp :: HsQOp -toJSONPBOp = HsQVarOp (UnQual (HsSymbol ".=")) - -parseJSONPBOp :: HsQOp -parseJSONPBOp = HsQVarOp (UnQual (HsSymbol ".:")) - -neConsOp :: HsQOp -neConsOp = HsQVarOp (Qual haskellNS (HsSymbol ":|")) - -intE :: Integral a => a -> HsExp -intE x = (if x < 0 then HsParen else id) . HsLit . HsInt . fromIntegral $ x - -intP :: Integral a => a -> HsPat -intP x = (if x < 0 then HsPParen else id) . HsPLit . HsInt . fromIntegral $ x +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE NegativeLiterals #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} + +{-| Utilities to manipulate Haskell AST -} +module Proto3.Suite.DotProto.Generate.Syntax where + +import Data.Functor ((<&>)) +import Data.Maybe (maybeToList) +#if !MIN_VERSION_ghc_lib_parser(9,12,0) +import GHC.Data.Bag (listToBag) +#endif +import GHC.Data.FastString (mkFastString) +import qualified GHC.Hs as GHC + (HsDecl(..), HsDerivingClause(..), HsModule(..), HsTyVarBndr(..), HsType(..)) + +import GHC.Types.Basic (Origin(..)) +import GHC.Types.Name.Occurrence (NameSpace, dataName, mkOccName, tcName, tvName, varName) +import GHC.Types.Name.Reader (mkRdrQual, mkRdrUnqual, rdrNameSpace) +import GHC.Types.SrcLoc (GenLocated(..), SrcSpan, generatedSrcSpan) + +#if MIN_VERSION_ghc_lib_parser(9,10,0) +import GHC.Types.Basic (GenReason(OtherExpansion)) +#endif +#if MIN_VERSION_ghc_lib_parser(9,8,0) +import Control.Arrow ((***)) +import Data.Bool (bool) +import Data.Ratio ((%)) +import Data.Void (Void) +import GHC.Hs hiding (HsBind, HsDecl, HsDerivingClause, HsOuterFamEqnTyVarBndrs, + HsOuterSigTyVarBndrs, HsTyVarBndr, HsType) +import qualified GHC.Hs as GHC (HsOuterFamEqnTyVarBndrs, HsOuterSigTyVarBndrs) +import GHC.Types.Basic (DoPmc(..), TopLevelFlag(..)) +import GHC.Types.Fixity (LexicalFixity(..)) +import GHC.Types.PkgQual (RawPkgQual(..)) +import GHC.Types.SourceText + (IntegralLit(..), FractionalExponentBase(..), FractionalLit(..), SourceText(..)) +#elif MIN_VERSION_ghc_lib_parser(9,6,0) +import Control.Arrow ((***)) +import Data.Bool (bool) +import Data.Ratio ((%)) +import Data.Void (Void) +import GHC.Hs hiding (HsBind, HsDecl, HsDerivingClause, HsOuterFamEqnTyVarBndrs, + HsOuterSigTyVarBndrs, HsTyVarBndr, HsType) +import qualified GHC.Hs as GHC (HsOuterFamEqnTyVarBndrs, HsOuterSigTyVarBndrs) +import GHC.Types.Basic (TopLevelFlag(..)) +import GHC.Types.Fixity (LexicalFixity(..)) +import GHC.Types.PkgQual (RawPkgQual(..)) +import GHC.Types.SourceText + (IntegralLit(..), FractionalExponentBase(..), FractionalLit(..), SourceText(..)) +#elif MIN_VERSION_ghc_lib_parser(9,4,0) +import Data.Ratio ((%)) +import Data.Void (Void) +import GHC.Hs hiding (HsBind, HsDecl, HsDerivingClause, HsOuterFamEqnTyVarBndrs, + HsOuterSigTyVarBndrs, HsTyVarBndr, HsType) +import qualified GHC.Hs as GHC (HsOuterFamEqnTyVarBndrs, HsOuterSigTyVarBndrs) +import GHC.Types.Basic (PromotionFlag(..), TopLevelFlag(..)) +import GHC.Types.Fixity (LexicalFixity(..)) +import GHC.Types.PkgQual (RawPkgQual(..)) +import GHC.Types.SourceText + (IntegralLit(..), FractionalExponentBase(..), FractionalLit(..), SourceText(..)) +import GHC.Types.SrcLoc (LayoutInfo(..)) +import GHC.Unit (IsBootInterface(..)) +import GHC.Unit.Module (ModuleName, mkModuleName) +#else +import Data.Ratio ((%)) +import Data.Void (Void) +import GHC.Hs hiding (HsBind, HsDecl, HsDerivingClause, HsOuterFamEqnTyVarBndrs, + HsOuterSigTyVarBndrs, HsTyVarBndr, HsType) +import qualified GHC.Hs as GHC (HsOuterFamEqnTyVarBndrs, HsOuterSigTyVarBndrs) +import GHC.Types.Basic (PromotionFlag(..), TopLevelFlag(..)) +import GHC.Types.Fixity (LexicalFixity(..)) +import GHC.Types.SourceText + (IntegralLit(..), FractionalExponentBase(..), FractionalLit(..), SourceText(..)) +import GHC.Types.SrcLoc (LayoutInfo(..), noLoc) +import GHC.Unit (IsBootInterface(..)) +import GHC.Unit.Module (ModuleName, mkModuleName) +#endif + +#if MIN_VERSION_base(4,16,0) +import GHC.Exts (considerAccessible) +#endif + +type HsAlt = LMatch GhcPs HsExp +type HsBangType = LBangType GhcPs +type HsBind = LHsBind GhcPs +type HsConDecl = LConDecl GhcPs +type HsDecl = LHsDecl GhcPs +type HsDerivStrategy = LDerivStrategy GhcPs +type HsDerivingClause = LHsDerivingClause GhcPs +type HsExp = LHsExpr GhcPs +type HsExportSpec = LIE GhcPs +type HsGrhs = LGRHS GhcPs HsExp +type HsGuardedAlts = GRHSs GhcPs HsExp +type HsImportDecl = LImportDecl GhcPs +type HsImportSpec = LIE GhcPs +type HsMatch = LMatch GhcPs HsExp +type HsName = LIdP GhcPs +type HsOuterFamEqnTyVarBndrs = GHC.HsOuterFamEqnTyVarBndrs GhcPs +type HsOuterSigTyVarBndrs = GHC.HsOuterSigTyVarBndrs GhcPs +type HsPat = LPat GhcPs +type HsQName = LIdP GhcPs +type HsQOp = LHsExpr GhcPs +type HsSig = LSig GhcPs +type HsTyVarBndrU = LHsTyVarBndr () GhcPs +type HsTyVarBndrV = LHsTyVarBndr +#if MIN_VERSION_ghc_lib_parser(9,8,0) + (HsBndrVis GhcPs) +#else + () +#endif + GhcPs +type HsType = LHsType GhcPs +type Module = ModuleName + +#if MIN_VERSION_ghc_lib_parser(9,10,0) + +pattern VirtualBraces :: Int -> EpLayout +pattern VirtualBraces indentation = EpVirtualBraces indentation + +#endif + +class SyntaxDefault a + where + synDef :: a + +instance SyntaxDefault () + where + synDef = () + +instance (SyntaxDefault a, SyntaxDefault b, SyntaxDefault c) => SyntaxDefault (a, b, c) + where + synDef = (synDef, synDef, synDef) + +instance SyntaxDefault (Maybe a) + where + synDef = Nothing + +instance SyntaxDefault [a] + where + synDef = [] + +instance (SyntaxDefault a, SyntaxDefault b) => SyntaxDefault (a, b) + where + synDef = (synDef, synDef) + +instance SyntaxDefault NoExtField + where + synDef = NoExtField + +instance SyntaxDefault SourceText + where + synDef = NoSourceText + +instance SyntaxDefault SrcSpan + where + synDef = generatedSrcSpan + +#if MIN_VERSION_ghc_lib_parser(9,10,0) + +instance SyntaxDefault AnnParen + where + synDef = noAnn + +instance SyntaxDefault AnnPragma + where + synDef = noAnn + +instance SyntaxDefault AnnSig + where + synDef = noAnn + +instance SyntaxDefault AnnsIf + where + synDef = noAnn + +instance SyntaxDefault (AnnSortKey tag) + where + synDef = NoAnnSortKey + +instance NoAnn a => SyntaxDefault (EpAnn a) + where + synDef = noAnn + +instance SyntaxDefault EpAnnHsCase + where + synDef = noAnn + +instance SyntaxDefault (EpToken token) + where + synDef = NoEpTok + +instance SyntaxDefault (EpUniToken token utoken) + where + synDef = NoEpUniTok + +instance SyntaxDefault (HsBndrVis GhcPs) + where + synDef = HsBndrRequired synDef + +#endif + +#if MIN_VERSION_ghc_lib_parser(9,8,0) && !MIN_VERSION_ghc_lib_parser(9,10,0) + +instance SyntaxDefault (HsBndrVis GhcPs) + where + synDef = HsBndrRequired + +#endif + +#if MIN_VERSION_ghc_lib_parser(9,4,0) + +instance SyntaxDefault a => SyntaxDefault (GenLocated TokenLocation a) + where + synDef = L NoTokenLoc synDef + +#endif + +#if MIN_VERSION_ghc_lib_parser(9,4,0) && !MIN_VERSION_ghc_lib_parser(9,10,0) + +instance SyntaxDefault (SrcAnn a) + where + synDef = noSrcSpanA + +instance SyntaxDefault (HsToken tok) + where + synDef = HsTok + +instance SyntaxDefault (HsUniToken tok utok) + where + synDef = HsNormalTok + +#else + +instance SyntaxDefault IsUnicodeSyntax + where + synDef = NormalSyntax + +#endif + +pattern PfxCon :: [arg] -> HsConDetails Void arg r +pattern PfxCon args = PrefixCon [] args + +#if !MIN_VERSION_ghc_lib_parser(9,10,0) + +instance SyntaxDefault e => SyntaxDefault (GenLocated (SrcAnn a) e) + where + synDef = noLocA synDef + +instance SyntaxDefault (EpAnn a) + where + synDef = EpAnnNotUsed + +instance SyntaxDefault EpAnnComments + where + synDef = emptyComments + +instance SyntaxDefault AnnSortKey + where + synDef = NoAnnSortKey + +#endif + +#if !MIN_VERSION_ghc_lib_parser(9,4,0) + +dataConCantHappen :: NoExtCon -> a +dataConCantHappen = noExtCon + +#endif + +haskellName, jsonpbName, grpcName, lrName, protobufName, + protobufASTName, protobufFormName, proxyName :: + NameSpace -> String -> HsQName +haskellName = qual_ haskellNS +jsonpbName = qual_ (mkModuleName "HsJSONPB") +grpcName = qual_ (mkModuleName "HsGRPC") +lrName = qual_ (mkModuleName "LR") +protobufName = qual_ (mkModuleName "HsProtobuf") +protobufASTName = qual_ (mkModuleName "HsProtobufAST") +protobufFormName = qual_ protobufFormNS +proxyName = qual_ (mkModuleName "Proxy") + +haskellNS :: ModuleName +haskellNS = mkModuleName "Hs" + +protobufFormNS :: ModuleName +protobufFormNS = mkModuleName "HsProtobufForm" + +protobufFormType :: NameSpace -> String -> HsType +protobufFormType ns = typeNamed_ . protobufFormName ns + +formProtoTypeT :: HsType +formProtoTypeT = protobufFormType tcName "ProtoType" + +formNamesOf, formNumberOf, formOneOfOf, formCardinalityOf, formProtoTypeOf :: HsQName +formNamesOf = protobufFormName tcName "NamesOf" +formNumberOf = protobufFormName tcName "NumberOf" +formOneOfOf = protobufFormName tcName "OneOfOf" +formCardinalityOf = protobufFormName tcName "CardinalityOf" +formProtoTypeOf = protobufFormName tcName "ProtoTypeOf" + +formFieldNotFound, formFieldOrOneOfNotFound :: HsType +formFieldNotFound = protobufFormType tcName "FieldNotFound" +formFieldOrOneOfNotFound = protobufFormType tcName "FieldOrOneOfNotFound" + +formUnpackedT, formPackedT :: HsType +formUnpackedT = protobufFormType dataName "Unpacked" +formPackedT = protobufFormType dataName "Packed" + +formCardinalityT, formImplicitT, formOptionalT, formRepeatedT :: HsType +formCardinalityT = protobufFormType tcName "Cardinality" +formImplicitT = protobufFormType dataName "Implicit" +formOptionalT = protobufFormType dataName "Optional" +formRepeatedT = protobufFormType dataName "Repeated" + +formInt32T, formInt64T, formSInt32T, formSInt64T, formUInt32T, formUInt64T, + formFixed32T, formFixed64T, formSFixed32T, formSFixed64T, + formStringT, formBytesT, formBoolT, formFloatT, formDoubleT, + formEnumerationT, formMessageT, formMapT :: HsType +formInt32T = protobufFormType dataName "Int32" +formInt64T = protobufFormType dataName "Int64" +formSInt32T = protobufFormType dataName "SInt32" +formSInt64T = protobufFormType dataName "SInt64" +formUInt32T = protobufFormType dataName "UInt32" +formUInt64T = protobufFormType dataName "UInt64" +formFixed32T = protobufFormType dataName "Fixed32" +formFixed64T = protobufFormType dataName "Fixed64" +formSFixed32T = protobufFormType dataName "SFixed32" +formSFixed64T = protobufFormType dataName "SFixed64" +formStringT = protobufFormType dataName "String" +formBytesT = protobufFormType dataName "Bytes" +formBoolT = protobufFormType dataName "Bool" +formFloatT = protobufFormType dataName "Float" +formDoubleT = protobufFormType dataName "Double" +formEnumerationT = protobufFormType dataName "Enumeration" +formMessageT = protobufFormType dataName "Message" +formMapT = protobufFormType dataName "Map" + +formWrapperT :: HsType +formWrapperT = protobufFormType tcName "Wrapper" + +-------------------------------------------------------------------------------- +-- +-- * Wrappers around ghc constructors +-- + +app :: HsExp -> HsExp -> HsExp +app f x = mkHsApp f (paren x) + +apply :: HsExp -> [HsExp] -> HsExp +apply f xs = mkHsApps f (map paren xs) + +appAt :: HsExp -> HsType -> HsExp +appAt f t = noLocA (HsAppType synDef f +#if MIN_VERSION_ghc_lib_parser(9,6,0) && !MIN_VERSION_ghc_lib_parser(9,10,0) + synDef +#endif + (HsWC NoExtField (parenTy t))) + +applyAt :: HsExp -> [HsType] -> HsExp +applyAt f = paren . foldl appAt f + +opApp :: HsExp -> HsQOp -> HsExp -> HsExp +opApp x op y = noLocA $ OpApp synDef x op y + +maybeModify :: HsExp -> Maybe HsExp -> HsExp +maybeModify x Nothing = x +maybeModify x (Just f) = paren (app f x) + +paren :: HsExp -> HsExp +paren = mkLHsPar + +parenPat :: HsPat -> HsPat +parenPat = mkParPat + +parenTy :: HsType -> HsType +parenTy t@(L _ (GHC.HsParTy {})) = t +parenTy t@(L _ (GHC.HsTyVar {})) = t +parenTy t@(L _ (GHC.HsTupleTy {})) = t +parenTy t = nlHsParTy t + +applicativeApply :: HsExp -> [HsExp] -> HsExp +applicativeApply f = foldl snoc nil + where + nil = apply pureE [f] + snoc g x = noLocA (OpApp synDef g apOp x) + +tyApp :: HsType -> HsType -> HsType +tyApp f = parenTy . mkHsAppTy (parenTy f) . parenTy + +tyApply :: HsType -> [HsType] -> HsType +tyApply = foldl tyApp + +-- | Whenever @f@ is not itself a type application, +-- @'splitTyApp' ('tyApply' f as) = (f, as)@. +splitTyApp :: HsType -> (HsType, [HsType]) +splitTyApp (L _ (GHC.HsParTy _ x)) = splitTyApp x +splitTyApp (L _ (GHC.HsAppTy NoExtField x y)) = (++ [y]) <$> splitTyApp x +splitTyApp x = (x, []) + +tyConApp :: HsName -> HsType -> HsType +tyConApp = tyApp . typeNamed_ + +tyConApply :: HsName -> [HsType] -> HsType +tyConApply = tyApply . typeNamed_ + +-- | @'splitTyConApp' ('tyApply' (L _ (GHC.HsTyVar _ NotPromoted tc)) as) = Just (tc, as)@. +splitTyConApp :: HsType -> Maybe (HsName, [HsType]) +splitTyConApp x = case splitTyApp x of + (L _ (GHC.HsTyVar _ NotPromoted tc), as) -> Just (tc, as) + _ -> Nothing + +funTy :: HsType -> HsType -> HsType +funTy a b = noLocA (GHC.HsFunTy synDef unrestrictedArrow_ a b) + +unrestrictedArrow_ :: HsArrow GhcPs +unrestrictedArrow_ = HsUnrestrictedArrow synDef + +unbangedTy_ :: HsType -> HsBangType +#if MIN_VERSION_ghc_lib_parser(9,12,0) +unbangedTy_ = noLocA . GHC.HsBangTy noAnn (HsBang NoSrcUnpack NoSrcStrict) . parenTy +#else +unbangedTy_ = noLocA . GHC.HsBangTy synDef (HsSrcBang synDef NoSrcUnpack NoSrcStrict) . parenTy +#endif + +#if MIN_VERSION_ghc_lib_parser(9,6,0) +-- https://hackage.haskell.org/package/ghc-lib-parser-9.6.2.20231121/docs/GHC-Hs.html#t:HsModule +module_ :: ModuleName -> Maybe [HsExportSpec] -> [HsImportDecl] -> [HsDecl] -> GHC.HsModule GhcPs +module_ moduleName maybeExports imports decls = + GHC.HsModule + { hsmodExt = XModulePs + { hsmodAnn = synDef + , hsmodLayout = VirtualBraces 2 + , hsmodDeprecMessage = Nothing + , hsmodHaddockModHeader = Nothing + } + , hsmodName = Just $ noLocA moduleName + , hsmodExports = noLocA <$> maybeExports + , hsmodImports = imports + , hsmodDecls = decls + } +#else +-- https://hackage.haskell.org/package/ghc-lib-parser-9.2.2.20220307/docs/GHC-Hs.html#t:HsModule +module_ :: ModuleName -> Maybe [HsExportSpec] -> [HsImportDecl] -> [HsDecl] -> GHC.HsModule +module_ moduleName maybeExports imports decls = + GHC.HsModule + { hsmodAnn = synDef + , hsmodLayout = VirtualBraces 2 + , hsmodName = Just $ noLocA moduleName + , hsmodExports = noLocA <$> maybeExports + , hsmodImports = imports + , hsmodDecls = decls + , hsmodDeprecMessage = Nothing + , hsmodHaddockModHeader = Nothing + } +#endif + +importDecl_ :: + ModuleName -> + Bool -> + Maybe ModuleName -> + Maybe (Bool, [HsImportSpec]) -> + HsImportDecl +importDecl_ moduleName qualified maybeAs details = noLocA ImportDecl + { +#if MIN_VERSION_ghc_lib_parser(9,6,0) + ideclExt = XImportDeclPass + { ideclAnn = synDef + , ideclSourceText = synDef + , ideclImplicit = False + } +#else + ideclExt = synDef + , ideclSourceSrc = NoSourceText +#endif + , ideclName = noLocA moduleName + , ideclPkgQual = +#if MIN_VERSION_ghc_lib_parser(9,4,0) + NoRawPkgQual +#else + Nothing +#endif + , ideclSource = NotBoot + , ideclSafe = False + , ideclQualified = if qualified then QualifiedPre else NotQualified +#if !MIN_VERSION_ghc_lib_parser(9,6,0) + , ideclImplicit = False +#endif + , ideclAs = noLocA <$> maybeAs +#if MIN_VERSION_ghc_lib_parser(9,6,0) + , ideclImportList = (bool Exactly EverythingBut *** noLocA) <$> details +#else + , ideclHiding = fmap noLocA <$> details +#endif + } + +ieName_ :: HsName -> HsImportSpec +ieName_ = + noLocA . +#if MIN_VERSION_ghc_lib_parser(9,10,0) + flip (IEVar synDef) Nothing . +#else + IEVar synDef . +#endif + noLocA . + IEName +#if MIN_VERSION_ghc_lib_parser(9,6,0) + synDef +#endif + +ieNameAll_ :: HsName -> HsImportSpec +ieNameAll_ = + noLocA . +#if MIN_VERSION_ghc_lib_parser(9,10,0) + flip (IEThingAll synDef) Nothing . +#else + (IEThingAll synDef) . +#endif + noLocA . + IEName +#if MIN_VERSION_ghc_lib_parser(9,6,0) + synDef +#endif + +dataDecl_ :: String -> [HsTyVarBndrV] -> [HsConDecl] -> [HsQName] -> HsDecl +dataDecl_ messageName bndrs constructors derivedInstances = noLocA $ GHC.TyClD NoExtField DataDecl + { tcdDExt = synDef + , tcdLName = unqual_ tcName messageName + , tcdTyVars = HsQTvs NoExtField bndrs + , tcdFixity = Prefix + , tcdDataDefn = HsDataDefn +#if MIN_VERSION_ghc_lib_parser(9,12,0) + { dd_ext = noAnn +#else + { dd_ext = NoExtField +#endif +#if !MIN_VERSION_ghc_lib_parser(9,6,0) + , dd_ND = maybe DataType (const NewType) newtypeCtor +#endif + , dd_ctxt = synDef + , dd_cType = Nothing + , dd_kindSig = Nothing + , dd_cons = +#if MIN_VERSION_ghc_lib_parser(9,6,0) + maybe (DataTypeCons False constructors) NewTypeCon newtypeCtor +#else + constructors +#endif + + , dd_derivs = + maybeToList $ derivingClause_ Nothing $ derivedInstances <&> \className -> + (implicitOuterSigTyVarBinders_, typeNamed_ className) + } + } + where + -- TO DO: Support GADT syntax, assuming we ever start to use it in generated code. + newtypeCtor = case constructors of + [ con@( L _ ( ConDeclH98 { con_forall = False + , con_ex_tvs = [] + , con_mb_cxt = Nothing + , con_args = args + } ) ) ] -> case args of + PfxCon [_] -> Just con + RecCon (L _ [L _ ConDeclField { cd_fld_names = [_] }]) -> Just con + _ -> Nothing + _ -> Nothing + +recDecl_ :: HsName -> [([HsName], HsBangType)] -> HsConDecl +recDecl_ name fields = noLocA ConDeclH98 +#if MIN_VERSION_ghc_lib_parser(9,12,0) + { con_ext = noAnn +#else + { con_ext = synDef +#endif + , con_name = name + , con_forall = False + , con_ex_tvs = [] + , con_mb_cxt = Nothing + , con_args = RecCon $ noLocA $ fields <&> \(names, bangTy) -> noLocA ConDeclField + { cd_fld_ext = synDef + , cd_fld_names = +#if MIN_VERSION_ghc_lib_parser(9,4,0) + noLocA +#else + noLoc +#endif + . FieldOcc NoExtField <$> names + , cd_fld_type = bangTy + , cd_fld_doc = Nothing + } + , con_doc = Nothing + } + +conDecl_ :: HsName -> [HsBangType] -> HsConDecl +conDecl_ name fields = noLocA ConDeclH98 +#if MIN_VERSION_ghc_lib_parser(9,12,0) + { con_ext = noAnn +#else + { con_ext = synDef +#endif + , con_name = name + , con_forall = False + , con_ex_tvs = [] + , con_mb_cxt = Nothing + , con_args = PfxCon (HsScaled unrestrictedArrow_ <$> fields) + , con_doc = Nothing + } + +derivingClause_ :: + Maybe HsDerivStrategy -> + [(HsOuterSigTyVarBndrs, HsType)] -> + Maybe HsDerivingClause +derivingClause_ _ [] = Nothing +derivingClause_ strategy classTypes = Just $ L synDef $ + GHC.HsDerivingClause + { GHC.deriv_clause_ext = synDef + , GHC.deriv_clause_strategy = strategy + , GHC.deriv_clause_tys = noLocA $ DctMulti NoExtField $ + noLocA . uncurry (HsSig NoExtField) <$> classTypes + } + +splitDerivingClause :: + HsDerivingClause -> + (Maybe HsDerivStrategy, [(HsOuterSigTyVarBndrs, HsType)]) +splitDerivingClause (L _ GHC.HsDerivingClause + { GHC.deriv_clause_strategy = strategy + , GHC.deriv_clause_tys = L _ clauseTypes + }) = + case clauseTypes of + DctSingle _ sig -> (strategy, [splitSig sig]) + DctMulti _ sigs -> (strategy, map splitSig sigs) + where + splitSig (L _ sig) = case sig of + HsSig _ binders classType -> (binders, classType) + XHsSigType impossible +#if MIN_VERSION_base(4,16,0) + | considerAccessible + -- We use 'considerAccessible' because GHC 9.4.6 will issue the warning + -- "Pattern match is redundant" (-Woverlapping-patterns) if we provide + -- this match *and* use its strict field 'impossible', and yet + -- if we omit this match then GHC 9.4.6 will issue the warning + -- "Pattern match(es) are non-exhaustive" (-Wincomplete-patterns). + -- We cannot avoid the warning without either 'considerAccessible' + -- or avoiding any use of 'impossible', which would require 'error' + -- or similar to handle this impossible case match. +#endif + -> dataConCantHappen impossible + +instDecl_ :: HsQName -> [HsType] -> [HsBind] -> HsDecl +instDecl_ className classArgs binds = noLocA $ GHC.InstD NoExtField ClsInstD + { cid_d_ext = NoExtField + , cid_inst = ClsInstDecl +#if MIN_VERSION_ghc_lib_parser(9,12,0) + { cid_ext = (Nothing, noAnn, NoAnnSortKey) +#else + { cid_ext = synDef +#endif + , cid_poly_ty = noLocA $ HsSig NoExtField implicitOuterSigTyVarBinders_ (tyConApply className classArgs) +#if MIN_VERSION_ghc_lib_parser(9,12,0) + , cid_binds = binds +#else + , cid_binds = listToBag binds +#endif + , cid_sigs = [] + , cid_tyfam_insts = [] + , cid_datafam_insts = [] + , cid_overlap_mode = Nothing + } + } + +typeOfInstDecl :: HsDecl -> Maybe (HsOuterSigTyVarBndrs, HsType) +typeOfInstDecl ( L _ ( GHC.InstD _ ClsInstD + { cid_inst = ClsInstDecl + { cid_poly_ty = L _ (HsSig _ binders classType) + } } ) ) = + Just (binders, classType) +typeOfInstDecl _ = + Nothing + +closedTyFamDecl_ :: + HsQName -> + [HsTyVarBndrV] -> + HsType -> + [(Maybe [HsTyVarBndrU], [HsType], HsType)] -> + HsDecl +closedTyFamDecl_ tyFamName famBndrs resultKind eqns = + noLocA $ GHC.TyClD NoExtField $ FamDecl synDef $ FamilyDecl +#if MIN_VERSION_ghc_lib_parser(9,12,0) + { fdExt = noAnn +#else + { fdExt = synDef +#endif + , fdInfo = ClosedTypeFamily (Just (map onEqn eqns)) + , fdTopLevel = TopLevel + , fdLName = tyFamName + , fdTyVars = HsQTvs synDef famBndrs + , fdFixity = Prefix + , fdResultSig = +#if MIN_VERSION_ghc_lib_parser(9,4,0) + noLocA $ +#else + noLoc $ +#endif + KindSig synDef resultKind + , fdInjectivityAnn = Nothing + } + where + onEqn (eqnBndrs, pats, rhs) = noLocA $ + FamEqn + { feqn_ext = synDef + , feqn_tycon = tyFamName + , feqn_bndrs = maybe (HsOuterImplicit NoExtField) (HsOuterExplicit synDef) eqnBndrs + , feqn_pats = map + (HsValArg +#if MIN_VERSION_ghc_lib_parser(9,10,0) + synDef +#endif + ) pats + , feqn_fixity = Prefix + , feqn_rhs = rhs + } + +tyFamInstDecl_ :: HsQName -> Maybe [HsTyVarBndrU] -> [HsType] -> HsType -> HsDecl +tyFamInstDecl_ tyFamName bndrs pats rhs = noLocA $ GHC.InstD NoExtField TyFamInstD + { tfid_ext = NoExtField + , tfid_inst = TyFamInstDecl + { tfid_xtn = synDef + , tfid_eqn = FamEqn + { feqn_ext = synDef + , feqn_tycon = tyFamName + , feqn_bndrs = maybe (HsOuterImplicit NoExtField) (HsOuterExplicit synDef) bndrs + , feqn_pats = map + (HsValArg +#if MIN_VERSION_ghc_lib_parser(9,10,0) + synDef +#endif + ) pats + , feqn_fixity = Prefix + , feqn_rhs = rhs + } + } + } + +-- | 'HsBind' includes a location, and this is one of the few places +-- where we do not need a location. Rather than distinguishing in +-- the type between bindings that have a location and those that +-- do not, we simply ignore any binding location given here. +valDecl_ :: HsBind -> HsDecl +valDecl_ (L _ b) = noLocA (GHC.ValD NoExtField b) + +patBind_ :: HsPat -> HsExp -> HsBind +patBind_ (L _ (VarPat _ nm)) rhs = + function_ nm [([], rhs)] -- The comments at 'HsBindLR' say to use 'FunBind'. +patBind_ (L _ (BangPat _ (L _ (VarPat _ nm)))) rhs = + functionLike_ SrcStrict nm [([], rhs)] -- The comments at 'HsBindLR' say to use 'FunBind'. +patBind_ (L _ (LazyPat _ (L _ (VarPat _ nm)))) rhs = + functionLike_ SrcLazy nm [([], rhs)] -- The comments at 'HsBindLR' say to use 'FunBind'. +patBind_ pat rhs = noLocA PatBind + { pat_ext = synDef + , pat_lhs = pat +#if MIN_VERSION_ghc_lib_parser(9,10,0) + , pat_mult = HsNoMultAnn synDef +#endif + , pat_rhs = unguardedGRHSs synDef rhs synDef +#if !MIN_VERSION_ghc_lib_parser(9,6,0) + , pat_ticks = synDef +#endif + } + +-- | @'functionS_' = 'function_' . 'unqual_' 'varName'@ +functionS_ :: String -> [([HsPat], HsExp)] -> HsBind +functionS_ = function_ . unqual_ varName + +-- | A function with prefix syntax (as opposed to infix). +function_ :: HsName -> [([HsPat], HsExp)] -> HsBind +function_ = functionLike_ NoSrcStrict + +functionLike_ :: SrcStrictness -> HsName -> [([HsPat], HsExp)] -> HsBind +functionLike_ strictness name alts = noLocA $ mkFunBind generated name (map match alts) + where + generated :: Origin + generated = Generated +#if MIN_VERSION_ghc_lib_parser(9,10,0) + OtherExpansion +#endif +#if MIN_VERSION_ghc_lib_parser(9,8,0) + DoPmc +#endif + + match :: ([HsPat], HsExp) -> HsMatch +#if MIN_VERSION_ghc_lib_parser(9,12,0) + match (pats, rhs) = mkSimpleMatch ctxt (noLocA pats) rhs +#else + match (pats, rhs) = mkSimpleMatch ctxt pats rhs +#endif + + ctxt = FunRhs + { mc_fun = name + , mc_fixity = Prefix + , mc_strictness = strictness +#if MIN_VERSION_ghc_lib_parser(9,12,0) + , mc_an = noAnn +#endif + } + +typeSig_ :: [HsName] -> HsOuterSigTyVarBndrs -> HsType -> HsDecl +typeSig_ nms bndrs ty = noLocA $ GHC.SigD NoExtField $ TypeSig synDef nms $ + HsWC NoExtField $ + noLocA $ + HsSig NoExtField bndrs ty + +implicitOuterFamEqnTyVarBinders_ :: HsOuterFamEqnTyVarBndrs +implicitOuterFamEqnTyVarBinders_ = HsOuterImplicit NoExtField + +implicitOuterSigTyVarBinders_ :: HsOuterSigTyVarBndrs +implicitOuterSigTyVarBinders_ = HsOuterImplicit NoExtField + +userTyVar_ :: flag -> HsName -> LHsTyVarBndr flag GhcPs +#if MIN_VERSION_ghc_lib_parser(9,12,0) +userTyVar_ flag nm = noLocA $ GHC.HsTvb noAnn flag (HsBndrVar NoExtField nm) (HsBndrNoKind NoExtField) +#else +userTyVar_ flag nm = noLocA $ GHC.UserTyVar synDef flag nm +#endif + +kindedTyVar_ :: flag -> HsName -> HsType -> LHsTyVarBndr flag GhcPs +#if MIN_VERSION_ghc_lib_parser(9,12,0) +kindedTyVar_ flag nm ty = noLocA $ GHC.HsTvb noAnn flag (HsBndrVar NoExtField nm) (HsBndrKind NoExtField ty) +#else +kindedTyVar_ flag nm ty = noLocA $ GHC.KindedTyVar synDef flag nm ty +#endif + +wild_ :: HsPat +wild_ = noLocA $ WildPat NoExtField + +qual_ :: ModuleName -> NameSpace -> String -> HsQName +qual_ m ns name = noLocA $ mkRdrQual m (mkOccName ns name) + +unqual_ :: NameSpace -> String -> HsName +unqual_ ns name = noLocA $ mkRdrUnqual (mkOccName ns name) + +uvar_ :: String -> HsExp +uvar_ = var_ . unqual_ varName + +var_ :: HsQName -> HsExp +var_ = noLocA . HsVar NoExtField + +fieldBind_ :: HsName -> HsExp -> LHsRecField GhcPs HsExp +fieldBind_ nm val = noLocA +#if MIN_VERSION_ghc_lib_parser(9,4,0) + HsFieldBind + { hfbAnn = synDef + , hfbLHS = noLocA $ FieldOcc NoExtField nm + , hfbRHS = val + , hfbPun = False + } +#else + HsRecField + { hsRecFieldAnn = synDef + , hsRecFieldLbl = noLoc $ FieldOcc NoExtField nm + , hsRecFieldArg = val + , hsRecPun = False + } +#endif + +recordCtor_ :: HsName -> [LHsRecField GhcPs HsExp] -> HsExp +recordCtor_ nm fields = noLocA RecordCon + { rcon_ext = synDef + , rcon_con = nm + , rcon_flds = HsRecFields + { rec_flds = fields + , rec_dotdot = Nothing +#if MIN_VERSION_ghc_lib_parser(9,12,0) + , rec_ext = NoExtField +#endif + } + } + +fieldUpd_ :: HsName -> HsExp -> LHsRecUpdField GhcPs +#if MIN_VERSION_ghc_lib_parser(9,8,0) + GhcPs +#endif +fieldUpd_ nm val = noLocA +#if MIN_VERSION_ghc_lib_parser(9,4,0) + HsFieldBind + { hfbAnn = synDef +#if MIN_VERSION_ghc_lib_parser(9,12,0) + , hfbLHS = noLocA $ FieldOcc NoExtField nm +#else + , hfbLHS = noLocA $ Ambiguous NoExtField nm +#endif + , hfbRHS = val + , hfbPun = False + } +#else + HsRecField + { hsRecFieldAnn = synDef + , hsRecFieldLbl = noLoc $ Ambiguous NoExtField nm + , hsRecFieldArg = val + , hsRecPun = False + } +#endif + +recordUpd_ :: HsExp -> [ LHsRecUpdField GhcPs +#if MIN_VERSION_ghc_lib_parser(9,8,0) + GhcPs +#endif + ] -> HsExp +recordUpd_ r fields = noLocA RecordUpd + { rupd_ext = synDef + , rupd_expr = r + , rupd_flds = +#if MIN_VERSION_ghc_lib_parser(9,8,0) + RegularRecUpdFields synDef +#else + Left +#endif + fields + } + +protobufType_, primType_, protobufStringType_, protobufBytesType_ :: String -> HsType +protobufType_ = typeNamed_ . protobufName tcName +primType_ = typeNamed_ . haskellName tcName +protobufStringType_ = tyApp (protobufType_ "String") . typeNamed_ . haskellName tcName +protobufBytesType_ = tyApp (protobufType_ "Bytes") . typeNamed_ . haskellName tcName + +protobufFixedType_, protobufSignedType_, protobufWrappedType_ :: HsType -> HsType +protobufFixedType_ = tyApp (protobufType_ "Fixed") +protobufSignedType_ = tyApp (protobufType_ "Signed") +protobufWrappedType_ = tyApp (protobufType_ "Wrapped") + +typeNamed_ :: HsName -> HsType +typeNamed_ nm@(L _ r) = noLocA $ GHC.HsTyVar synDef promotion nm + where + promotion + | rdrNameSpace r == dataName = IsPromoted + | otherwise = NotPromoted + +type_ :: String -> HsType +type_ = typeNamed_ . unqual_ tcName + +tvarn_ :: String -> HsName +tvarn_ = unqual_ tvName + +tvar_ :: String -> HsType +tvar_ = typeNamed_ . tvarn_ + +kindSig_ :: HsType -> HsType -> HsType +kindSig_ ty = noLocA . GHC.HsKindSig synDef ty + +tupleType_ :: [HsType] -> HsType +tupleType_ = noLocA . GHC.HsTupleTy synDef HsBoxedOrConstraintTuple + +patVar :: String -> HsPat +patVar = noLocA . VarPat NoExtField . unqual_ varName + +conPat :: HsQName -> [HsPat] -> HsPat +conPat (L _ ctor) = nlConPat ctor + +recPat :: HsQName -> [LHsRecField GhcPs HsPat] -> HsPat +recPat ctor fields = noLocA $ ConPat synDef ctor $ RecCon $ HsRecFields + { rec_flds = fields + , rec_dotdot = Nothing +#if MIN_VERSION_ghc_lib_parser(9,12,0) + , rec_ext = NoExtField +#endif + } + +fieldPunPat :: HsName -> LHsRecField GhcPs HsPat +fieldPunPat nm = noLocA +#if MIN_VERSION_ghc_lib_parser(9,4,0) + HsFieldBind + { hfbAnn = synDef + , hfbLHS = noLocA $ FieldOcc NoExtField nm + , hfbRHS = noLocA $ VarPat NoExtField nm + , hfbPun = True + } +#else + HsRecField + { hsRecFieldAnn = synDef + , hsRecFieldLbl = noLoc $ FieldOcc NoExtField nm + , hsRecFieldArg = noLocA $ VarPat NoExtField nm + , hsRecPun = True + } +#endif + +alt_ :: HsPat -> HsExp -> HsAlt +alt_ = mkHsCaseAlt + +case_ :: HsExp -> [HsAlt] -> HsExp +case_ e = noLocA . HsCase synDef e . mkMatchGroup generated . noLocA + where + generated :: Origin + generated = Generated +#if MIN_VERSION_ghc_lib_parser(9,10,0) + OtherExpansion +#endif +#if MIN_VERSION_ghc_lib_parser(9,8,0) + DoPmc +#endif + +-- | Simple let expression for ordinary bindings. +let_ :: [HsBind] -> HsExp -> HsExp +let_ locals e = +#if MIN_VERSION_ghc_lib_parser(9,10,0) + noLocA $ HsLet synDef binds e +#elif MIN_VERSION_ghc_lib_parser(9,4,0) + noLocA $ HsLet synDef synDef binds synDef e +#else + noLocA $ HsLet synDef binds e +#endif + where +#if MIN_VERSION_ghc_lib_parser(9,12,0) + binds = HsValBinds synDef (ValBinds synDef locals []) +#else + binds = HsValBinds synDef (ValBinds synDef (listToBag locals) []) +#endif + +-- | Lambda abstraction. +lambda_ :: [HsPat] -> HsExp -> HsExp +#if MIN_VERSION_ghc_lib_parser(9,12,0) +lambda_ = mkHsLam . noLocA +#else +lambda_ = mkHsLam +#endif + +if_ :: HsExp -> HsExp -> HsExp -> HsExp +if_ c t f = noLocA $ mkHsIf c t f synDef + +-- | A boxed tuple with all components present. +tuple_ :: [HsExp] -> HsExp +#if MIN_VERSION_ghc_lib_parser(9,12,0) +tuple_ xs = mkLHsTupleExpr xs noAnn +#else +tuple_ xs = mkLHsTupleExpr xs synDef +#endif + +-- | A promoted boxed tuple value with all components present. +tupleT_ :: [HsType] -> HsType +tupleT_ = noLocA . HsExplicitTupleTy synDef +#if MIN_VERSION_ghc_lib_parser(9,12,0) + NotPromoted +#endif + +list_ :: [HsExp] -> HsExp +list_ = nlList + +listT_ :: [HsType] -> HsType +listT_ = noLocA . HsExplicitListTy synDef IsPromoted + +str_ :: String -> HsExp +str_ = noLocA . HsLit synDef . mkHsString + +strPat :: String -> HsPat +strPat = noLocA . LitPat NoExtField . HsString NoSourceText . mkFastString + +symT :: String -> HsType +symT = noLocA . HsTyLit synDef . HsStrTy NoSourceText . mkFastString + +-------------------------------------------------------------------------------- +-- +-- * Common Haskell expressions, constructors, and operators +-- + +nothingN, justN :: HsQName + +dotProtoFieldC, primC, optionalC, repeatedC, nestedRepeatedC, namedC, mapC, + fieldNumberC, singleC, dotsC, pathC, qualifiedC, anonymousC, dotProtoOptionC, + identifierC, stringLitC, intLitC, floatLitC, boolLitC, trueC, falseC, nothingC, + justC, forceEmitC, encodeMessageFieldE, fromStringE, decodeMessageFieldE, + pureE, returnE, mappendE, memptyE, msumE, atE, oneofE, fmapE :: HsExp + +forceEmitT, justT, maybeT, nothingT, natT, symbolT, typeErrorT :: HsType + +dotProtoFieldC = var_ (protobufASTName tcName "DotProtoField") +primC = var_ (protobufASTName dataName "Prim") +optionalC = var_ (protobufASTName dataName "Optional") +repeatedC = var_ (protobufASTName dataName "Repeated") +nestedRepeatedC = var_ (protobufASTName dataName "NestedRepeated") +namedC = var_ (protobufASTName tcName "Named") +mapC = var_ (protobufASTName dataName "Map") +fieldNumberC = var_ (protobufName dataName "FieldNumber") +singleC = var_ (protobufASTName dataName "Single") +pathC = var_ (protobufASTName dataName "Path") +dotsC = var_ (protobufASTName dataName "Dots") +qualifiedC = var_ (protobufASTName dataName "Qualified") +anonymousC = var_ (protobufASTName dataName "Anonymous") +dotProtoOptionC = var_ (protobufASTName tcName "DotProtoOption") +identifierC = var_ (protobufASTName dataName "Identifier") +stringLitC = var_ (protobufASTName dataName "StringLit") +intLitC = var_ (protobufASTName dataName "IntLit") +floatLitC = var_ (protobufASTName dataName "FloatLit") +boolLitC = var_ (protobufASTName dataName "BoolLit") +forceEmitC = var_ (protobufName dataName "ForceEmit") +forceEmitT = protobufType_ "ForceEmit" +encodeMessageFieldE = var_ (protobufName varName "encodeMessageField") +decodeMessageFieldE = var_ (protobufName varName "decodeMessageField") +atE = var_ (protobufName varName "at") +oneofE = var_ (protobufName varName "oneof") + +trueC = var_ (haskellName dataName "True") +falseC = var_ (haskellName dataName "False") +nothingC = var_ nothingN +nothingN = haskellName dataName "Nothing" +nothingT = typeNamed_ (haskellName tcName "Nothing") +justC = var_ justN +justN = haskellName dataName "Just" +justT = typeNamed_ (haskellName tcName "Just") +maybeT = typeNamed_ (haskellName tcName "Maybe") +fromStringE = var_ (haskellName varName "fromString") +pureE = var_ (haskellName varName "pure") +returnE = var_ (haskellName varName "return") +mappendE = var_ (haskellName varName "mappend") +memptyE = var_ (haskellName varName "mempty") +msumE = var_ (haskellName varName "msum") +fmapE = var_ (haskellName varName "fmap") +natT = typeNamed_ (haskellName tcName "Nat") +symbolT = typeNamed_ (haskellName tcName "Symbol") +typeErrorT = typeNamed_ (haskellName tcName "TypeError") + +apOp :: HsQOp +apOp = uvar_ "<*>" + +fmapOp :: HsQOp +fmapOp = uvar_ "<$>" + +composeOp :: HsQOp +composeOp = var_ (haskellName varName ".") + +fractionOp :: HsQOp +fractionOp = var_ (haskellName varName "/") + +bindOp :: HsQOp +bindOp = var_ (haskellName varName ">>=") + +altOp :: HsQOp +altOp = uvar_ "<|>" + +toJSONPBOp :: HsQOp +toJSONPBOp = uvar_ ".=" + +parseJSONPBOp :: HsQOp +parseJSONPBOp = uvar_ ".:" + +neConsOp :: HsQOp +neConsOp = var_ (haskellName varName ":|") + +intE :: Integral a => a -> HsExp +intE x = noLocA $ HsOverLit synDef $ mkHsIntegral $ IL + { il_text = NoSourceText + , il_neg = x < 0 + , il_value = toInteger x + } + +intP :: Integral a => a -> HsPat +intP x = noLocA $ NPat synDef overlit Nothing NoExtField + where + overlit = L synDef $ mkHsIntegral $ IL + { il_text = NoSourceText + , il_neg = x < 0 + , il_value = toInteger x + } + +natTLit :: Integral a => a -> HsType +natTLit = noLocA . HsTyLit synDef . HsNumTy NoSourceText . toInteger + +floatE :: forall f . RealFloat f => f -> HsExp +floatE x + | isNaN x = opApp zero fractionOp zero + | isInfinite x = opApp (if x < 0 then minusOne else plusOne) fractionOp zero + | otherwise = scientific x + where + zero = scientific (0 :: f) + minusOne = scientific (-1 :: f) + plusOne = scientific (1 :: f) + scientific y = noLocA $ HsOverLit synDef overlit + where + (_s, _e) = decodeFloat (abs y) + overlit = mkHsFractional $ FL + { fl_text = NoSourceText + , fl_neg = y < 0 + , fl_signi = _s % 1 + , fl_exp = toInteger _e + , fl_exp_base = case floatRadix y of + 2 -> Base2 + 10 -> Base10 + b -> error $ "doubleE: unsupported floatRadix " ++ show b + } + +do_ :: [ExprLStmt GhcPs] -> HsExp +do_ = noLocA . mkHsDo (DoExpr Nothing) . noLocA + +letStmt_ :: [HsBind] -> ExprLStmt GhcPs +letStmt_ locals = noLocA $ LetStmt synDef binds + where +#if MIN_VERSION_ghc_lib_parser(9,12,0) + binds = HsValBinds synDef (ValBinds synDef locals []) +#else + binds = HsValBinds synDef (ValBinds synDef (listToBag locals) []) +#endif + +bindStmt_ :: HsPat -> HsExp -> ExprLStmt GhcPs +bindStmt_ p e = noLocA $ mkPsBindStmt synDef p e + +lastStmt_ :: HsExp -> ExprLStmt GhcPs +lastStmt_ = noLocA . mkLastStmt + +bodyStmt_ :: HsExp -> ExprLStmt GhcPs +bodyStmt_ = noLocA . mkBodyStmt diff --git a/src/Proto3/Suite/DotProto/Internal.hs b/src/Proto3/Suite/DotProto/Internal.hs --- a/src/Proto3/Suite/DotProto/Internal.hs +++ b/src/Proto3/Suite/DotProto/Internal.hs @@ -1,17 +1,18 @@ -- | This module provides misc internal helpers and utilities -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE ViewPatterns #-} module Proto3.Suite.DotProto.Internal where @@ -29,7 +30,7 @@ import Data.Foldable import Data.Functor.Compose import Data.Int (Int32) -import Data.List (intercalate) +import Data.List (intercalate, sort) import qualified Data.List.NonEmpty as NE import qualified Data.Map as M import Data.Maybe (fromMaybe) @@ -87,6 +88,159 @@ mapM_ Turtle.err msg Turtle.exit (ExitFailure 1) +-- | The proposition that some third value comes strictly after +-- the first argument but strictly before the second argument. +nonconsecutive :: (Enum a, Ord a) => a -> a -> Bool +nonconsecutive x y = x < y && succ x < y + -- The check that @x < y@ avoids the potential for arithmetic overflow in @succ x@. +{-# INLINABLE nonconsecutive #-} -- To allow specialization to particular type class instances. + +-- | This function yields 'Just' of the union of its arguments if that union +-- can be expressed as a single interval, and otherwise yields 'Nothing'. +joinIntervals :: (Enum a, Ord a) => (a, a) -> (a, a) -> Maybe (a, a) +joinIntervals (a, b) (c, d) + | b < a = Just (c, d) -- (a, b) is empty; we can just drop it + | d < c = Just (a, b) -- (c, d) is empty; we can just drop it + | a <= c = if + | nonconsecutive b c -> Nothing -- (a, b), then something strictly between, then (c, d) + | otherwise -> Just (a, max b d) -- no value lies strictly between b and c + | otherwise = if + | nonconsecutive d a -> Nothing -- (c, d), then something strictly between, then (a, b) + | otherwise -> Just (c, max b d) -- no value lies strictly between d and a +{-# INLINABLE joinIntervals #-} -- To allow specialization to particular type class instances. + +-- | Finds the unique shortest list of intervals having the same +-- set union as the given list and nondecreasing low endpoints. +-- +-- The result also satisfies the definition of /normal/ given below. +-- +-- Each interval is specified by pairing its low and high endpoints, +-- which are included in the interval, except when the first component +-- of the pair exceeds the second, in which case the interval is empty. +-- +-- = Supporting Theory +-- +-- == Definition of /normal/ +-- +-- Call a list of intervals /normal/ when it excludes empty intervals +-- and for any two consecutive intervals /[a .. b]/ and /[c .. d]/, +-- there exists an /x/ such that /b < x < c/. +-- +-- We claim that, among those interval lists having any given union, +-- normality is equivalent to having minimal length and nondecreasing +-- low endpoints. +-- +-- == Normal implies minimal length +-- +-- To see why, first consider any normal interval list /N/. Clearly its +-- low endpoints are nondecreasing--and in fact are strictly increasing +-- with gaps inbetween. Therefore any interval intersecting at least two +-- intervals of /N/ necessarily includes at least one point in such a gap, +-- and that point is outside the union of /N/. Hence every interval list +-- with the same union as /N/ consists of (possibly empty) subintervals of +-- intervals listed by /N/. Hence /N/ has minimal length among such lists. +-- +-- == Minimal length implies normal +-- +-- To establish the converse, consider any interval list /N/ having +-- nondecreasing endpoints and minimal length. Deleting empty intervals +-- from /N/ would only decrease its length, so /N/ must not include any. +-- Next note that if /[a .. b]/ and /[c .. d]/ are consecutive intervals +-- within /N/, then either there exists an /x/ such that /b < x < c/, or +-- else we may shorten /N/ without changing its union by replacing both +-- /[a .. b]/ and /[c .. d]/ by the single interval /[a .. max b d]/, +-- which would contradict the minimality of the length of /N/. Thus +-- /N/ fulfills all the requirements of being a normal interval list. +-- +-- == Existence +-- +-- Having proved the desired equivalence, we turn to the question of +-- the existence of the shortest interval list having the same union +-- as any given interval list and nondecreasing low endpoints. +-- +-- Consider the set /S/ of interval lists having the same union as +-- the given interval list and nondecreasing low endpoints. Note +-- that by performing a stable sort on the given interval list we +-- immediately find that /S/ is nonempty. Being nonempty, it must +-- contain at least one element of minimal length. +-- +-- == Uniqueness +-- +-- But could there be two different interval lists of minimal length +-- for their common union, both with nondecreasing low endpoints? +-- +-- We claim the answer is no, and proceed by induction on that shared +-- minimal length. The base case is trivial: if both lists are empty, +-- then they cannot differ. +-- +-- For the induction step, suppose that there are two interval lists +-- that share the same positive minimal length among those that +-- have nondecreasing low endpoints and a given same union. +-- Call them /L/ and /N/. We will prove that /L = N/. +-- +-- Let /(a, b) = head L/ and /(e, f) = head N/. +-- +-- If /a < e/ then /a/ is in /union L/ but not in /union N/, +-- contradicting our assumpion that /union L = union N/. Likewise +-- we may exclude /e < a/, leaving /a = e/ and /(a, f) = head N/. +-- +-- Next suppose that /b < f/. If /tail L == []/ then clearly /f/ +-- is outside of /union L/ and yet inside of /union N/, which is +-- once again beyond our scenario. Let /(c, d) = head (tail L)/. +-- By the equivalence we established earlier, /L/ is normal and +-- hence there exists an /x/ such that /b < x < c/. If /x <= f/, +-- then /x/ is in /[a .. f]/ and yet outside of /union L/, once +-- again contradicting our hypotheses. Otherwise /f < x < c/, and +-- hence /f/ is outside of /union L/, a similar contradiction. +-- Therefore our supposition that /b < f/ must be impossible, +-- and we can likewise exclude /f < b/. Hence /b = f/. +-- +-- Having establishing both /a = e/ and /b = f/, we conclude that +-- /head L = head N/. It follows that /tail L/ and /tail N/ have +-- the same union as each other. Both tails must be minimal in +-- length, because otherwise there would also be a way to shorten +-- /L/ or /N/ in a union-preserving way. Invoking our induction +-- hypothesis we find that /tail L = tail N/; therefore /L = N/. +-- +-- = Conclusions +-- +-- In conclusion, the desired behavior of this function is well defined +-- by the first paragraph in this comment block, and the second paragraph +-- (once combined with a requirement to preserve the union) provides +-- an equivalent definition. +-- +-- To check that the implementation actually fulfills these requirements, +-- note that it filters out empty intervals, sorts those that remain, +-- and then merges intervals until the resulting list becomes normal. +-- +-- There are also unit tests checking that the result is +-- normal and has the same union as the given list. +normalizeIntervals :: (Enum a, Ord a) => [(a, a)] -> [(a, a)] +normalizeIntervals = mergeIntervals . filter \(x, y) -> x <= y +{-# INLINABLE normalizeIntervals #-} -- To allow specialization to particular type class instances. + +-- | Returns a sorted list that contains all intervals from the minimal set of +-- intervals to represent the given list of intervals. +-- +-- "Merges" overlapping intervals in a list of intervals. Think disjunctive +-- normal form. +mergeIntervals :: forall a . (Enum a, Ord a) => [(a, a)] -> [(a, a)] +mergeIntervals = foldr step [] . sort + where + step :: (a, a) -> [(a, a)] -> [(a, a)] + step x [] = [x] + step x (y : ys) = case joinIntervals x y of + Nothing -> x : y : ys + -- In this case @x@ and @y@ could not be merged, and therefore there is + -- some value strictly inbetween the end of @x@ and the start of @y@. + -- Compare this property to the definition of /normal/ (above). + Just xy -> step xy ys + -- Recursion is necessary here because @x@ may end later than did @y@, + -- possibly making @xy@ mergable with some prefix of @ys@, unlike @y@. + -- By merging @x@ and @y@ into @xy@ we have shortened the overall + -- length of the list, and therefore this recursion must terminate. +{-# INLINABLE mergeIntervals #-} -- To allow specialization to particular type class instances. + -------------------------------------------------------------------------------- -- -- * Reading files @@ -568,13 +722,13 @@ -- | Bookeeping for qualified fields data QualifiedField = QualifiedField - { recordFieldName :: FieldName - , fieldInfo :: FieldInfo + { recordFieldName :: FieldName + , fieldInfo :: FieldInfo } deriving Show -- | Bookkeeping for fields data FieldInfo - = FieldOneOf OneofField + = FieldOneOf FieldName OneofField | FieldNormal FieldName FieldNumber DotProtoType [DotProtoOption] deriving Show @@ -586,11 +740,11 @@ -- | Bookkeeping for oneof subfields data OneofSubfield = OneofSubfield - { subfieldNumber :: FieldNumber - , subfieldConsName :: String - , subfieldName :: FieldName - , subfieldType :: DotProtoType - , subfieldOptions :: [DotProtoOption] + { subfieldNumber :: FieldNumber + , subfieldConsName :: String + , subfieldName :: FieldName + , subfieldType :: DotProtoType + , subfieldOptions :: [DotProtoOption] } deriving Show getQualifiedFields :: MonadError CompileError m @@ -617,14 +771,21 @@ let mkSubfield DotProtoField{..} = do s <- dpIdentUnqualName dotProtoFieldName c <- prefixedConName oneofTypeName s - pure [OneofSubfield dotProtoFieldNumber c (coerce s) dotProtoFieldType dotProtoFieldOptions] - mkSubfield DotProtoEmptyField = pure [] + pure [ OneofSubfield + { subfieldNumber = dotProtoFieldNumber + , subfieldConsName = c + , subfieldName = coerce s + , subfieldType = dotProtoFieldType + , subfieldOptions = dotProtoFieldOptions + } + ] fieldElems <- foldMapM mkSubfield fields - pure . (:[]) $ QualifiedField { recordFieldName = coerce oneofName - , fieldInfo = FieldOneOf (OneofField ident fieldElems) - } + pure . (:[]) $ QualifiedField + { recordFieldName = coerce oneofName + , fieldInfo = FieldOneOf (coerce ident) (OneofField ident fieldElems) + } _ -> pure [] -- | Project qualified fields, given a projection function per field type. @@ -633,7 +794,7 @@ -> QualifiedField -> a foldQF f _ (QualifiedField _ (FieldNormal fldName fldNum _ _)) = f fldName fldNum -foldQF _ g (QualifiedField _ (FieldOneOf fld)) = g fld +foldQF _ g (QualifiedField _ (FieldOneOf _ fld)) = g fld fieldBinder :: FieldNumber -> String fieldBinder = ("f" ++) . show @@ -663,6 +824,12 @@ | NonzeroFirstEnumeration String DotProtoIdentifier Int32 | EmptyEnumeration String | Unimplemented String + | RedefinedFields (Histogram FieldName) (Histogram FieldNumber) + -- ^ At least one field/oneof name and or field number was + -- used more than once within the same message definition, + -- which violates the protobuf specification. The histograms + -- mention only the repeated names and numbers, not the ones + -- used only once. deriving (Show, Eq) @@ -680,3 +847,21 @@ noSuchTypeError :: MonadError CompileError m => DotProtoIdentifier -> m a noSuchTypeError = throwError . NoSuchType + + +newtype Histogram a = Histogram (M.Map a Int) + deriving stock (Eq, Ord, Show) + +instance Ord a => Semigroup (Histogram a) + where + Histogram x <> Histogram y = Histogram (M.unionWith (+) x y) + +instance Ord a => Monoid (Histogram a) + where + mempty = Histogram M.empty + +oneOccurrence :: a -> Histogram a +oneOccurrence k = Histogram (M.singleton k 1) + +mulipleOccurrencesOnly :: Histogram a -> Histogram a +mulipleOccurrencesOnly (Histogram m) = Histogram (M.filter (1 <) m) diff --git a/src/Proto3/Suite/DotProto/Parsing.hs b/src/Proto3/Suite/DotProto/Parsing.hs --- a/src/Proto3/Suite/DotProto/Parsing.hs +++ b/src/Proto3/Suite/DotProto/Parsing.hs @@ -1,6 +1,7 @@ -- | This module contains a near-direct translation of the proto3 grammar -- It uses String for easier compatibility with DotProto.Generator, which needs it for not very good reasons +{-# LANGUAGE BlockArguments #-} {-# LANGUAGE CPP #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-} @@ -26,6 +27,9 @@ -- * Extension Parsers , pExtendStmt , pExtendKw + + -- * Empty Statement + , pEmptyStmt ) where import Prelude hiding (fail) @@ -38,6 +42,7 @@ import Control.Monad.Fail #endif import qualified Data.Char as Char +import Data.Maybe (catMaybes) import Data.List.NonEmpty (NonEmpty ((:|))) import qualified Data.List.NonEmpty as NE import Data.Functor @@ -273,8 +278,8 @@ -- top-level statements topStatement :: ProtoParser DotProtoStatement -topStatement = - choice +topStatement = + choice [ DPSImport <$> import_ , DPSPackage <$> package , DPSOption <$> pOptionStmt @@ -299,17 +304,17 @@ return $ DotProtoPackageSpec p definition :: ProtoParser DotProtoDefinition -definition = - choice +definition = + choice [ try message - , try enum + , try pEnumDefn , service ] -------------------------------------------------------------------------------- -- options --- | Parses a protobuf option that could appear in a service, RPC, message, +-- | Parses a protobuf option that could appear in a service, RPC, message, -- enumeration, or at the top-level. -- -- @since 0.5.2 @@ -321,7 +326,7 @@ -- @since 0.5.2 pFieldOptions :: ProtoParser [DotProtoOption] pFieldOptions = pOptions <|> pure [] - where + where pOptions :: ProtoParser [DotProtoOption] pOptions = between lbracket rbracket (commaSep1 (token pFieldOptionStmt)) @@ -335,8 +340,8 @@ -- -- @since 0.5.2 pFieldOptionStmt :: ProtoParser DotProtoOption -pFieldOptionStmt = token $ do - idt <- pOptionId +pFieldOptionStmt = token $ do + idt <- pOptionId token (char '=') val <- value pure (DotProtoOption idt val) @@ -345,23 +350,23 @@ -- -- @since 0.5.2 pOptionId :: ProtoParser DotProtoIdentifier -pOptionId = - choice +pOptionId = + choice [ try pOptionQName , try (parens pOptionName) , pOptionName ] - where + where pOptionName :: ProtoParser DotProtoIdentifier pOptionName = token $ do nm <- identifierName nms <- many (char '.' *> identifierName) - if null nms + if null nms then pure (Single nm) else pure (Dots (Path (nm :| nms))) pOptionQName :: ProtoParser DotProtoIdentifier - pOptionQName = token $ do + pOptionQName = token $ do idt <- parens pOptionName nms <- char '.' *> pOptionName pure (Qualified idt nms) @@ -378,10 +383,11 @@ -------------------------------------------------------------------------------- -- service statements -servicePart :: ProtoParser DotProtoServicePart -servicePart = DotProtoServiceRPCMethod <$> rpc - <|> DotProtoServiceOption <$> pOptionStmt - <|> DotProtoServiceEmpty <$ empty +servicePart :: ProtoParser (Maybe DotProtoServicePart) +servicePart = + try (fmap (Just . DotProtoServiceRPCMethod) rpc) + <|> try (fmap (Just . DotProtoServiceOption) pOptionStmt) + <|> Nothing <$ pEmptyStmt rpcOptions :: ProtoParser [DotProtoOption] rpcOptions = braces $ many pOptionStmt @@ -402,53 +408,70 @@ return RPCMethod{..} service :: ProtoParser DotProtoDefinition -service = do symbol "service" - name <- singleIdentifier - statements <- braces (many servicePart) - return $ DotProtoService mempty name statements +service = do + symbol "service" + name <- singleIdentifier + statements <- braces do + results <- many servicePart + pure (catMaybes results) + return $ DotProtoService mempty name statements -------------------------------------------------------------------------------- -- message definitions message :: ProtoParser DotProtoDefinition -message = do symbol "message" - name <- singleIdentifier - body <- braces (many messagePart) - return $ DotProtoMessage mempty name body +message = do + symbol "message" + name <- singleIdentifier + body <- braces do + results <- many messagePart + pure (catMaybes results) + pure (DotProtoMessage mempty name body) messageOneOf :: ProtoParser DotProtoMessagePart messageOneOf = do symbol "oneof" name <- singleIdentifier - body <- braces $ many (messageField <|> empty $> DotProtoEmptyField) + body <- braces (many oneofField) return $ DotProtoMessageOneOf name body -messagePart :: ProtoParser DotProtoMessagePart -messagePart = try (DotProtoMessageDefinition <$> enum) - <|> try (DotProtoMessageReserved <$> reservedField) - <|> try (DotProtoMessageDefinition <$> message) - <|> try messageOneOf - <|> try (DotProtoMessageField <$> messageField) - <|> try (DotProtoMessageOption <$> pOptionStmt) +messagePart :: ProtoParser (Maybe DotProtoMessagePart) +messagePart = + try (Just . DotProtoMessageDefinition <$> pEnumDefn) + <|> try (Just . DotProtoMessageReserved <$> pReserved) + <|> try (Just . DotProtoMessageDefinition <$> message) + <|> try (fmap Just messageOneOf) + <|> try (Just . DotProtoMessageField <$> messageField) + <|> try (Just . DotProtoMessageOption <$> pOptionStmt) + <|> (Nothing <$ pEmptyStmt) messageType :: ProtoParser DotProtoType -messageType = try mapType <|> try repType <|> (Prim <$> primType) +messageType = try mapType <|> try optType <|> try repType <|> (Prim <$> primType) where mapType = do symbol "map" angles $ Map <$> (primType <* comma) <*> primType + optType = do symbol "optional" + Optional <$> primType + repType = do symbol "repeated" Repeated <$> primType messageField :: ProtoParser DotProtoField -messageField = do mtype <- messageType - mname <- identifier - symbol "=" - mnumber <- fieldNumber - moptions <- pFieldOptions - semi - return $ DotProtoField mnumber mtype mname moptions mempty +messageField = messageFieldFor messageType +oneofField :: ProtoParser DotProtoField +oneofField = messageFieldFor (Prim <$> primType) + +messageFieldFor :: ProtoParser DotProtoType -> ProtoParser DotProtoField +messageFieldFor parseType = do mtype <- parseType + mname <- identifier + symbol "=" + mnumber <- fieldNumber + moptions <- pFieldOptions + semi + return $ DotProtoField mnumber mtype mname moptions mempty + -------------------------------------------------------------------------------- -- enumerations @@ -461,16 +484,21 @@ return $ DotProtoEnumField fname fpos opts -enumStatement :: ProtoParser DotProtoEnumPart -enumStatement = try (DotProtoEnumOption <$> pOptionStmt) - <|> enumField - <|> empty $> DotProtoEnumEmpty +enumStatement :: ProtoParser (Maybe DotProtoEnumPart) +enumStatement = + try (fmap (Just . DotProtoEnumReserved) pReserved) + <|> try (fmap (Just . DotProtoEnumOption) pOptionStmt) + <|> try (fmap Just enumField) + <|> (Nothing <$ pEmptyStmt) -enum :: ProtoParser DotProtoDefinition -enum = do symbol "enum" - ename <- singleIdentifier - ebody <- braces (many enumStatement) - return $ DotProtoEnum mempty ename ebody +pEnumDefn :: ProtoParser DotProtoDefinition +pEnumDefn = do + symbol "enum" + ename <- singleIdentifier + ebody <- braces do + results <- many enumStatement + pure (catMaybes results) + pure (DotProtoEnum mempty ename ebody) -------------------------------------------------------------------------------- -- field reservations @@ -485,11 +513,12 @@ ranges :: ProtoParser [DotProtoReservedField] ranges = commaSep1 (try range <|> (SingleField . fromInteger <$> integer)) -reservedField :: ProtoParser [DotProtoReservedField] -reservedField = do symbol "reserved" - v <- ranges <|> commaSep1 (ReservedIdentifier <$> strFieldName) - semi - return v +pReserved :: ProtoParser [DotProtoReservedField] +pReserved = do + symbol "reserved" + v <- ranges <|> commaSep1 (ReservedIdentifier <$> strFieldName) + semi + return v strFieldName :: ProtoParser String strFieldName = @@ -499,10 +528,12 @@ -- Message Extensions ---------------------------------------------------------- pExtendStmt :: ProtoParser (DotProtoIdentifier, [DotProtoMessagePart]) -pExtendStmt = do +pExtendStmt = do pExtendKw idt <- identifier - fxs <- braces (many messagePart) + fxs <- braces do + results <- many messagePart + pure (catMaybes results) pure (idt, fxs) -- | Parses a single keyword token "extend". @@ -510,6 +541,14 @@ -- @since 0.5.2 pExtendKw :: ProtoParser () pExtendKw = do - spaces - token (string "extend" >> notFollowedBy alphaNum) + spaces + token (string "extend" >> notFollowedBy alphaNum) "keyword 'extend'" + +-- Parse - Empty Statements ---------------------------------------------------- + +-- | Parses a single empty statement (i.e. a semicolon). +-- +-- See: https://protobuf.dev/reference/protobuf/proto3-spec/#emptystatement +pEmptyStmt :: ProtoParser () +pEmptyStmt = token (() <$ char ';') "empty statement" diff --git a/src/Proto3/Suite/DotProto/Rendering.hs b/src/Proto3/Suite/DotProto/Rendering.hs --- a/src/Proto3/Suite/DotProto/Rendering.hs +++ b/src/Proto3/Suite/DotProto/Rendering.hs @@ -1,11 +1,9 @@ -- | This module provides types and functions to generate .proto files. -{-# LANGUAGE CPP #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedLists #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} module Proto3.Suite.DotProto.Rendering ( renderDotProto @@ -19,17 +17,11 @@ , Pretty(..) ) where -import Data.Char -import qualified Data.List.NonEmpty as NE -#if (MIN_VERSION_base(4,11,0)) -import Prelude hiding ((<>)) -#endif import Proto3.Suite.DotProto.AST import Proto3.Wire.Types (FieldNumber (..)) -import Text.PrettyPrint (($$), (<+>), (<>)) +import Text.PrettyPrint (($$), (<+>)) import qualified Text.PrettyPrint as PP import Text.PrettyPrint.HughesPJClass (Pretty(..)) -import Turtle.Compat (encodeString) -- | Options for rendering a @.proto@ file. data RenderingOptions = RenderingOptions @@ -67,30 +59,6 @@ $$ (PP.vcat $ topOption <$> protoOptions) $$ (PP.vcat $ prettyPrintProtoDefinition opts <$> protoDefinitions) -strLit :: String -> PP.Doc -strLit string = PP.text "\"" <> foldMap escape string <> PP.text "\"" - where - escape '\n' = PP.text "\\n" - escape '\\' = PP.text "\\\\" - escape '\0' = PP.text "\\x00" - escape '"' = PP.text "\\\"" - escape c = PP.text [ c ] - -instance Pretty DotProtoPackageSpec where - pPrint (DotProtoPackageSpec p) = PP.text "package" <+> pPrint p <> PP.text ";" - pPrint (DotProtoNoPackage) = PP.empty - -instance Pretty DotProtoImport where - pPrint (DotProtoImport q i) = - PP.text "import" <+> pPrint q <+> strLit fp <> PP.text ";" - where - fp = encodeString i - -instance Pretty DotProtoImportQualifier where - pPrint DotProtoImportDefault = PP.empty - pPrint DotProtoImportPublic = PP.text "public" - pPrint DotProtoImportWeak = PP.text "weak" - optionAnnotation :: [DotProtoOption] -> PP.Doc optionAnnotation [] = PP.empty optionAnnotation os = PP.brackets @@ -99,10 +67,7 @@ $ pPrint <$> os topOption :: DotProtoOption -> PP.Doc -topOption o = PP.text "option" <+> pPrint o <> PP.text ";" - -instance Pretty DotProtoOption where - pPrint (DotProtoOption key value) = pPrint key <+> PP.text "=" <+> pPrint value +topOption o = PP.text "option" <+> pPrint o PP.<> PP.text ";" renderComment :: String -> PP.Doc renderComment = PP.vcat . map ((PP.text "//" <+>) . textIfNonempty) . lines @@ -133,21 +98,20 @@ msgPart _ (DotProtoMessageReserved reservations) = PP.text "reserved" <+> (PP.hcat . PP.punctuate (PP.text ", ") $ pPrint <$> reservations) - <> PP.text ";" + PP.<> PP.text ";" msgPart msgName (DotProtoMessageOneOf name fields) = vbraces (PP.text "oneof" <+> pPrint name) (PP.vcat $ field msgName <$> fields) msgPart _ (DotProtoMessageOption opt) - = PP.text "option" <+> pPrint opt <> PP.text ";" + = PP.text "option" <+> pPrint opt PP.<> PP.text ";" field :: DotProtoIdentifier -> DotProtoField -> PP.Doc field msgName (DotProtoField number mtype name options comments) = pPrint mtype <+> roSelectorName opts msgName name number <+> PP.text "=" - <+> pPrint number + <+> pPrintFieldNumber number <+> optionAnnotation options - <> PP.text ";" + PP.<> PP.text ";" $$ PP.nest 2 (renderComment comments) - field _ DotProtoEmptyField = PP.empty enumPart :: DotProtoIdentifier -> DotProtoEnumPart -> PP.Doc enumPart msgName (DotProtoEnumField name value options) @@ -155,73 +119,14 @@ <+> PP.text "=" <+> pPrint (fromIntegral value :: Int) <+> optionAnnotation options - <> PP.text ";" + PP.<> PP.text ";" + enumPart _ (DotProtoEnumReserved reservedFields) + = PP.text "reserved" <+> (PP.hcat . PP.punctuate (PP.text ", ") $ pPrint <$> reservedFields) enumPart _ (DotProtoEnumOption opt) - = PP.text "option" <+> pPrint opt <> PP.text ";" - enumPart _ DotProtoEnumEmpty - = PP.empty - -instance Pretty DotProtoServicePart where - pPrint (DotProtoServiceRPCMethod RPCMethod{..}) - = PP.text "rpc" - <+> pPrint rpcMethodName - <+> PP.parens (pPrint rpcMethodRequestStreaming <+> pPrint rpcMethodRequestType) - <+> PP.text "returns" - <+> PP.parens (pPrint rpcMethodResponseStreaming <+> pPrint rpcMethodResponseType) - <+> case rpcMethodOptions of - [] -> PP.text ";" - _ -> PP.braces . PP.vcat $ topOption <$> rpcMethodOptions - pPrint (DotProtoServiceOption option) = topOption option - pPrint DotProtoServiceEmpty = PP.empty - -instance Pretty Streaming where - pPrint Streaming = PP.text "stream" - pPrint NonStreaming = PP.empty - -instance Pretty DotProtoIdentifier where - pPrint (Single name) = PP.text name - pPrint (Dots (Path names)) = PP.hcat . PP.punctuate (PP.text ".") $ PP.text <$> NE.toList names - pPrint (Qualified qualifier identifier) = PP.parens (pPrint qualifier) <> PP.text "." <> pPrint identifier - pPrint Anonymous = PP.empty - -instance Pretty DotProtoValue where - pPrint (Identifier value) = pPrint value - pPrint (StringLit value) = strLit value - pPrint (IntLit value) = PP.text $ show value - pPrint (FloatLit value) = PP.text $ show value - pPrint (BoolLit value) = PP.text $ toLower <$> show value - -instance Pretty DotProtoType where - pPrint (Prim ty) = pPrint ty - pPrint (Repeated ty) = PP.text "repeated" <+> pPrint ty - pPrint (NestedRepeated ty) = PP.text "repeated" <+> pPrint ty - pPrint (Map keyty valuety) = PP.text "map<" <> pPrint keyty <> PP.text ", " <> pPrint valuety <> PP.text ">" - -instance Pretty DotProtoPrimType where - pPrint (Named i) = pPrint i - pPrint Int32 = PP.text "int32" - pPrint Int64 = PP.text "int64" - pPrint SInt32 = PP.text "sint32" - pPrint SInt64 = PP.text "sint64" - pPrint UInt32 = PP.text "uint32" - pPrint UInt64 = PP.text "uint64" - pPrint Fixed32 = PP.text "fixed32" - pPrint Fixed64 = PP.text "fixed64" - pPrint SFixed32 = PP.text "sfixed32" - pPrint SFixed64 = PP.text "sfixed64" - pPrint String = PP.text "string" - pPrint Bytes = PP.text "bytes" - pPrint Bool = PP.text "bool" - pPrint Float = PP.text "float" - pPrint Double = PP.text "double" - -instance Pretty FieldNumber where - pPrint = PP.text . show . getFieldNumber + = PP.text "option" <+> pPrint opt PP.<> PP.text ";" -instance Pretty DotProtoReservedField where - pPrint (SingleField num) = PP.text $ show num - pPrint (FieldRange start end) = (PP.text $ show start) <+> PP.text "to" <+> (PP.text $ show end) - pPrint (ReservedIdentifier i) = PP.text $ show i +pPrintFieldNumber :: FieldNumber -> PP.Doc +pPrintFieldNumber = PP.text . show . getFieldNumber -- | Render protobufs metadata as a .proto file stringy toProtoFile :: RenderingOptions -> DotProto -> String diff --git a/src/Proto3/Suite/Form.hs b/src/Proto3/Suite/Form.hs new file mode 100644 --- /dev/null +++ b/src/Proto3/Suite/Form.hs @@ -0,0 +1,403 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | Type-Level Format Information +-- +-- Use @compile-proto-file --typeLevelFormat ...@ to instantiate these type families to +-- provide type-level information that may be used to define custom encoders and decoders. +-- +-- /WARNING/: This module is experimental and breaking changes may occur much more +-- frequently than in the other modules of this package, perhaps even in patch releases. +module Proto3.Suite.Form + ( NamesOf + , NumberOf + , ProtoTypeOf + , OneOfOf + , CardinalityOf + , FieldNotFound + , FieldOrOneOfNotFound + , Packing(..) + , Cardinality(..) + , ProtoType(..) + , Association + , CardinalityOfMapped + , Wrapper + , RecoverCardinality + , RecoverProtoType + , MessageFieldType + , OptionalMessageFieldType + , RepeatedMessageFieldType + ) where + +import Data.Int (Int32, Int64) +import Data.Kind (Type) +import Data.Map qualified as M +import Data.Word (Word32, Word64) +import GHC.Exts (Constraint) +import GHC.TypeLits (ErrorMessage(..), Nat, Symbol, TypeError) +import Prelude hiding (String) +import Proto3.Suite.Types (Bytes, Enumerated, Commented, Fixed, ForceEmit, Nested, + NestedVec, PackedVec, Signed, String, UnpackedVec) + +-- | Returns the names of the fields within a given type of message. +-- +-- The names appear in increasing order of field number, in case that helps +-- type-level search algorithms, though at present it is likely that there +-- is no benefit other than ensuring that declaration order is irrelevant. +-- +-- Note that the names of fields and oneofs must be unique within their shared namespace +-- (see ). +type family NamesOf (message :: Type) :: [Symbol] + +-- | In the context of a message type, maps its field names to their numbers. +type family NumberOf (message :: Type) (name :: Symbol) :: Nat + +-- | In the context of a message type, maps the name of every field to its protobuf type. +type family ProtoTypeOf (message :: Type) (name :: Symbol) :: ProtoType + +-- | In the context of a message type, maps the name of every field to the name +-- of its containing @oneof@, or to @""@ if that field is not part of a oneof. +-- Also maps the name of every @oneof@ in the message to itself. +type family OneOfOf (message :: Type) (name :: Symbol) :: Symbol + +-- | In the context of a message type, maps the name +-- of every field and @oneof@ to its 'Cardinality'. +-- +-- (Every @oneof@ in the message is mapped to 'OneOf', +-- as are those fields that are within @oneof@s.) +type family CardinalityOf (message :: Type) (name :: Symbol) :: Cardinality + +-- | A compilation error message for when the given message +-- does not contain a field with the given name. +type FieldNotFound (message :: Type) (name :: Symbol) = + 'Text "Field " ':<>: 'ShowType name ':<>: + 'Text " not found in message:" ':$$: 'ShowType message + +-- | A compilation error message for when the given message +-- does not contain a field or oneof with the given name. +type FieldOrOneOfNotFound (message :: Type) (name :: Symbol) = + 'Text "Field or oneof " ':<>: 'ShowType name ':<>: + 'Text " not found in message:" ':$$: 'ShowType message + +-- | The packing of field that is @repeated@ or is a @map@. Every +-- encoding appends and element, and omission means zero elements. +data Packing + = Unpacked + -- ^ Packing is not preferred or not supported (for example, submessages and maps). + | Packed + -- ^ Packing is supported and preferred (perhaps implicitly). + +-- | Expresses how many values we expect a field to contain, what it means when its +-- encoding is omitted, and if it is @repeated@, whether or not packing is preferred. +-- +-- Each data constructor is chosen in such a way that it implies how many +-- values are expected as arguments to `Proto3.Suite.Form.Encode.field`. +-- This choice simplifies instantiation of type classes. +data Cardinality + = Implicit + -- ^ We expect exactly one value for this field, + -- though the default value is expressed by omission + -- in the binary format. Such a field is never "unset". + -- + -- In the terminology of the proto3 specification, the field is + -- "singular" and is neither @optional@ nor part of a @oneof@. + -- + -- Put another way: the field is not declared @optional@ or + -- @repeated@, it is not a @map@, it does not have a message type, + -- and it is not part of a @oneof@. + -- + -- `Proto3.Suite.Form.Encode.field` will expect exactly one field + -- value as its argument. Typically the argument type is not + -- a container type. But there may be application-specific reasons + -- for supplying a container type, such as the field type being + -- a message that has container semantics implemented by an + -- application-specific instance of `Proto3.Suite.Form.Encode.FieldForm`. + | Optional + -- ^ The field is singular and has optional field presence. That is, + -- That is, it is a non-@repeated@ submessage field (which is optional + -- even when not explicitly declared @optional@), or an @optional@ + -- scalar/enumerated field whose omission implies an "unset" value + -- distinct from the default value, or any field within a @oneof@. + -- + -- `Proto3.Suite.Form.Encode.field` will expect zero or one field + -- values as its argument. Typically the type involves 'Maybe', + -- but when the 'Nothing' case can be excluded, feel free to + -- use `Data.Functor.Identity.Identity` to illustrate that fact. + | Repeated Packing + -- ^ The field is @repeated@ or is a @map@, with the indicated + -- packing preference (which for @map is always 'Unpacked'). + -- + -- `Proto3.Suite.Form.Encode.field` will expect zero or more + -- field values, typically expressed by a container type having + -- an instance of `Proto3.Wire.Encode.Repeated.ToRepeated`. + +-- | The type of a message field, but when the field is repeated, this is the element type. +-- +-- Design Note: We do not use the same Haskell types recognized +-- by `Proto3.Suite.Class.MessageField` because there more than +-- one such type corresponds to protobuf type @string@. +-- But see 'RecoverProtoType'. +data ProtoType + = Int32 + | Int64 + | SInt32 + | SInt64 + | UInt32 + | UInt64 + | Fixed32 + | Fixed64 + | SFixed32 + | SFixed64 + | String + | Bytes + | Bool + | Float + | Double + | Enumeration Type + -- ^ The field is the type created by code generation from the protobuf enum. + | Message Type + -- ^ The field is the type created by code generation from the protobuf message. + | Map ProtoType ProtoType + -- ^ A map with the given key and value types. + +-- | The type of the repeated key-value pair submessage implied by a map field. +-- +-- We never need to construct values; instead we construct values of types +-- such as @`Proto3.Suite.Form.Encode.Encoding` ('Association' key value)@. +-- +-- The key field is named @"key"@ and the value field is named @"value"@. +data Association (key :: ProtoType) (value :: ProtoType) + +type instance NamesOf (Association _ _) = '[ "key", "value" ] + +type instance NumberOf (Association _ _) "key" = 1 +type instance NumberOf (Association _ _) "value" = 2 + +type instance ProtoTypeOf (Association key _) "key" = key +type instance ProtoTypeOf (Association _ value) "value" = value + +type instance OneOfOf (Association _ _) "key" = "" +type instance OneOfOf (Association _ _) "value" = "" + +type instance CardinalityOf (Association _ _) "key" = 'Implicit +type instance CardinalityOf (Association _ value) "value" = CardinalityOfMapped value + +-- | Yields the field presence of a mapped value of the given protobuf type. +type family CardinalityOfMapped (protoType :: ProtoType) :: Cardinality + where + CardinalityOfMapped ('Message _) = 'Optional + CardinalityOfMapped ('Map k v) = TypeError + ( 'Text "Nested maps are disallowed, so this cannot be a mapped type:" + ':$$: 'ShowType ('Map k v) ) + CardinalityOfMapped _ = 'Implicit + +-- | Indicates the standard protobuf wrapper having +-- the field type given by the type argument. +-- +-- We never need to construct values; instead we construct values of types +-- such as @`Proto3.Suite.Form.Encode.Encoding` ('Wrapper' protoType)@ or +-- @`Proto.Suite.Form.Encode.Wrap` a@, where @a@ is a corresponding native representation. +-- +-- Note that if Google ever adds wrappers for "sint..." or "...fixed..." +-- then this type constructor will naturally support such wrappers. +data Wrapper (protoType :: ProtoType) + +type instance NamesOf (Wrapper protoType) = '[ "value" ] + +type instance NumberOf (Wrapper protoType) "value" = 1 + +type instance ProtoTypeOf (Wrapper protoType) "value" = protoType + +type instance OneOfOf (Wrapper protoType) "value" = "" + +type instance CardinalityOf (Wrapper protoType) "value" = 'Implicit + +-- | Given the Haskell type used by features such as `Proto3.Suite.Class.MessageField` +-- to indicate the encoding of a message field. +type family RecoverCardinality (haskellType :: Type) :: Cardinality + where + RecoverCardinality (Commented _ haskellType) = RecoverCardinality haskellType + RecoverCardinality (Maybe (ForceEmit _)) = 'Optional + RecoverCardinality (PackedVec _) = 'Repeated 'Packed + RecoverCardinality (UnpackedVec _) = 'Repeated 'Unpacked + RecoverCardinality (NestedVec _) = 'Repeated 'Unpacked + RecoverCardinality (Nested _) = 'Optional + RecoverCardinality (Enumerated _) = 'Implicit + RecoverCardinality (M.Map _ _) = 'Repeated 'Unpacked + RecoverCardinality Int32 = 'Implicit + RecoverCardinality Int64 = 'Implicit + RecoverCardinality (Signed Int32) = 'Implicit + RecoverCardinality (Signed Int64) = 'Implicit + RecoverCardinality Word32 = 'Implicit + RecoverCardinality Word64 = 'Implicit + RecoverCardinality (Fixed Word32) = 'Implicit + RecoverCardinality (Fixed Word64) = 'Implicit + RecoverCardinality (Signed (Fixed Int32)) = 'Implicit + RecoverCardinality (Signed (Fixed Int64)) = 'Implicit + RecoverCardinality (String _) = 'Implicit + RecoverCardinality (Bytes _) = 'Implicit + RecoverCardinality Bool = 'Implicit + RecoverCardinality Float = 'Implicit + RecoverCardinality Double = 'Implicit + +-- | Given the Haskell type used by features such as `Proto3.Suite.Class.MessageField` +-- to indicate the encoding of a message field, returns the corresponding type of kind +-- 'ProtoType', which for repeated types is the element type. This type family is /not/ +-- injective because multiple types are supported for fields of protobuf type @string@. +type family RecoverProtoType (haskellType :: Type) :: ProtoType + where + RecoverProtoType Int32 = 'Int32 + RecoverProtoType Int64 = 'Int64 + RecoverProtoType (Signed Int32) = 'SInt32 + RecoverProtoType (Signed Int64) = 'SInt64 + RecoverProtoType Word32 = 'UInt32 + RecoverProtoType Word64 = 'UInt64 + RecoverProtoType (Fixed Word32) = 'Fixed32 + RecoverProtoType (Fixed Word64) = 'Fixed64 + RecoverProtoType (Signed (Fixed Int32)) = 'SFixed32 + RecoverProtoType (Signed (Fixed Int64)) = 'SFixed64 + RecoverProtoType (String _) = 'String + RecoverProtoType (Bytes _) = 'Bytes + RecoverProtoType Bool = 'Bool + RecoverProtoType Float = 'Float + RecoverProtoType Double = 'Double + RecoverProtoType (Commented _ haskellType) = RecoverProtoType haskellType + RecoverProtoType (Maybe (ForceEmit haskellType)) = RecoverProtoType haskellType + RecoverProtoType (PackedVec haskellType) = RecoverProtoType haskellType + RecoverProtoType (UnpackedVec haskellType) = RecoverProtoType haskellType + RecoverProtoType (Enumerated e) = 'Enumeration e + RecoverProtoType (Nested m) = 'Message m + RecoverProtoType (NestedVec m) = 'Message m + RecoverProtoType (M.Map k v) = 'Map (RecoverProtoType k) (RecoverProtoType v) + RecoverProtoType m = 'Message m + +-- | Inhabited by Haskell types used by features such as `Proto3.Suite.Class.MessageField` +-- that correspond to particular protobuf types that are repeated in the specified way. +class ( RecoverCardinality haskellType ~ cardinality + , RecoverProtoType haskellType ~ protoType + ) => + MessageFieldType (cardinality :: Cardinality) (protoType :: ProtoType) (haskellType :: Type) + +instance MessageFieldType 'Implicit 'Int32 Int32 +instance MessageFieldType 'Implicit 'Int64 Int64 +instance MessageFieldType 'Implicit 'SInt32 (Signed Int32) +instance MessageFieldType 'Implicit 'SInt64 (Signed Int64) +instance MessageFieldType 'Implicit 'UInt32 (Word32) +instance MessageFieldType 'Implicit 'UInt64 (Word64) +instance MessageFieldType 'Implicit 'Fixed32 (Fixed Word32) +instance MessageFieldType 'Implicit 'Fixed64 (Fixed Word64) +instance MessageFieldType 'Implicit 'SFixed32 (Signed (Fixed Int32)) +instance MessageFieldType 'Implicit 'SFixed64 (Signed (Fixed Int64)) +instance MessageFieldType 'Implicit 'String (String a) +instance MessageFieldType 'Implicit 'Bytes (Bytes a) +instance MessageFieldType 'Implicit 'Bool Bool +instance MessageFieldType 'Implicit 'Float Float +instance MessageFieldType 'Implicit 'Double Double +instance MessageFieldType 'Implicit ('Enumeration e) (Enumerated e) + +instance MessageFieldType 'Optional 'Int32 (Maybe (ForceEmit Int32)) +instance MessageFieldType 'Optional 'Int64 (Maybe (ForceEmit Int64)) +instance MessageFieldType 'Optional 'SInt32 (Maybe (ForceEmit (Signed Int32))) +instance MessageFieldType 'Optional 'SInt64 (Maybe (ForceEmit (Signed Int64))) +instance MessageFieldType 'Optional 'UInt32 (Maybe (ForceEmit Word32)) +instance MessageFieldType 'Optional 'UInt64 (Maybe (ForceEmit Word64)) +instance MessageFieldType 'Optional 'Fixed32 (Maybe (ForceEmit (Fixed Word32))) +instance MessageFieldType 'Optional 'Fixed64 (Maybe (ForceEmit (Fixed Word64))) +instance MessageFieldType 'Optional 'SFixed32 (Maybe (ForceEmit (Signed (Fixed Int32)))) +instance MessageFieldType 'Optional 'SFixed64 (Maybe (ForceEmit (Signed (Fixed Int64)))) +instance MessageFieldType 'Optional 'String (Maybe (ForceEmit (String a))) +instance MessageFieldType 'Optional 'Bytes (Maybe (ForceEmit (Bytes a))) +instance MessageFieldType 'Optional 'Bool (Maybe (ForceEmit Bool)) +instance MessageFieldType 'Optional 'Float (Maybe (ForceEmit Float)) +instance MessageFieldType 'Optional 'Double (Maybe (ForceEmit Double)) +instance MessageFieldType 'Optional ('Enumeration e) (Maybe (ForceEmit (Enumerated e))) + +-- | Helps to diagnose the absence of an instance for 'MessageFieldType' +-- for optional submessages by requiring that the second type parameter +-- be 'Nested' of the first. Please try to avoid using this type family +-- directly; it is exported only to help explain compilation errors. +type family OptionalMessageFieldType (m :: Type) (haskellType :: Type) + where + OptionalMessageFieldType m (Nested m) = (() :: Constraint) + OptionalMessageFieldType m (Nested a) = TypeError + ( 'Text "Expected reflected protobuf submessage type " ':<>: 'ShowType m ':$$: + 'Text "Actual type: " ':<>: 'ShowType a ) + OptionalMessageFieldType m haskellType = TypeError + ( 'Text "When using a Haskell type to specify an optional protobuf submessage" ':$$: + 'Text "(as opposed to repeated one or a submessage within a oneof)" ':$$: + 'Text "you must wrap the Haskell reflection type in Proto3.Suite.Nested." ':$$: + 'Text "Expected reflected protobuf submessage type " ':<>: 'ShowType m ':$$: + 'Text "Haskell type provided: " ':<>: 'ShowType haskellType ) + +instance ( OptionalMessageFieldType m haskellType + , RecoverCardinality haskellType ~ 'Optional + , RecoverProtoType haskellType ~ 'Message m + ) => + MessageFieldType 'Optional ('Message m) haskellType + +instance MessageFieldType ('Repeated 'Unpacked) 'Int32 (UnpackedVec Int32) +instance MessageFieldType ('Repeated 'Unpacked) 'Int64 (UnpackedVec Int64) +instance MessageFieldType ('Repeated 'Unpacked) 'SInt32 (UnpackedVec (Signed Int32)) +instance MessageFieldType ('Repeated 'Unpacked) 'SInt64 (UnpackedVec (Signed Int64)) +instance MessageFieldType ('Repeated 'Unpacked) 'UInt32 (UnpackedVec (Word32)) +instance MessageFieldType ('Repeated 'Unpacked) 'UInt64 (UnpackedVec (Word64)) +instance MessageFieldType ('Repeated 'Unpacked) 'Fixed32 (UnpackedVec (Fixed Word32)) +instance MessageFieldType ('Repeated 'Unpacked) 'Fixed64 (UnpackedVec (Fixed Word64)) +instance MessageFieldType ('Repeated 'Unpacked) 'SFixed32 (UnpackedVec (Signed (Fixed Int32))) +instance MessageFieldType ('Repeated 'Unpacked) 'SFixed64 (UnpackedVec (Signed (Fixed Int64))) +instance MessageFieldType ('Repeated 'Unpacked) 'String (UnpackedVec (String a)) +instance MessageFieldType ('Repeated 'Unpacked) 'Bytes (UnpackedVec (Bytes a)) +instance MessageFieldType ('Repeated 'Unpacked) 'Bool (UnpackedVec Bool) +instance MessageFieldType ('Repeated 'Unpacked) 'Float (UnpackedVec Float) +instance MessageFieldType ('Repeated 'Unpacked) 'Double (UnpackedVec Double) +instance MessageFieldType ('Repeated 'Unpacked) ('Enumeration e) (UnpackedVec (Enumerated e)) + +-- | Helps to diagnose the absence of an instance for 'MessageFieldType' +-- for repeated submessages by requiring that the second type parameter +-- be 'NestedVec' of the first. Please try to avoid using this type family +-- directly; it is exported only to help explain compilation errors. +type family RepeatedMessageFieldType (m :: Type) (haskellType :: Type) + where + RepeatedMessageFieldType m (NestedVec m) = (() :: Constraint) + RepeatedMessageFieldType m (NestedVec a) = TypeError + ( 'Text "Expected reflected protobuf submessage type " ':<>: 'ShowType m ':$$: + 'Text "Actual type: " ':<>: 'ShowType a ) + RepeatedMessageFieldType m haskellType = TypeError + ( 'Text "When using a Haskell type to specify a repeated protobuf submessage" ':$$: + 'Text "(as opposed to an optional one or a submessage within a oneof)" ':$$: + 'Text "you must wrap the Haskell reflection type in Proto3.Suite.NestedVec." ':$$: + 'Text "Expected reflected protobuf submessage type " ':<>: 'ShowType m ':$$: + 'Text "Haskell type provided: " ':<>: 'ShowType haskellType ) + +instance ( RepeatedMessageFieldType m haskellType + , RecoverCardinality haskellType ~ 'Repeated 'Unpacked + , RecoverProtoType haskellType ~ 'Message m + ) => + MessageFieldType ('Repeated 'Unpacked) ('Message m) haskellType + +instance ( MessageFieldType 'Implicit k kh + , MessageFieldType (CardinalityOfMapped v) v vh + ) => + MessageFieldType ('Repeated 'Unpacked) ('Map k v) (M.Map kh vh) + +instance MessageFieldType ('Repeated 'Packed) 'Int32 (PackedVec Int32) +instance MessageFieldType ('Repeated 'Packed) 'Int64 (PackedVec Int64) +instance MessageFieldType ('Repeated 'Packed) 'SInt32 (PackedVec (Signed Int32)) +instance MessageFieldType ('Repeated 'Packed) 'SInt64 (PackedVec (Signed Int64)) +instance MessageFieldType ('Repeated 'Packed) 'UInt32 (PackedVec (Word32)) +instance MessageFieldType ('Repeated 'Packed) 'UInt64 (PackedVec (Word64)) +instance MessageFieldType ('Repeated 'Packed) 'Fixed32 (PackedVec (Fixed Word32)) +instance MessageFieldType ('Repeated 'Packed) 'Fixed64 (PackedVec (Fixed Word64)) +instance MessageFieldType ('Repeated 'Packed) 'SFixed32 (PackedVec (Signed (Fixed Int32))) +instance MessageFieldType ('Repeated 'Packed) 'SFixed64 (PackedVec (Signed (Fixed Int64))) +instance MessageFieldType ('Repeated 'Packed) 'Bool (PackedVec Bool) +instance MessageFieldType ('Repeated 'Packed) 'Float (PackedVec Float) +instance MessageFieldType ('Repeated 'Packed) 'Double (PackedVec Double) +instance MessageFieldType ('Repeated 'Packed) ('Enumeration e) (PackedVec (Enumerated e)) diff --git a/src/Proto3/Suite/Form/Encode.hs b/src/Proto3/Suite/Form/Encode.hs new file mode 100644 --- /dev/null +++ b/src/Proto3/Suite/Form/Encode.hs @@ -0,0 +1,573 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RoleAnnotations #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE ViewPatterns #-} + +{-# OPTIONS_GHC -Wno-orphans #-} + +-- | Encodes to protobuf directly from application-specific source data without +-- an intermediate value of a type generated from protobuf message definitions. +-- +-- Use @compile-proto-file --typeLevelFormat ...@ to generate supporting code. +-- +-- Importantly, code generation does not make use of this module, +-- instead using only "Proto3.Suite.Form". Therefore one can replace +-- this module with another that makes use of the same generated code. +-- +-- /WARNING/: This module is experimental and breaking changes may occur much more +-- frequently than in the other modules of this package, perhaps even in patch releases. +-- +-- Example @.proto@ file: +-- +-- > syntax = "proto3"; +-- > package Example; +-- > +-- > message Submessage { +-- > }; +-- > +-- > message Message { +-- > sint32 implicitField = 1; +-- > optional sint32 optionalField = 2; +-- > repeated sint32 repeatedField = 3; +-- > Submessage submessageField = 4; +-- > map mapField = 5; +-- > } +-- +-- Example Haskell program: +-- +-- > {-# LANGUAGE DataKinds #-} +-- > {-# LANGUAGE OverloadedStrings #-} +-- > {-# LANGUAGE PolyKinds #-} +-- > {-# LANGUAGE TypeApplications #-} +-- > +-- > import Control.Category ((.), id) +-- > import Data.ByteString.Lazy (writeFile) +-- > import Data.Text.Short (ShortText) +-- > import Data.Word (Word8) +-- > import Example (Message, Submessage) +-- > import Prelude hiding ((.), id) +-- > import Proto3.Suite.Form (Association, ProtoType(SInt32, String)) +-- > import Proto3.Suite.Form.Encode +-- > (Auto(..), MessageEncoder, associations, field, +-- > fieldsToMessage, messageEncoderToLazyByteString) +-- > import Proto3.Wire.Encode.Repeated (mapRepeated) +-- > +-- > main :: IO () +-- > main = do +-- > let assoc :: (Word8, ShortText) -> MessageEncoder (Association 'SInt32 'String) +-- > assoc (k, v) = fieldsToMessage (field @"key" k . field @"value" v) +-- > Data.ByteString.Lazy.writeFile "example.data" $ +-- > messageEncoderToLazyByteString $ +-- > fieldsToMessage @Message $ +-- > field @"implicitField" @Word8 123 . +-- > field @"optionalField" (Just (Auto 456)) . +-- > field @"repeatedField" (mapRepeated Auto [789, 321]) . +-- > field @"submessageField" (Just (fieldsToMessage @Submessage id)) . +-- > associations @"mapField" (mapRepeated assoc [(3, "abc"), (5, "xyz")]) +-- +module Proto3.Suite.Form.Encode + ( MessageEncoder(..) + , messageEncoderToLazyByteString + , messageEncoderToByteString + , etaMessageEncoder + , unsafeByteStringToMessageEncoder + , MessageEncoding + , messageCache + , cacheMessageEncoding + , cachedMessageEncoding + , messageEncodingToByteString + , unsafeByteStringToMessageEncoding + , FieldsEncoder(..) + , etaFieldsEncoder + , FieldsEncoding + , cacheFieldsEncoding + , cachedFieldsEncoding + , Distinct + , DistinctCheck + , RepeatedNames + , RepeatedNames1 + , Omits + , Strip + , OccupiedOnly + , OccupiedOnly1 + , fieldsToMessage + , Occupy + , Occupy1 + , NameSublist + , omitted + , SFieldNumberI + , KnownFieldNumber + , Field(..) + , FieldForm(..) + , Wrap(..) + , Auto(..) + , foldFieldsEncoders + , message + , associations + , Reflection(..) + , messageReflection + ) where + +import Control.Applicative ((<|>)) +import Control.Category (Category(..)) +import Control.DeepSeq (NFData) +import Data.Aeson qualified as Aeson (FromJSON(..), ToJSON(..)) +import Data.Coerce (coerce) +import Data.Int (Int8, Int16, Int32, Int64) +import Data.Kind (Type) +import Data.ByteString qualified as B +import Data.ByteString.Lazy qualified as BL +import Data.ByteString.Short qualified as BS +import Data.Functor.Identity (Identity(..)) +import Data.Text qualified as T +import Data.Text.Lazy qualified as TL +import Data.Text.Short qualified as TS +import Data.Word (Word8, Word16, Word32, Word64) +import GHC.Exts (Proxy#, proxy#) +import GHC.Generics (Generic) +import GHC.TypeLits (Symbol) +import Prelude hiding (String, (.), id) +import Proto3.Suite.Form.Encode.Core +import Proto3.Suite.Class + (Message, MessageField, encodeMessage, encodeMessageField, fromByteString) +import Proto3.Suite.Form + (Association, MessageFieldType, Packing(..), Cardinality(..), + CardinalityOf, ProtoType(..), ProtoTypeOf) +import Proto3.Suite.JSONPB.Class qualified as JSONPB + (FromJSONPB(..), ToJSONPB(..), toAesonEncoding, toAesonValue) +import Proto3.Suite.Types (Enumerated, codeFromEnumerated) +import Proto3.Wire.Class (ProtoEnum(..)) +import Proto3.Wire.Encode qualified as Encode +import Proto3.Wire.Encode.Repeated (ToRepeated, mapRepeated) +import Proto3.Wire.Reverse qualified as RB +import Proto3.Wire.Types (FieldNumber, fieldNumber) + +-- | The unsafe but fast inverse of 'messageEncoderToByteString'. +unsafeByteStringToMessageEncoder :: B.ByteString -> MessageEncoder message +unsafeByteStringToMessageEncoder = UnsafeMessageEncoder . Encode.unsafeFromByteString + +-- | The octet sequence that would be emitted by some +-- 'MessageEncoder' having the same type parameter. +-- +-- (This type is not a 'Semigroup' because combining encodings that both +-- have the same non-repeated field is arguably incorrect, even though the +-- standard asks parsers to to try to work around such improper repetition.) +-- +-- See also: 'cacheMessageEncoding' +newtype MessageEncoding (message :: Type) = UnsafeMessageEncoding B.ByteString + deriving stock (Generic) + deriving newtype (NFData) + +type role MessageEncoding nominal + +instance FieldForm 'Optional ('Message inner) (Identity (MessageEncoding inner)) + where + fieldForm rep ty !fn (Identity e) = fieldForm rep ty fn (Identity (cachedMessageEncoding e)) + {-# INLINE fieldForm #-} + +-- | This instance is rather artificial because maps are automatically +-- repeated and unpacked, with no option to specify a single key-value pair +-- as an @optional@ field or a field of a @oneof@. Hence the code generator +-- should never directly make use of this instance, but it will do so +-- indirectly via the general instance for repeated unpacked fields, +-- which will then delegate to this instance. +instance FieldForm 'Optional ('Map key value) (Identity (MessageEncoding (Association key value))) + where + fieldForm rep ty !fn (Identity a) = fieldForm rep ty fn (Identity (cachedMessageEncoding a)) + {-# INLINE fieldForm #-} + +-- | Precomputes the octet sequence that would be written by the given 'MessageEncoder'. +-- Do this only if you expect to reuse that specific octet sequence repeatedly. +-- +-- @'cachedMessageEncoding' . 'cacheMessageEncoding'@ is functionally equivalent +-- to 'id' but has different performance characteristics. +-- +-- See also: 'cacheFieldsEncoding'. +cacheMessageEncoding :: MessageEncoder message -> MessageEncoding message +cacheMessageEncoding = UnsafeMessageEncoding . messageEncoderToByteString + +-- | Encodes a precomputed 'MessageEncoder' by copying octets from a memory buffer. +-- See 'cacheMessageEncoding'. +-- +-- See also: 'cachedFieldsEncoding' +cachedMessageEncoding :: MessageEncoding message -> MessageEncoder message +cachedMessageEncoding = unsafeByteStringToMessageEncoder . messageEncodingToByteString + +-- | Strips type information from the message encoding, leaving only its octets. +messageEncodingToByteString :: MessageEncoding message -> B.ByteString +messageEncodingToByteString (UnsafeMessageEncoding octets) = octets + +-- | Unsafe because the caller must ensure that the given octets +-- are in the correct format for a message of the specified type. +unsafeByteStringToMessageEncoding :: B.ByteString -> MessageEncoding message +unsafeByteStringToMessageEncoding = UnsafeMessageEncoding + +-- | The octet sequence that would be prefixed by some +-- 'FieldsEncoder' having the same type parameters. +newtype FieldsEncoding (message :: Type) (possible :: [Symbol]) (following :: [Symbol]) = + UnsafeFieldsEncoding { untypedFieldsEncoding :: B.ByteString } + +type role FieldsEncoding nominal nominal nominal + +-- | Precomputes the octet sequence that would be written by the given 'FieldsEncoder'. +-- Do this only if you expect to reuse that specific octet sequence repeatedly. +-- +-- @'cachedFieldsEncoding' . 'cacheFieldsEncoding'@ is functionally equivalent +-- to 'id' but has different performance characteristics. +-- +-- See also: 'cacheMessageEncoding' +cacheFieldsEncoding :: + FieldsEncoder message possible following -> FieldsEncoding message possible following +cacheFieldsEncoding = + UnsafeFieldsEncoding . BL.toStrict . Encode.toLazyByteString . untypedFieldsEncoder + +-- | Encodes a precomputed 'FieldsEncoder' by copying octets from a memory buffer. +-- See 'cacheFieldsEncoding'. +-- +-- See also: 'cachedMessageEncoding'. +cachedFieldsEncoding :: + FieldsEncoding message possible following -> FieldsEncoder message possible following +cachedFieldsEncoding = UnsafeFieldsEncoder . Encode.unsafeFromByteString . untypedFieldsEncoding +{-# INLINE cachedFieldsEncoding #-} + +$(instantiatePackableField + [t| 'UInt32 |] [t| Word32 |] [| Encode.uint32 |] [| Encode.packedUInt32R |] + [ ([t| Word16 |], [| fromIntegral @Word16 @Word32 |], [t| 'UInt32 |]) + , ([t| Word8 |], [| fromIntegral @Word8 @Word32 |], [t| 'UInt32 |]) + ] True) + +$(instantiatePackableField + [t| 'UInt64 |] [t| Word64 |] [| Encode.uint64 |] [| Encode.packedUInt64R |] + [ ([t| Word32 |], [| id |], [t| 'UInt32 |]) + , ([t| Word16 |], [| fromIntegral @Word16 @Word32 |], [t| 'UInt32 |]) + , ([t| Word8 |], [| fromIntegral @Word8 @Word32 |], [t| 'UInt32 |]) + ] True) + +$(instantiatePackableField + [t| 'Int32 |] [t| Int32 |] [| Encode.int32 |] [| Encode.packedInt32R |] + [ ([t| Int16 |], [| fromIntegral @Int16 @Int32 |], [t| 'Int32 |]) + , ([t| Int8 |], [| fromIntegral @Int8 @Int32 |], [t| 'Int32 |]) + -- Because the encoding for @int32@ is just a conversion to the 64-bit unsigned + -- integer that is equal to the original value modulo @2^64@ followed by @uint64@ + -- encoding, the encoding of unsigned values can be accomplished with the @uint32@ + -- encoder, which generates less code because it need not support values @>= 2^32@. + , ([t| Word16 |], [| id |], [t| 'UInt32 |]) + , ([t| Word8 |], [| id |], [t| 'UInt32 |]) + ] True) + +$(instantiatePackableField + [t| 'Int64 |] [t| Int64 |] [| Encode.int64 |] [| Encode.packedInt64R |] + [ ([t| Int32 |], [| fromIntegral @Int32 @Int64 |], [t| 'Int64 |]) + , ([t| Int16 |], [| fromIntegral @Int16 @Int64 |], [t| 'Int64 |]) + , ([t| Int8 |], [| fromIntegral @Int8 @Int64 |], [t| 'Int64 |]) + -- Because the encoding for @int32@ is just a conversion to the 64-bit unsigned + -- integer that is equal to the original value modulo @2^64@ followed by @uint64@ + -- encoding, the encoding of unsigned values can be accomplished with the @uint32@ + -- encoder, which generates less code because it need not support values @>= 2^32@. + , ([t| Word32 |], [| id |], [t| 'UInt32 |]) + , ([t| Word16 |], [| id |], [t| 'UInt32 |]) + , ([t| Word8 |], [| id |], [t| 'UInt32 |]) + ] True) + +$(instantiatePackableField + [t| 'SInt32 |] [t| Int32 |] [| Encode.sint32 |] [| Encode.packedSInt32R |] + [ ([t| Int16 |], [| fromIntegral @Int16 @Int32 |], [t| 'SInt32 |]) + , ([t| Int8 |], [| fromIntegral @Int8 @Int32 |], [t| 'SInt32 |]) + , ([t| Word16 |], [| fromIntegral @Word16 @Int32 |], [t| 'SInt32 |]) + , ([t| Word8 |], [| fromIntegral @Word8 @Int32 |], [t| 'SInt32 |]) + ] False) + +$(instantiatePackableField + [t| 'SInt64 |] [t| Int64 |] [| Encode.sint64 |] [| Encode.packedSInt64R |] + [ ([t| Int32 |], [| id |], [t| 'SInt32 |]) + , ([t| Int16 |], [| id |], [t| 'SInt32 |]) + , ([t| Int8 |], [| id |], [t| 'SInt32 |]) + , ([t| Word32 |], [| fromIntegral @Word32 @Int64 |], [t| 'SInt64 |]) + , ([t| Word16 |], [| id |], [t| 'SInt32 |]) + , ([t| Word8 |], [| id |], [t| 'SInt32 |]) + ] False) + +$(instantiatePackableField + [t| 'Fixed32 |] [t| Word32 |] [| Encode.fixed32 |] [| Encode.packedFixed32R |] + [ ([t| Word16 |], [| fromIntegral @Word16 @Word32 |], [t| 'Fixed32 |]) + , ([t| Word8 |], [| fromIntegral @Word8 @Word32 |], [t| 'Fixed32 |]) + ] False) + +$(instantiatePackableField + [t| 'Fixed64 |] [t| Word64 |] [| Encode.fixed64 |] [| Encode.packedFixed64R |] + [ ([t| Word32 |], [| fromIntegral @Word32 @Word64 |], [t| 'Fixed64 |]) + , ([t| Word16 |], [| fromIntegral @Word16 @Word64 |], [t| 'Fixed64 |]) + , ([t| Word8 |], [| fromIntegral @Word8 @Word64 |], [t| 'Fixed64 |]) + ] False) + +$(instantiatePackableField + [t| 'SFixed32 |] [t| Int32 |] [| Encode.sfixed32 |] [| Encode.packedSFixed32R |] + [ ([t| Int16 |], [| fromIntegral @Int16 @Int32 |], [t| 'SFixed32 |]) + , ([t| Int8 |], [| fromIntegral @Int8 @Int32 |], [t| 'SFixed32 |]) + , ([t| Word16 |], [| fromIntegral @Word16 @Int32 |], [t| 'SFixed32 |]) + , ([t| Word8 |], [| fromIntegral @Word8 @Int32 |], [t| 'SFixed32 |]) + ] False) + +$(instantiatePackableField + [t| 'SFixed64 |] [t| Int64 |] [| Encode.sfixed64 |] [| Encode.packedSFixed64R |] + [ ([t| Int32 |], [| fromIntegral @Int32 @Int64 |], [t| 'SFixed64 |]) + , ([t| Int16 |], [| fromIntegral @Int16 @Int64 |], [t| 'SFixed64 |]) + , ([t| Int8 |], [| fromIntegral @Int8 @Int64 |], [t| 'SFixed64 |]) + , ([t| Word32 |], [| fromIntegral @Word32 @Int64 |], [t| 'SFixed64 |]) + , ([t| Word16 |], [| fromIntegral @Word16 @Int64 |], [t| 'SFixed64 |]) + , ([t| Word8 |], [| fromIntegral @Word8 @Int64 |], [t| 'SFixed64 |]) + ] False) + +$(instantiatePackableField + [t| 'Bool |] [t| Bool |] [| Encode.bool |] [| Encode.packedBoolsR |] + [] True) + +$(instantiatePackableField + [t| 'Float |] [t| Float |] [| Encode.float |] [| Encode.packedFloatsR |] + [] True) + +$(instantiatePackableField + [t| 'Double |] [t| Double |] [| Encode.double |] [| Encode.packedDoublesR |] + [ ([t| Float |], [| realToFrac @Float @Double |], [t| 'Double |]) + ] True) + +$(instantiateStringOrBytesField + [t| 'String |] [t| TS.ShortText |] [| Encode.shortText |] + [ ([t| T.Text |], [| \(!fn) x -> Encode.text fn (TL.fromStrict x) |]) + , ([t| TL.Text |], [| Encode.text |]) + ]) + +$(instantiateStringOrBytesField + [t| 'Bytes |] [t| BS.ShortByteString |] [| Encode.shortByteString |] + [ ([t| B.ByteString |], [| Encode.byteString |]) + , ([t| BL.ByteString |], [| Encode.lazyByteString |]) + ]) + +instance ( ProtoEnum e + , FieldForm 'Implicit 'Int32 Int32 + ) => + FieldForm 'Implicit ('Enumeration e) e + where + fieldForm rep _ !fn x = fieldForm rep (proxy# :: Proxy# 'Int32) fn (fromProtoEnum x) + {-# INLINE fieldForm #-} + +instance ( ProtoEnum e + , FieldForm 'Optional 'Int32 (Identity Int32) + ) => + FieldForm 'Optional ('Enumeration e) (Identity e) + where + fieldForm rep _ !fn (Identity x) = + fieldForm rep (proxy# :: Proxy# 'Int32) fn (Identity (fromProtoEnum x)) + {-# INLINE fieldForm #-} + +instance ( ProtoEnum e + , FieldForm 'Implicit 'Int32 Int32 + ) => + FieldForm 'Implicit ('Enumeration e) (Enumerated e) + where + fieldForm rep _ !fn x = fieldForm rep (proxy# :: Proxy# 'Int32) fn (codeFromEnumerated x) + {-# INLINE fieldForm #-} + +instance ( ProtoEnum e + , FieldForm 'Optional 'Int32 (Identity Int32) + ) => + FieldForm 'Optional ('Enumeration e) (Identity (Enumerated e)) + where + fieldForm rep _ !fn (Identity x) = + fieldForm rep (proxy# :: Proxy# 'Int32) fn (Identity (codeFromEnumerated x)) + {-# INLINE fieldForm #-} + +instance ProtoEnum e => + PackedFieldForm ('Enumeration e) e + where + packedFieldForm _ !fn xs = + packedFieldForm (proxy# :: Proxy# 'Int32) fn (fmap fromProtoEnum xs) + {-# INLINE packedFieldForm #-} + +instance ProtoEnum e => + PackedFieldForm ('Enumeration e) (Enumerated e) + where + packedFieldForm _ !fn xs = + packedFieldForm (proxy# :: Proxy# 'Int32) fn (fmap codeFromEnumerated xs) + {-# INLINE packedFieldForm #-} + +instance FieldForm 'Optional 'Bytes (Identity RB.BuildR) + where + fieldForm _ _ = coerce + @(FieldNumber -> RB.BuildR -> Encode.MessageBuilder) + @(FieldNumber -> Identity RB.BuildR -> Encode.MessageBuilder) + Encode.bytes + {-# INLINE fieldForm #-} + +instance FieldForm 'Implicit 'Bytes RB.BuildR + where + fieldForm _ _ = Encode.bytesIfNonempty + {-# INLINE fieldForm #-} + +-- | Combines 'FieldsEncoder' builders for zero or more repeated fields. +foldFieldsEncoders :: + forall c message names . + ToRepeated c (FieldsEncoder message names names) => + c -> + FieldsEncoder message names names +foldFieldsEncoders prefixes = + UnsafeFieldsEncoder (Encode.repeatedMessageBuilder (mapRepeated untypedFieldsEncoder prefixes)) +{-# INLINE foldFieldsEncoders #-} + +-- | Specializes the argument type of 'field' to the encoding of a submessage type, +-- which can help to avoid ambiguity when the argument expression is polymorphic. +message :: + forall (name :: Symbol) (inner :: Type) (outer :: Type) (names :: [Symbol]) . + ( ProtoTypeOf outer name ~ 'Message inner + , Field name (MessageEncoder inner) outer + , KnownFieldNumber outer name + ) => + MessageEncoder inner -> + FieldsEncoder outer names (Occupy outer name names) +message = field @name @(MessageEncoder inner) + +-- | Specializes the argument type of 'field' to be a sequence of key-value pair encodings, +-- which can help to avoid ambiguity when the argument expression is polymorphic. +associations :: + forall (name :: Symbol) (t :: Type -> Type) (key :: ProtoType) (value :: ProtoType) + (message :: Type) (names :: [Symbol]) . + ( ProtoTypeOf message name ~ 'Map key value + , CardinalityOf message name ~ 'Repeated 'Unpacked + , Field name (t (MessageEncoder (Association key value))) message + , KnownFieldNumber message name + ) => + t (MessageEncoder (Association key value)) -> + FieldsEncoder message names names +associations = field @name @(t (MessageEncoder (Association key value))) + +-- | Signals that the argument to 'field' should be treated +-- as a reflection in Haskell of a protobuf construct, both +-- in its type and in its value. +-- +-- For example, if the type argument is generated from a protobuf +-- message definition, then 'field' will encode the message whose +-- fields are given by the Haskell data type inside of this @newtype@. +-- +-- Repeated fields must be supplied as an appropriately-typed sequence. +-- +-- For this @newtype@, 'Field' delegates to `Proto3.Suite.Class.MessageField` +-- and has its performance characteristics. The creation of temporary +-- reflections of protobuf messages may decrease efficiency +-- in some cases. However, you may find this @newtype@ useful +-- where a mix of techniques is needed, either for compatibility +-- or during a gradual transition to use of 'Field'. +-- +-- Note that for optional submessages you must use `Proto3.Suite.Types.Nested`, +-- and for repeated submessages you must use `Proto3.Suite.Types.NestedVec`. +-- (For submessages within a @oneof@ you can use the reflection type directly.) +-- +-- To encode a top-level message instead of a field, use 'messageReflection'. +newtype Reflection a = Reflection a + +instance ( MessageFieldType cardinality protoType a + , MessageField a + ) => + FieldForm cardinality protoType (Reflection a) + where + fieldForm _ _ = coerce (encodeMessageField @a) + {-# INLINE fieldForm #-} + +-- | Creates a message encoder by means of type class `Proto3.Suite.Class.Message`. +-- +-- To encode a field instead of a top-level message, use 'Reflection'. +messageReflection :: forall message . Message message => message -> MessageEncoder message +messageReflection m = coerce (encodeMessage @message (fieldNumber 1) m) +{-# INLINABLE messageReflection #-} + +-- | Creates a message encoding by means of type class `Proto3.Suite.Class.Message`. +-- +-- Equivalent to @'cacheMessageEncoding' . 'messageReflection'@. +messageCache :: forall message . Message message => message -> MessageEncoding message +messageCache m = cacheMessageEncoding (messageReflection m) +{-# INLINABLE messageCache #-} + +instance (Message message, Show message) => + Show (MessageEncoding message) + where + showsPrec d (messageEncodingToByteString -> bs) = showParen (d >= 11) $ + case fromByteString bs of + Left _ -> shows 'unsafeByteStringToMessageEncoding . showChar ' ' . showsPrec 11 bs + Right (msg :: message) -> shows 'messageCache . showChar ' ' . showsPrec 11 msg + +instance (Message message, Show message) => + Show (MessageEncoder message) + where + showsPrec d (messageEncoderToByteString -> bs) = showParen (d >= 11) $ + case fromByteString bs of + Left _ -> shows 'unsafeByteStringToMessageEncoder . showChar ' ' . showsPrec 11 bs + Right (msg :: message) -> shows 'messageReflection . showChar ' ' . showsPrec 11 msg + +instance (Message message, JSONPB.ToJSONPB message) => + JSONPB.ToJSONPB (MessageEncoding message) + where + toJSONPB (messageEncodingToByteString -> bs) opts = + case fromByteString bs of + Left _ -> JSONPB.toJSONPB @B.ByteString bs opts + Right (msg :: message) -> JSONPB.toJSONPB @message msg opts + + toEncodingPB (messageEncodingToByteString -> bs) opts = + case fromByteString bs of + Left _ -> JSONPB.toEncodingPB @B.ByteString bs opts + Right (msg :: message) -> JSONPB.toEncodingPB @message msg opts + +instance (Message message, JSONPB.ToJSONPB message) => + JSONPB.ToJSONPB (MessageEncoder message) + where + toJSONPB = JSONPB.toJSONPB @(MessageEncoding message) . cacheMessageEncoding + toEncodingPB = JSONPB.toEncodingPB @(MessageEncoding message) . cacheMessageEncoding + +instance (Message message, JSONPB.FromJSONPB message) => + JSONPB.FromJSONPB (MessageEncoding message) + where + parseJSONPB v = + messageCache <$> JSONPB.parseJSONPB @message v <|> + unsafeByteStringToMessageEncoding <$> JSONPB.parseJSONPB @B.ByteString v + +instance (Message message, JSONPB.FromJSONPB message) => + JSONPB.FromJSONPB (MessageEncoder message) + where + parseJSONPB v = + messageReflection <$> JSONPB.parseJSONPB @message v <|> + unsafeByteStringToMessageEncoder <$> JSONPB.parseJSONPB @B.ByteString v + +instance (Message message, JSONPB.ToJSONPB message) => + Aeson.ToJSON (MessageEncoding message) + where + toJSON = JSONPB.toAesonValue + toEncoding = JSONPB.toAesonEncoding + +instance (Message message, JSONPB.ToJSONPB message) => + Aeson.ToJSON (MessageEncoder message) + where + toJSON = JSONPB.toAesonValue + toEncoding = JSONPB.toAesonEncoding + +instance (Message message, JSONPB.FromJSONPB message) => + Aeson.FromJSON (MessageEncoding message) + where + parseJSON = JSONPB.parseJSONPB + +instance (Message message, JSONPB.FromJSONPB message) => + Aeson.FromJSON (MessageEncoder message) + where + parseJSON = JSONPB.parseJSONPB diff --git a/src/Proto3/Suite/Form/Encode/Core.hs b/src/Proto3/Suite/Form/Encode/Core.hs new file mode 100644 --- /dev/null +++ b/src/Proto3/Suite/Form/Encode/Core.hs @@ -0,0 +1,778 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PackageImports #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RoleAnnotations #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE TemplateHaskellQuotes #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ViewPatterns #-} + +-- | Implementation details of "Proto3.Suite.Form.Encode" that +-- must be kept separate for the sake of @TemplateHaskell@. +module Proto3.Suite.Form.Encode.Core + ( MessageEncoder(..) + , messageEncoderToLazyByteString + , messageEncoderToByteString + , etaMessageEncoder + , FieldsEncoder(..) + , etaFieldsEncoder + , Distinct + , DistinctCheck + , RepeatedNames + , RepeatedNames1 + , Omits + , Strip + , OccupiedName + , OccupiedOnly + , OccupiedOnly1 + , fieldsToMessage + , Occupy + , Occupy1 + , NameSublist + , omitted + , SFieldNumberI + , KnownFieldNumber + , fieldNumberVal + , Field(..) + , FieldForm(..) + , PackedFieldForm(..) + , Wrap(..) + , Auto(..) + , instantiatePackableField + , instantiateStringOrBytesField + ) where + +import Control.Category (Category(..)) +import Data.ByteString qualified as B +import Data.ByteString.Lazy qualified as BL +import Data.Coerce (coerce) +import Data.Functor.Identity (Identity(..)) +import Data.Kind (Type) +import Data.Traversable (for) +import GHC.Exts (Constraint, Proxy#, TYPE, proxy#) +import GHC.Generics (Generic) +import GHC.TypeLits (ErrorMessage(..), KnownNat, Nat, Symbol, TypeError, natVal') +import "template-haskell" Language.Haskell.TH qualified as TH +import Prelude hiding ((.), id) +import Proto3.Suite.Class (isDefault) +import Proto3.Suite.Form + (Association, NumberOf, OneOfOf, Packing(..), Cardinality(..), + CardinalityOf, ProtoType(..), ProtoTypeOf, Wrapper) +import Proto3.Wire.Encode qualified as Encode +import Proto3.Wire.Encode.Repeated (Repeated(..), ToRepeated(..), mapRepeated) +import Proto3.Wire.Types (FieldNumber, fieldNumber) + +-- | Annotates 'Encode.MessageBuilder' with the type of protobuf message it encodes. +-- Prefix a tag and length to turn the message into a submessage of a larger message. +newtype MessageEncoder (message :: Type) = UnsafeMessageEncoder + { untypedMessageEncoder :: Encode.MessageBuilder } + +type role MessageEncoder nominal + +-- | Serialize a message (or portion thereof) as a lazy 'BL.ByteString'. +messageEncoderToLazyByteString :: forall message . MessageEncoder message -> BL.ByteString +messageEncoderToLazyByteString = Encode.toLazyByteString . untypedMessageEncoder + +-- | Serialize a message (or portion thereof) as a strict 'B.ByteString'. +-- +-- Functionally equivalent to @'BL.toStrict' . 'messageEncoderToLazyByteString'@, +-- and currently even the performance is the same. +messageEncoderToByteString :: forall message . MessageEncoder message -> B.ByteString +messageEncoderToByteString = BL.toStrict . messageEncoderToLazyByteString + +-- | Like 'Encode.etaMessageBuilder' but for 'MessageEncoder'. +etaMessageEncoder :: forall a message . (a -> MessageEncoder message) -> a -> MessageEncoder message +etaMessageEncoder = coerce (Encode.etaMessageBuilder @a) + +-- | A 'Category' on builders that prefix zero or more fields to a message. +-- Use '.' to accumulate prefixes to create an 'MessageEncoder' for a whole message. +-- +-- The first type parameter specifies the type of message being built. +-- +-- The second and third type parameters list the names of some subset +-- of the oneofs and non-repeatable non-oneof fields possible within +-- the type of message specified by the first type parameter. The +-- third type parameter must be a suffix of the second, and limits +-- the oneofs and non-repeatable non-oneof fields that may occur in +-- any builder which follows the contained builder. The first parameter +-- prefixes the names of the oneofs and non-repeatable non-oneof +-- fields that /might/ be written by the contained builder. +-- +-- If a name ends up listed more than once, that will eventually +-- be detected as a compilation error; see type family 'Distinct'. +-- +-- Note that this type system permits multiple blocks of the same +-- packed repeated field. Though that would be less compact than +-- a single block, it is allowed by the protobuf standard. +-- +-- See also: 'cacheFieldsEncoder' +newtype FieldsEncoder (message :: Type) (possible :: [Symbol]) (following :: [Symbol]) = + UnsafeFieldsEncoder { untypedFieldsEncoder :: Encode.MessageBuilder } + +type role FieldsEncoder nominal nominal nominal + +-- | The 'Category' on encoders of zero or more fields of a particular +-- type of message whose '.' is '<>' on the contained builders. +-- +-- Note that '.' preserves the requirements +-- on the type parameters of 'FieldsEncoder'. +instance Category (FieldsEncoder message) + where + id = UnsafeFieldsEncoder mempty + f . g = UnsafeFieldsEncoder (untypedFieldsEncoder f <> untypedFieldsEncoder g) + +-- | Like 'Encode.etaMessageBuilder' but for 'FieldsEncoder'. +etaFieldsEncoder :: + forall a message possible following . + (a -> FieldsEncoder message possible following) -> + a -> FieldsEncoder message possible following +etaFieldsEncoder = coerce (Encode.etaMessageBuilder @a) + +-- | Yields a satisfied constraint if the given list of names contains +-- no duplicates after first filtering out the names of repeated fields +-- and replacing the names of @oneof@ fields with their @oneof@ names. +-- Otherwise raises a compilation error mentioning the repeated names. +type Distinct (message :: Type) (names :: [Symbol]) = + DistinctCheck message (RepeatedNames (OccupiedOnly message names)) + +-- | Reports nonempty output of 'RepeatedNames' as applied to the result of 'OccupiedOnly'. +-- +-- This type family is an implementation detail of 'Distinct' +-- that is subject to change, and is exported only to assist +-- in understanding of compilation errors. +type family DistinctCheck (message :: Type) (repeated :: [k]) :: Constraint + where + DistinctCheck _ '[] = () + DistinctCheck message repeated = TypeError + ( 'ShowType message ':<>: 'Text " forbids repetition of:" + ':$$: 'ShowType repeated ) + +-- | Given a list of names, returns the non-repeating list +-- of names that occur more than once in the given list. +-- +-- This type family is an implementation detail of 'Distinct' +-- that is subject to change, and is exported only to assist +-- in understanding of compilation errors. +type family RepeatedNames (names :: [k]) :: [k] + where + RepeatedNames (name ': names) = RepeatedNames1 name names (Omits name names) + RepeatedNames '[] = '[] + +-- | Helps to implement 'RepeatedNames'. +-- +-- This type family is an implementation detail of 'Distinct' +-- that is subject to change, and is exported only to assist +-- in understanding of compilation errors. +type family RepeatedNames1 (name :: k) (names :: [k]) (omits :: Bool) :: [k] + where + RepeatedNames1 _ names 'True = RepeatedNames names + RepeatedNames1 name names 'False = name ': RepeatedNames (Strip name names) + +-- | Is the given name absent from the given list of names? +-- +-- This type family is an implementation detail of 'RepeatedNames' +-- that is subject to change, and is exported only to assist +-- in understanding of compilation errors. +type family Omits (name :: k) (names :: [k]) :: Bool + where + Omits name (name ': names) = 'False + Omits name (_ ': names) = Omits name names + Omits name '[] = 'True + +-- | Strips all occurrences of the given name, leaving behind all other name occurrences. +-- +-- This type family is an implementation detail of 'RepeatedNames' +-- that is subject to change, and is exported only to assist +-- in understanding of compilation errors. +type family Strip (name :: k) (names :: [k]) :: [k] + where + Strip name (name ': names) = Strip name names + Strip name (other ': names) = other ': Strip name names + Strip name '[] = '[] + +-- | Yields the name of the containing @oneof@ if there is one, +-- and otherwise returns the field name as is. This type family can +-- help prevent two fields of the same @oneof@ from being emitted. +-- +-- This type family is an implementation detail of other type families +-- that is subject to change, and is exported only to assist +-- in understanding of compilation errors. +type OccupiedName (message :: Type) (name :: Symbol) = OccupiedName1 name (OneOfOf message name) + +-- | This type family is an implementation detail of 'OccupiedName' +-- that is subject to change, and is exported only to assist +-- in understanding of compilation errors. +type family OccupiedName1 (name :: Symbol) (oneof :: Symbol) :: Symbol + where + OccupiedName1 name "" = name + OccupiedName1 _ oneof = oneof + +-- | Filters out the repeated field names and replaces @oneof@ fields with their @oneof@ names. +-- +-- We do this in case 'omitted' is used to introduce the names of repeated fields +-- or fields that are contained within @oneof@s; see the explanatory comments there. +-- +-- This type family is an implementation detail of 'Distinct' +-- that is subject to change, and is exported only to assist +-- in understanding of compilation errors. +type family OccupiedOnly (message :: Type) (names :: [Symbol]) :: [Symbol] + where + OccupiedOnly message (name ': names) = + OccupiedOnly1 message name names (CardinalityOf message name) + OccupiedOnly _ '[] = + '[] + +-- | Helps to implement 'OccupiedOnly'. +-- +-- This type family is an implementation detail of 'Distinct' +-- that is subject to change, and is exported only to assist +-- in understanding of compilation errors. +type family OccupiedOnly1 (message :: Type) (name :: Symbol) (names :: [Symbol]) + (cardinality :: Cardinality) :: [Symbol] + where + OccupiedOnly1 message name names 'Implicit = + name ': OccupiedOnly message names + OccupiedOnly1 message name names 'Optional = + OccupiedName message name ': OccupiedOnly message names + OccupiedOnly1 message name names ('Repeated _) = + OccupiedOnly message names + +-- | Relabels a prefix of fields of a message as an encoding for +-- the message as a whole (though without any tag or length that +-- would make it a submessage). +fieldsToMessage :: + forall (message :: Type) (names :: [Symbol]) . + Distinct message names => + FieldsEncoder message '[] names -> + MessageEncoder message +fieldsToMessage = UnsafeMessageEncoder . untypedFieldsEncoder + +-- | Among the names of the given message, prefixes +-- the given name with the following exceptions: +-- +-- * Names of repeatable fields are not prefixed; +-- there is no need to avoid their repetition. +-- +-- * When a field of a @oneof@ is named, the name +-- of the entire @oneof@ is prefixed in order to +-- prevent further emission of any of its fields. +-- +type Occupy (message :: Type) (name :: Symbol) (names :: [Symbol]) = + Occupy1 message name names (CardinalityOf message name) + +-- | Helps to implement 'Occupy'. +-- +-- This type family is an implementation detail of 'Occupy' +-- that is subject to change, and is exported only to assist +-- in understanding of compilation errors. +type family Occupy1 (message :: Type) (name :: Symbol) (names :: [Symbol]) + (cardinality :: Cardinality) :: [Symbol] + where + Occupy1 message name names 'Implicit = name ': names + Occupy1 message name names 'Optional = OccupiedName message name ': names + Occupy1 message name names ('Repeated _) = names + +-- | The constraint that 'moreNames' is 'names', but possibly with additional +-- names inserted. For simplicity, reordering is not currently allowed. +type family NameSublist (names :: [Symbol]) (moreNames :: [Symbol]) :: Constraint + where + NameSublist '[] _ = (() :: Constraint) + NameSublist (n ': ns) (n ': ms) = NameSublist ns ms + NameSublist ns (_ ': ms) = NameSublist ns ms + NameSublist (n ': _) '[] = TypeError + ( 'Text "NameSublist: name disappeared: " ':<>: 'ShowType n ) + +-- | Uses an empty encoding for the @oneof@s and non-@oneof@ message fields +-- that appear in the final type parameter of 'FieldsEncoder' but not the +-- previous type parameter, thereby implicitly emitting their default values. +-- +-- This function is not always required, but becomes necessary when +-- there are two code paths, one of which may write non-repeatable +-- fields and one of which leaves some implicitly defaulted. This +-- function reconciles the types of the two code paths. +-- +-- This function should not be used to introduce the name of a field +-- that is repeated or belongs to @oneof@, because doing so could +-- confuse the reader. But such misuse is unlikely to be accidental, +-- and the 'Distinct' constraint compensates by ignoring repeated +-- fields and replacing @oneof@ fields with their @oneof@ names. +omitted :: + forall (message :: Type) (names :: [Symbol]) (moreNames :: [Symbol]) . + NameSublist names moreNames => + FieldsEncoder message names moreNames +omitted = UnsafeFieldsEncoder mempty + +-- | Singleton field number type. +newtype SFieldNumber (fieldNumber :: Nat) + = UnsafeSFieldNumber { untypedSFieldNumber :: FieldNumber } + +-- | Provides the term-level value of the given field number type. +class SFieldNumberI (fieldNumber :: Nat) + where + -- | Provides the term-level value in the form of a value of the associated singleton type. + sFieldNumber :: SFieldNumber fieldNumber + +instance KnownNat fieldNumber => + SFieldNumberI fieldNumber + where + sFieldNumber = + UnsafeSFieldNumber (fieldNumber (fromInteger (natVal' (proxy# :: Proxy# fieldNumber)))) + {-# INLINABLE sFieldNumber #-} -- So that it can specialize to particular field number types. + +-- | Provides the (term-level) field number of the field +-- having the specified message type and field name. +type KnownFieldNumber message name = SFieldNumberI (NumberOf message name) + +-- | Provides the (term-level) field number of the field having +-- the message type and field name specified by the type arguments. +fieldNumberVal :: forall message name . KnownFieldNumber message name => FieldNumber +fieldNumberVal = untypedSFieldNumber (sFieldNumber @(NumberOf message name)) +{-# INLINE fieldNumberVal #-} + +-- | Provides a way to encode a field with the given name from a given type. +-- That name is interpreted in the context of a given type of message. +-- +-- More than one argument type may be supported for any given field; +-- see further discussion in the comments for 'FieldForm', to which +-- this type class delegates after determining the cardinality and +-- protobuf type of the field in question. +type Field :: Symbol -> forall {r} . TYPE r -> Type -> Constraint +class Field name a message + where + -- | Encodes the named field from the given value. + -- + -- If the field is neither @optional@, nor @repeated@, nor part of a @oneof@, then + -- its default value is represented implicitly--that is, it encodes to zero octets. + -- + -- In other cases the argument is often a container. In particular, when using + -- this method with @optional@ fields and fields within a @oneof@, the argument + -- type typically involves 'Maybe' or (if the field is always "set") 'Identity'. + -- + -- Use @TypeApplications@ to specify the field name as the first type parameter. + -- + -- The second type parameter may also be ambiguous. For example, the argument + -- expression may be an integer literal or (when using @OverloadedStrings@) + -- a string literal. @TypeApplications@ would resolve the ambiguity, but you + -- may prefer the 'Auto' wrapper or special-case helper functions such as: + -- `Proto3.Suite.Form.Encode.message`, + -- `Proto3.Suite.Form.Encode.associations`. + -- + -- See also 'fieldForm'. + field :: forall names . a -> FieldsEncoder message names (Occupy message name names) + +instance forall (name :: Symbol) +#if defined(__GLASGOW_HASKELL__) && 904 <= __GLASGOW_HASKELL__ + r (a :: TYPE r) +#else + (a :: Type) + -- Regarding the call to @coerce@, GHC 9.2.8 would say: + -- "Cannot use function with levity-polymorphic arguments". + -- So we just drop support for unlifted arguments until GHC 9.4. +#endif + (message :: Type) . + ( KnownFieldNumber message name + , FieldForm (CardinalityOf message name) (ProtoTypeOf message name) a + ) => + Field name a message + where + field :: forall names . a -> FieldsEncoder message names (Occupy message name names) + field = coerce + @(a -> Encode.MessageBuilder) + @(a -> FieldsEncoder message names (Occupy message name names)) + (fieldForm @(CardinalityOf message name) @(ProtoTypeOf message name) @a + proxy# proxy# (fieldNumberVal @message @name)) + -- Implementation Note: Using the newtype constructor would require us + -- to bind a variable of kind @TYPE r@, which is runtime-polymorphic. + -- By using a coercion we avoid runtime polymorphism restrictions. + {-# INLINE field #-} + +-- | Implements 'Field' for all fields having the specified cardinality, +-- protobuf type, and type of argument to be encoded within that field. +-- +-- Argument Type: +-- +-- For any given cardinality and protobuf type there may be multiple +-- instances of this class for different types of argument. For example, +-- a field of protobuf type @sint64@ may be encoded from any of the Haskell +-- types `Data.Int.Int8`, `Data.Int.Word8`, `Data.Int.Int16`, `Data.Int.Word16`, +-- `Data.Int.Int32`, `Data.Int.Word32`, or `Data.Int.Int64`. Note that this +-- library does /not/ provide an instance for `Data.Int.Word64` because its +-- values greater than or equal to @2 ^ 63@ cannot be represented by @sint64@. +-- +-- As another example, for fields of submessage type @m@ there +-- are type class instances for both @'MessageEncoder' m@ +-- and @`Proto3.Suite.Form.Encode.MessageEncoding` m@ +-- (wrapped in a suitable container if repeated or outside of a @oneof@). +-- +-- Arguments for optional fields are often expressed using 'Maybe', +-- and arguments for repeated fields are often expressed in using +-- 'Forward', 'Reverse', and 'Reverse'--the choice is up to the user. +-- +-- Of course, if you add instances of this type class then please be +-- sure to consider how they might overlap with existing instances, +-- and try to avoid overly broad instances that might cause ambiguity. +-- +-- However, this library does provide some general instances: +-- +-- * An instance for 'Optional' with 'Maybe' that delegates to +-- the corresponding instance for 'Optional' with 'Identity'. +-- +-- * An instance for @'Repeated' 'Unpacked'@ that delegates to +-- the corresponding instance for 'Optional' with 'Identity'. +-- +-- * An instance for @'Repeated' 'Packed'@ that delegates to 'PackedFieldForm'. +-- +-- Design Note: +-- +-- Importantly, the type parameters of this type class do not mention +-- the containing message type, field name, or field number, thus +-- allowing it to be broadly applicable to all containing message types. +-- +-- Furthermore, type class 'Field' has a general-purpose definition +-- that need not be specialized for particular message types: one that +-- makes use of 'KnownFieldNumber', 'ProtoTypeOf', and this type class +-- (though in order to simplify usage, 'Field' is a full type class, +-- not a mere constraint alias with a related function). +-- +-- In this way the only message-specific instances are of type classes +-- defined in "Proto3.Suite.Form", which declare message format without +-- specifying any policy regarding how to efficiently encode or which +-- Haskell types may be encoded. +type FieldForm :: Cardinality -> ProtoType -> forall {r} . TYPE r -> Constraint +class FieldForm cardinality protoType a + where + -- | Encodes a message field with the + -- given number from the given value. + -- + -- If the field is neither @repeated@, nor @optional@, nor + -- part of a @oneof@, then its default value is represented + -- implicitly--that is, it encodes to zero octets. + -- + -- If you apply this method to a polymorphic expression, + -- such as a literal value, then you may need to choose + -- a particular type with @TypeApplications@ or @::@. + fieldForm :: Proxy# cardinality -> Proxy# protoType -> FieldNumber -> a -> Encode.MessageBuilder + +instance FieldForm 'Optional protoType (Identity a) => + FieldForm 'Optional protoType (Maybe a) + where + fieldForm rep ty !fn = Encode.etaMessageBuilder $ + foldMap @Maybe (fieldForm rep ty fn . Identity) + {-# INLINE fieldForm #-} + +instance ( ToRepeated c e + , FieldForm 'Optional protoType (Identity e) + ) => + FieldForm ('Repeated 'Unpacked) protoType c + where + fieldForm _ ty !fn = Encode.etaMessageBuilder $ + Encode.repeatedMessageBuilder . + mapRepeated (fieldForm (proxy# :: Proxy# 'Optional) ty fn . Identity) + {-# INLINE fieldForm #-} + +-- | Ignores the preference for packed format when there is exactly one element, +-- and therefore packed format would be more verbose. (Conforming parsers must +-- accept both packed and unpacked primitives regardless of packing preference.) +instance ( ToRepeated c e + , PackedFieldForm protoType e + , FieldForm 'Optional protoType (Identity e) + ) => + FieldForm ('Repeated 'Packed) protoType c + where + fieldForm _ ty !fn (toRepeated -> !xs@(ReverseRepeated prediction reversed)) = + case prediction of + Just count + | 2 <= count -> packedFieldForm ty fn xs -- multiple packed elements + | otherwise -> fieldForm (proxy# :: Proxy# ('Repeated 'Unpacked)) ty fn xs -- 0 or 1 + Nothing -> case foldr singletonOp Empty reversed of + Empty -> mempty -- 0 elements can be expressed implicitly + Singleton x -> fieldForm (proxy# :: Proxy# 'Optional) ty fn (Identity x) -- unpacked + Multiple -> packedFieldForm ty fn xs -- multiple packed elements + where + singletonOp :: a -> Singleton a -> Singleton a + singletonOp x Empty = Singleton x + singletonOp _ _ = Multiple + {-# INLINE fieldForm #-} + +data Singleton a = Empty | Singleton a | Multiple + +instance FieldForm 'Optional ('Message inner) (Identity (MessageEncoder inner)) + where + fieldForm _ _ !fn (Identity e) = Encode.embedded fn (untypedMessageEncoder e) + {-# INLINE fieldForm #-} + +-- | This instance is rather artificial because maps are automatically +-- repeated and unpacked, with no option to specify a single key-value pair +-- as an @optional@ field or a field of a @oneof@. Hence the code generator +-- should never directly make use of this instance, but it will do so +-- indirectly via the general instance for repeated unpacked fields, +-- which will then delegate to this instance. +instance FieldForm 'Optional ('Map key value) (Identity (MessageEncoder (Association key value))) + where + fieldForm _ _ !fn (Identity a) = Encode.embedded fn (untypedMessageEncoder a) + {-# INLINE fieldForm #-} + +-- | 'FieldForm' delegates to this type class when encoding +-- packed repeated fields containing two or more elements. +type PackedFieldForm :: ProtoType -> forall {r} . TYPE r -> Constraint +class PackedFieldForm protoType a + where + -- | 'fieldForm' delegates to this method when encoding + -- packed repeated fields containing two or more elements. + packedFieldForm :: Proxy# protoType -> FieldNumber -> Repeated a -> Encode.MessageBuilder + +-- | Indicates that a wrapper type should be emitted by encoding its field, +-- as opposed to by supplying 'MessageEncoder' for the wrapper as a whole. +-- +-- We also provide specific instances of 'FieldForm' that avoid the need +-- to 'Wrap' certain commonly-used argument types, such as 'Int32'. +-- +-- See also 'Wrapper'. +newtype Wrap (a :: Type) = Wrap { unwrap :: a } + deriving stock (Foldable, Functor, Generic, Traversable) + deriving newtype (Bounded, Enum, Eq, Fractional, Integral, Ord, Num, Read, Real, Show) + +instance FieldForm 'Implicit protoType a => + FieldForm 'Optional ('Message (Wrapper protoType)) (Identity (Wrap a)) + where + fieldForm _ ty !fn (Identity (Wrap x)) = + fieldForm (proxy# :: Proxy# 'Optional) ty fn + (Identity (fieldsToMessage @(Wrapper protoType) (field @"value" x))) + {-# INLINE fieldForm #-} + +-- | Asks that its type parameter be chosen to be the most efficient Haskell type +-- that expresses the full range of possible values of the relevant protobuf field. +-- +-- This choice can be used to resolve ambiguity around polymorphic +-- literal values, or when performing a polymorphic conversion +-- from a type that is not directly encodable, such as 'Int'. +newtype Auto (a :: Type) = Auto { unauto :: a } + deriving stock (Foldable, Functor, Generic, Traversable) + deriving newtype (Bounded, Enum, Eq, Fractional, Integral, Ord, Num, Read, Real, Show) + +instantiatePackableField :: + -- | Protobuf type of kind 'ProtoType'. + TH.Q TH.Type -> + -- | 'fieldForm' argument type. + TH.Q TH.Type -> + -- | The encoder for non-repeated or unpacked fields + -- of the specified protobuf type and argument type. + TH.Q TH.Exp -> + -- | The encoder for packed fields of the specified protobuf type and argument type. + TH.Q TH.Exp -> + -- | For every promotion to this type of field: + -- 1. The argument type to before promotion. + -- 2. The conversion from that type to an argument type. + -- 3. The compatible protobuf type whose encoder we should use; + -- it must support the post-conversion type of the argument. + -- + -- NOTE: Do not convert when some source values have no semantically-equivalent + -- value to which to convert. Specifically, do not convert from signed integers + -- to unsigned integers (because negative values become positive ones), and only + -- convert from unsigned to signed when widening (because otherwise some positive + -- values become will negative ones). + -- + -- These are /not/ selected by 'Auto'. + [(TH.Q TH.Type, TH.Q TH.Exp, TH.Q TH.Type)] -> + -- | Is there a standard wrapper type? + Bool -> + TH.Q [TH.Dec] +instantiatePackableField protoType elementType encoder packedEncoder promotions hasWrapper = do + direct <- + [d| + + instance FieldForm 'Optional $protoType (Identity $elementType) + where + fieldForm _ _ = coerce + @(FieldNumber -> $elementType -> Encode.MessageBuilder) + @(FieldNumber -> Identity $elementType -> Encode.MessageBuilder) + $encoder + {-# INLINE fieldForm #-} + + instance FieldForm 'Implicit $protoType $elementType + where + fieldForm _ ty !fn x + | isDefault x = mempty + | otherwise = fieldForm (proxy# :: Proxy# 'Optional) ty fn (Identity x) + {-# INLINE fieldForm #-} + + instance (a ~ $elementType) => + FieldForm 'Optional $protoType (Identity (Auto a)) + where + fieldForm = coerce (fieldForm @'Optional @($protoType) @(Identity a)) + {-# INLINE fieldForm #-} + + instance (a ~ $elementType) => + FieldForm 'Implicit $protoType (Auto a) + where + fieldForm = coerce (fieldForm @'Implicit @($protoType) @a) + {-# INLINE fieldForm #-} + + instance PackedFieldForm $protoType $elementType + where + packedFieldForm _ = $packedEncoder + {-# INLINE packedFieldForm #-} + + instance (a ~ $elementType) => + PackedFieldForm $protoType (Auto a) + where + packedFieldForm = coerce (packedFieldForm @($protoType) @a) + {-# INLINE packedFieldForm #-} + + |] + + promoted <- for promotions $ \(supportedType, conversion, compatibleProtoType) -> + [d| + + instance FieldForm 'Optional $protoType (Identity $supportedType) + where + fieldForm rep _ !fn (Identity x) = + fieldForm rep (proxy# :: Proxy# $compatibleProtoType) fn (Identity ($conversion x)) + {-# INLINE fieldForm #-} + + instance FieldForm 'Implicit $protoType $supportedType + where + fieldForm rep _ !fn x = + fieldForm rep (proxy# :: Proxy# $compatibleProtoType) fn ($conversion x) + {-# INLINE fieldForm #-} + + instance PackedFieldForm $protoType $supportedType + where + packedFieldForm _ !fn xs = + packedFieldForm (proxy# :: Proxy# $compatibleProtoType) fn (fmap $conversion xs) + {-# INLINE packedFieldForm #-} + + |] + + wrapped <- if not hasWrapper then pure [] else + [d| + + instance FieldForm 'Optional ('Message (Wrapper $protoType)) (Identity $elementType) + where + fieldForm = coerce + (fieldForm @'Optional @('Message (Wrapper $protoType)) @(Identity (Wrap $elementType))) + {-# INLINE fieldForm #-} + + instance (a ~ $elementType) => + FieldForm 'Optional ('Message (Wrapper $protoType)) (Identity (Auto a)) + where + fieldForm = coerce + (fieldForm @'Optional @('Message (Wrapper $protoType)) @(Identity (Wrap a))) + {-# INLINE fieldForm #-} + + |] + + wrappedPromoted <- if not hasWrapper then pure [] else + for promotions $ \(supportedType, _, _) -> do + [d| + + instance FieldForm 'Optional ('Message (Wrapper $protoType)) (Identity $supportedType) + where + fieldForm = coerce + (fieldForm @'Optional @('Message (Wrapper $protoType)) @(Identity (Wrap $supportedType))) + {-# INLINE fieldForm #-} + + |] + + pure $ direct ++ concat promoted ++ wrapped ++ concat wrappedPromoted + +instantiateStringOrBytesField :: + -- | Protobuf type of kind 'ProtoType'. + TH.Q TH.Type -> + -- | 'fieldForm' argument type. + TH.Q TH.Type -> + -- | The encoder for fields of the specified protobuf type and argument type. + TH.Q TH.Exp -> + -- | Additional argument types and their associated encoders. + -- These are /not/ selected by 'Auto'. + [(TH.Q TH.Type, TH.Q TH.Exp)] -> + TH.Q [TH.Dec] +instantiateStringOrBytesField protoType argumentType encoder additional = do + preferred <- [d| + + instance FieldForm 'Optional $protoType (Identity $argumentType) + where + fieldForm _ _ = coerce + @(FieldNumber -> $argumentType -> Encode.MessageBuilder) + @(FieldNumber -> Identity $argumentType -> Encode.MessageBuilder) + $encoder + {-# INLINE fieldForm #-} + + instance FieldForm 'Implicit $protoType $argumentType + where + fieldForm _ ty !fn x + | isDefault x = mempty + | otherwise = fieldForm (proxy# :: Proxy# 'Optional) ty fn (Identity x) + {-# INLINE fieldForm #-} + + instance (a ~ $argumentType) => + FieldForm 'Optional $protoType (Identity (Auto a)) + where + fieldForm = coerce (fieldForm @'Optional @($protoType) @(Identity a)) + {-# INLINE fieldForm #-} + + instance (a ~ $argumentType) => + FieldForm 'Implicit $protoType (Auto a) + where + fieldForm = coerce (fieldForm @'Implicit @($protoType) @a) + {-# INLINE fieldForm #-} + + instance FieldForm 'Optional ('Message (Wrapper $protoType)) (Identity $argumentType) + where + fieldForm = coerce + (fieldForm @'Optional @('Message (Wrapper $protoType)) @(Identity (Wrap $argumentType))) + {-# INLINE fieldForm #-} + + instance (a ~ $argumentType) => + FieldForm 'Optional ('Message (Wrapper $protoType)) (Identity (Auto a)) + where + fieldForm = coerce + (fieldForm @'Optional @('Message (Wrapper $protoType)) @(Identity (Wrap a))) + {-# INLINE fieldForm #-} + + |] + + supported <- for additional $ \(supportedType, additionalEncoder) -> [d| + + instance FieldForm 'Optional $protoType (Identity $supportedType) + where + fieldForm _ _ = coerce + @(FieldNumber -> $supportedType -> Encode.MessageBuilder) + @(FieldNumber -> Identity $supportedType -> Encode.MessageBuilder) + $additionalEncoder + {-# INLINE fieldForm #-} + + instance FieldForm 'Implicit $protoType $supportedType + where + fieldForm _ ty !fn x + | isDefault x = mempty + | otherwise = fieldForm (proxy# :: Proxy# 'Optional) ty fn (Identity x) + {-# INLINE fieldForm #-} + + instance FieldForm 'Optional ('Message (Wrapper $protoType)) (Identity $supportedType) + where + fieldForm = coerce + (fieldForm @'Optional @('Message (Wrapper $protoType)) @(Identity (Wrap $supportedType))) + {-# INLINE fieldForm #-} + + |] + + pure $ preferred ++ concat supported diff --git a/src/Proto3/Suite/Haskell/Parser.hs b/src/Proto3/Suite/Haskell/Parser.hs new file mode 100644 --- /dev/null +++ b/src/Proto3/Suite/Haskell/Parser.hs @@ -0,0 +1,248 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ViewPatterns #-} + +module Proto3.Suite.Haskell.Parser + ( Logger + , initLogger + , parseModule + , renderSDoc + ) where + +import qualified GHC.Data.EnumSet as EnumSet +import GHC.Data.StringBuffer (StringBuffer) +import GHC.Driver.Session (languageExtensions) +import qualified GHC.Hs +import qualified GHC.Parser +import GHC.Parser.Lexer (P(..), PState, ParseResult(..)) +import GHC.Types.SrcLoc (Located, RealSrcLoc) +import GHC.Utils.Outputable (SDoc) + +#if MIN_VERSION_ghc_lib_parser(9,8,0) +import qualified GHC.Driver.Errors (printMessages) +import GHC.Parser.Errors.Types (PsMessage) +import GHC.Parser.Lexer (getPsMessages, initParserState, mkParserOpts) +import GHC.Types.Error (Messages, NoDiagnosticOpts(..), partitionMessages, unionMessages) +import GHC.Utils.Error (DiagOpts, emptyDiagOpts) +import GHC.Utils.Logger (Logger, initLogger) +import GHC.Utils.Outputable (defaultSDocContext, renderWithContext) +#elif MIN_VERSION_ghc_lib_parser(9,6,0) +import qualified GHC.Driver.Errors (printMessages) +import GHC.Parser.Errors.Types (PsMessage) +import GHC.Parser.Lexer (getPsMessages, initParserState, mkParserOpts) +import GHC.Types.Error (Messages, NoDiagnosticOpts(..), partitionMessages, unionMessages) +import GHC.Utils.Error (DiagOpts(..)) +import GHC.Utils.Logger (Logger, initLogger) +import GHC.Utils.Outputable (defaultSDocContext, renderWithContext) +#elif MIN_VERSION_ghc_lib_parser(9,4,0) +import qualified GHC.Driver.Errors (printMessages) +import GHC.Parser.Errors.Types (PsMessage) +import GHC.Parser.Lexer (getPsMessages, initParserState, mkParserOpts) +import GHC.Types.Error (Messages, partitionMessages, unionMessages) +import GHC.Utils.Error (DiagOpts(..)) +import GHC.Utils.Logger (Logger, initLogger) +import GHC.Utils.Outputable (defaultSDocContext, renderWithContext) +#else +import Control.Arrow ((***)) +import Data.Foldable (traverse_) +import GHC.ByteOrder (targetByteOrder) +import GHC.Data.Bag (Bag) +import GHC.Driver.Session + (DynFlags(..), FileSettings(..), GhcNameVersion(..), + LlvmConfig(..), Settings(..), defaultDynFlags) +import GHC.Parser.Errors.Ppr (pprError, pprWarning) +import GHC.Parser.Lexer (getMessages, initParserState, mkParserOpts) +import GHC.Platform (ArchOS(..)) +import GHC.Settings (Platform(..), PlatformMisc(..), ToolSettings(..)) +import GHC.Types.Error (DecoratedSDoc, MsgEnvelope(..), renderDiagnostic) +import GHC.Utils.Error (formatBulleted, sortMsgBag) +import GHC.Utils.Fingerprint (fingerprint0) +import GHC.Utils.Logger (Logger, initLogger, putLogMsg) +import GHC.Utils.Outputable (defaultSDocContext, mkErrStyle, renderWithContext, withPprStyle) +#endif + +-- | Parses the module with the specified location and content, +-- returning 'Nothing' on parse failure. Errors and warnings +-- are sent to the given 'Logger', except on GHC 9.0, which +-- would require a 'DynFlags' in order to report messages. +-- Unfortunately, creating a 'DynFlags' would require a directory +-- containing a GHC installation; we do not wish to require that. +parseModule :: + Logger -> + RealSrcLoc -> + StringBuffer -> + IO (Maybe (Located (GHC.Hs.HsModule +#if MIN_VERSION_ghc_lib_parser(9,6,0) + GHC.Hs.GhcPs +#endif + ))) +parseModule logger location input = do + case unP GHC.Parser.parseModule initialState of + POk _finalState m -> do + printWarningsAndErrors logger diagOpts _finalState + pure (Just m) + PFailed _finalState -> do + printWarningsAndErrors logger diagOpts _finalState + pure Nothing + where + exts = EnumSet.fromList (languageExtensions Nothing) +#if MIN_VERSION_ghc_lib_parser(9,4,0) + diagOpts = +#if MIN_VERSION_ghc_lib_parser(9,8,0) + emptyDiagOpts +#else + DiagOpts + { diag_warning_flags = mempty + , diag_fatal_warning_flags = mempty + , diag_warn_is_error = False + , diag_reverse_errors = False + , diag_max_errors = Nothing + , diag_ppr_ctx = defaultSDocContext + } +#endif + parserOpts = mkParserOpts exts diagOpts [] False True True True + initialState = initParserState parserOpts input location +#else + diagOpts = DiagOpts + parserOpts = mkParserOpts EnumSet.empty exts False True True True + initialState = initParserState parserOpts input location +#endif + +printWarningsAndErrors :: Logger -> DiagOpts -> PState -> IO () +printWarningsAndErrors logger diagOpts state = do +#if MIN_VERSION_ghc_lib_parser(9,4,0) + let (ws, es) = getPsMessages state + let (warnings, unionMessages es -> errors) = partitionMessages ws +#else + let (warnings, errors) = (fmap pprWarning *** fmap pprError) (getMessages state) +#endif + printMessages logger diagOpts warnings + printMessages logger diagOpts errors + +#if MIN_VERSION_ghc_lib_parser(9,6,0) + +printMessages :: Logger -> DiagOpts -> Messages PsMessage -> IO () +printMessages logger = GHC.Driver.Errors.printMessages logger NoDiagnosticOpts + +#elif MIN_VERSION_ghc_lib_parser(9,4,0) + +printMessages :: Logger -> DiagOpts -> Messages PsMessage -> IO () +printMessages = GHC.Driver.Errors.printMessages + +#else + +printMessages :: Logger -> DiagOpts -> Bag (MsgEnvelope DecoratedSDoc) -> IO () +printMessages logger _ = traverse_ report . sortMsgBag Nothing + where + report MsgEnvelope + { errMsgContext = errCtxt + , errMsgDiagnostic = diagnostic + , errMsgReason = reason + , errMsgSeverity = severity + , errMsgSpan = sp } = + putLogMsg logger renderingDynFlags reason severity sp $ + withPprStyle (mkErrStyle errCtxt) $ + formatBulleted defaultSDocContext (renderDiagnostic diagnostic) + +#endif + +renderSDoc :: SDoc -> String +renderSDoc = renderWithContext defaultSDocContext + +#if !MIN_VERSION_ghc_lib_parser(9,4,0) + +data DiagOpts = DiagOpts + +-- | 'DynFlags' suitable only for rendering +-- Haskell source and diagnostic messages. +-- +-- NOTE: For use with GHC 9.0 only. These flags are rather questionable +-- all of the tools direction information consists of placeholders so +-- that compile-proto-file does not require an actual GHC installation. +renderingDynFlags :: DynFlags +renderingDynFlags = defaultDynFlags placeholderSettings placeholderLlvmConfig + where + archUnknown = read "ArchUnknown" + osUnknown = read "OSUnknown" + placeholderSettings = Settings + { sGhcNameVersion = GhcNameVersion "compile-proto-file" "v?" + , sFileSettings = FileSettings + { fileSettings_ghcUsagePath = mempty + , fileSettings_ghciUsagePath = mempty + , fileSettings_toolDir = Nothing + , fileSettings_topDir = mempty + , fileSettings_tmpDir = mempty + , fileSettings_globalPackageDatabase = mempty + } + , sTargetPlatform = Platform + { platformArchOS = ArchOS archUnknown osUnknown + , platformWordSize = read "8" + , platformByteOrder = targetByteOrder + , platformUnregisterised = True + , platformHasGnuNonexecStack = False + , platformHasIdentDirective = False + , platformHasSubsectionsViaSymbols = False + , platformIsCrossCompiling = True + , platformLeadingUnderscore = True + , platformTablesNextToCode = False + , platform_constants = Nothing + } + , sToolSettings = ToolSettings + { toolSettings_ldSupportsCompactUnwind = False + , toolSettings_ldSupportsBuildId = False + , toolSettings_ldSupportsFilelist = False + , toolSettings_ldIsGnuLd = False + , toolSettings_ccSupportsNoPie = False + , toolSettings_pgm_L = mempty + , toolSettings_pgm_P = mempty + , toolSettings_pgm_F = mempty + , toolSettings_pgm_c = mempty + , toolSettings_pgm_a = mempty + , toolSettings_pgm_l = mempty + , toolSettings_pgm_lm = mempty + , toolSettings_pgm_dll = mempty + , toolSettings_pgm_T = mempty + , toolSettings_pgm_windres = mempty + , toolSettings_pgm_libtool = mempty + , toolSettings_pgm_ar = mempty + , toolSettings_pgm_otool = mempty + , toolSettings_pgm_install_name_tool = mempty + , toolSettings_pgm_ranlib = mempty + , toolSettings_pgm_lo = mempty + , toolSettings_pgm_lc = mempty + , toolSettings_pgm_lcc = mempty + , toolSettings_pgm_i = mempty + , toolSettings_opt_L = mempty + , toolSettings_opt_P = mempty + , toolSettings_opt_P_fingerprint = fingerprint0 + , toolSettings_opt_F = mempty + , toolSettings_opt_c = mempty + , toolSettings_opt_cxx = mempty + , toolSettings_opt_a = mempty + , toolSettings_opt_l = mempty + , toolSettings_opt_lm = mempty + , toolSettings_opt_windres = mempty + , toolSettings_opt_lo = mempty + , toolSettings_opt_lc = mempty + , toolSettings_opt_lcc = mempty + , toolSettings_opt_i = mempty + , toolSettings_extraGccViaCFlags = mempty + } + , sPlatformMisc = PlatformMisc + { platformMisc_targetPlatformString = mempty + , platformMisc_ghcWithInterpreter = False + , platformMisc_ghcWithSMP = False + , platformMisc_ghcRTSWays = mempty + , platformMisc_libFFI = False + , platformMisc_ghcRtsWithLibdw = False + , platformMisc_llvmTarget = mempty + } + , sRawSettings = mempty + } + + placeholderLlvmConfig = LlvmConfig + { llvmTargets = mempty + , llvmPasses = mempty + } + +#endif diff --git a/src/Proto3/Suite/JSONPB/Class.hs b/src/Proto3/Suite/JSONPB/Class.hs --- a/src/Proto3/Suite/JSONPB/Class.hs +++ b/src/Proto3/Suite/JSONPB/Class.hs @@ -70,7 +70,7 @@ ToJSON (..), Value (..), ToJSON1(..), FromJSON1(..), ToJSONKey(..), - decode, eitherDecode, json, + decode, eitherDecode, (.!=)) import qualified Data.Aeson.Encoding as E import qualified Data.Aeson.Encoding.Internal as E @@ -80,7 +80,7 @@ #if MIN_VERSION_aeson(2,0,0) import qualified Data.Aeson.Key as A #endif -import qualified Data.Aeson.Parser as A (eitherDecodeWith) +import qualified Data.Aeson.Parser as A (eitherDecodeWith, json) import qualified Data.Aeson.Types as A (Object, Pair, Parser, Series, explicitParseField, @@ -117,9 +117,9 @@ import Proto3.Suite.Class (HasDefault (def, isDefault), Named (nameOf)) import Proto3.Suite.Types (Enumerated(..), Fixed(..), - Nested(..), NestedVec(..), - PackedVec(..), Signed(..), - UnpackedVec(..)) + ForceEmit(..), Nested(..), + NestedVec(..), PackedVec(..), + Signed(..), UnpackedVec(..)) import qualified Proto3.Suite.Types import Proto3.Wire.Class (ProtoEnum(..)) import Test.QuickCheck.Arbitrary (Arbitrary(..)) @@ -551,6 +551,12 @@ deriving via (Maybe a) instance ToJSONPB a => ToJSONPB (Nested a) -------------------------------------------------------------------------------- +-- Instances for optional fields + +deriving newtype instance FromJSONPB a => FromJSONPB (ForceEmit a) +deriving newtype instance ToJSONPB a => ToJSONPB (ForceEmit a) + +-------------------------------------------------------------------------------- -- Instances for map deriving newtype instance A.FromJSONKey a => A.FromJSONKey (Fixed a) @@ -588,11 +594,23 @@ #endif instance (A.ToJSONKey k, ToJSONPB k, ToJSONPB v) => ToJSONPB (M.Map k v) where - toJSONPB m opts = A.liftToJSON @(M.Map k) (`toJSONPB` opts) (A.Array . V.fromList . map (`toJSONPB` opts)) m - toEncodingPB m opts = A.liftToEncoding @(M.Map k) (`toEncodingPB` opts) (E.list (`toEncodingPB` opts)) m + toJSONPB m opts = A.liftToJSON @(M.Map k) +#if MIN_VERSION_aeson(2,2,0) + (const False) -- Unless and until we test for the protobuf default value. +#endif + (`toJSONPB` opts) (A.Array . V.fromList . map (`toJSONPB` opts)) m + toEncodingPB m opts = A.liftToEncoding @(M.Map k) +#if MIN_VERSION_aeson(2,2,0) + (const False) -- Unless and until we test for the protobuf default value. +#endif + (`toEncodingPB` opts) (E.list (`toEncodingPB` opts)) m instance (Ord k, A.FromJSONKey k, FromJSONPB k, FromJSONPB v) => FromJSONPB (M.Map k v) where - parseJSONPB = A.liftParseJSON @(M.Map k) parseJSONPB parseList + parseJSONPB = A.liftParseJSON @(M.Map k) +#if MIN_VERSION_aeson(2,2,0) + Nothing -- Unless and until we decide to use the protobuf default value. +#endif + parseJSONPB parseList where parseList (A.Array a) = traverse parseJSONPB (V.toList a) parseList v = A.typeMismatch "not a list" v diff --git a/src/Proto3/Suite/Types.hs b/src/Proto3/Suite/Types.hs --- a/src/Proto3/Suite/Types.hs +++ b/src/Proto3/Suite/Types.hs @@ -2,12 +2,12 @@ {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE ExplicitNamespaces #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} -{-# LANGUAGE ExplicitNamespaces #-} module Proto3.Suite.Types ( @@ -17,6 +17,8 @@ -- * Enumerable Types , Enumerated(..) + , codeFromEnumerated + , codeToEnumerated -- * String and Bytes Types , String(..) @@ -34,7 +36,7 @@ import Control.Applicative import Control.DeepSeq (NFData) import GHC.Exts (IsList(..)) -import GHC.Generics +import GHC.Generics (Generic) import Data.Function (on) import Data.Int (Int32) import qualified Data.Vector as V @@ -73,6 +75,18 @@ i <- arbitrary return . Enumerated $ maybe (Left i) Right (toProtoEnumMay i) +-- | Pass through those values that are outside the enum range; +-- this is for forward compatibility as enumerations are extended. +codeFromEnumerated :: ProtoEnum e => Enumerated e -> Int32 +codeFromEnumerated = either id fromProtoEnum . enumerated +{-# INLINE codeFromEnumerated #-} + +-- | Values inside the enum range are in Right, the rest in Left; +-- this is for forward compatibility as enumerations are extended. +codeToEnumerated :: ProtoEnum e => Int32 -> Enumerated e +codeToEnumerated code = Enumerated (maybe (Left code) Right (toProtoEnumMay code)) +{-# INLINE codeToEnumerated #-} + -- | 'String' provides a way to indicate that the given type expresses -- a Protobuf string scalar. @'String' a@ may have type class instances -- that are more specific to Protobuf uses than those of @a@. @@ -131,9 +145,9 @@ deriving (Show, Eq, Ord, Generic, NFData, Monoid, Arbitrary, Functor, Foldable, Traversable, Applicative, Alternative, Monad, Semigroup) --- | 'ForceEmit' provides a way to force emission of field values, even when --- default-value semantics states otherwise. Used when serializing oneof --- subfields. +-- | 'ForceEmit' provides a way to force emission of field values, +-- even when they have the default value. Used for @optional@ fields +-- and fields that are part of a @oneof@. newtype ForceEmit a = ForceEmit{ forceEmit :: a } deriving (Show, Eq, Ord, Generic, NFData, Monoid, Arbitrary, Functor, Foldable, Traversable, Semigroup) diff --git a/test-files/with_repeated_signed.bin b/test-files/with_repeated_signed.bin Binary files a/test-files/with_repeated_signed.bin and b/test-files/with_repeated_signed.bin differ diff --git a/tests/ArbitraryGeneratedTestTypes.hs b/tests/ArbitraryGeneratedTestTypes.hs --- a/tests/ArbitraryGeneratedTestTypes.hs +++ b/tests/ArbitraryGeneratedTestTypes.hs @@ -11,8 +11,10 @@ import Test.QuickCheck.Arbitrary.Generic (genericArbitrary, Arbitrary (..)) import TestProto import qualified TestProtoImport +import qualified TestProtoNegativeEnum import qualified TestProtoOneof import qualified TestProtoOneofImport +import qualified TestProtoOptional instance Arbitrary Trivial where arbitrary = Trivial <$> arbitrary @@ -163,3 +165,43 @@ [ TestProtoOneofImport.WithOneofPickOneA <$> fmap fromString arbitrary , TestProtoOneofImport.WithOneofPickOneB <$> arbitrary ] + +instance Arbitrary TestProtoNegativeEnum.NegativeEnum where + arbitrary = QC.elements + [ TestProtoNegativeEnum.NegativeEnumNEGATIVE_ENUM_0 + , TestProtoNegativeEnum.NegativeEnumNEGATIVE_ENUM_NEGATIVE_1 + , TestProtoNegativeEnum.NegativeEnumNEGATIVE_ENUM_1 + , TestProtoNegativeEnum.NegativeEnumNEGATIVE_ENUM_NEGATIVE_128 + , TestProtoNegativeEnum.NegativeEnumNEGATIVE_ENUM_128 + ] + +instance Arbitrary TestProtoNegativeEnum.WithNegativeEnum where + arbitrary = + TestProtoNegativeEnum.WithNegativeEnum + <$> arbitrary + +instance Arbitrary TestProtoOptional.Submessage where + arbitrary = + TestProtoOptional.Submessage + <$> arbitrary + +instance Arbitrary TestProtoOptional.WithOptional where + arbitrary = + TestProtoOptional.WithOptional + <$> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary diff --git a/tests/Main.hs b/tests/Main.hs --- a/tests/Main.hs +++ b/tests/Main.hs @@ -1,8 +1,17 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE OverloadedLists #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE CPP #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ImplicitParams #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-} @@ -12,23 +21,39 @@ import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as BC import qualified Data.ByteString.Lazy as BL +import qualified Data.ByteString.Short as BS import Data.Either (isRight) +import Data.Functor.Identity (Identity(..)) +import Data.Int (Int8, Int16, Int32, Int64) import qualified Data.List.NonEmpty as NE +import Data.Proxy (Proxy(..)) import Data.String +import qualified Data.Text.Short +import Data.Typeable (Typeable, showsTypeRep, typeRep) +import Data.Word (Word8, Word16, Word32, Word64) +import qualified Data.Vector as V import GHC.Exts (fromList, Proxy#) +import GHC.TypeLits (Nat, SomeNat(..), Symbol, TypeError, someNatVal) import Proto3.Suite +import qualified Proto3.Suite.Form as Form +import qualified Proto3.Suite.Form.Encode as FormE +import Proto3.Suite.Haskell.Parser (Logger, initLogger) +import qualified Proto3.Suite.JSONPB.Class as JSONPB import Proto3.Wire.Decode (ParseError) import qualified Proto3.Wire.Decode as Decode +import qualified Proto3.Wire.Reverse as RB import Proto3.Wire.Types as P import qualified Test.DocTest -import Test.QuickCheck (Arbitrary, Property, arbitrary, - counterexample, oneof) +import Test.QuickCheck (Arbitrary, Property, (.&&.), arbitrary, choose, + counterexample, forAll, oneof, property) import Test.Tasty -import Test.Tasty.HUnit (Assertion, assertBool, testCase, - (@=?), (@?=)) +import Test.Tasty.HUnit (Assertion, assertBool, assertEqual, + testCase, (@=?), (@?=)) import Test.Tasty.QuickCheck (testProperty, (===)) import TestCodeGen import qualified TestProto as TP +import qualified TestProtoOneof as TPO +import qualified TestProtoOneofImport as TPOI #ifdef DHALL import TestDhall @@ -36,23 +61,29 @@ import qualified Test.Proto.Generate.Name import qualified Test.Proto.Parse.Option +import qualified Test.Proto.Interval +import Test.Proto.ToEncoder (Iterator(Forward, Vector), + Stripping(Keep, Strip), ToEncoder(..)) -- ----------------------------------------------------------------------------- main :: IO () -main = defaultMain tests +main = do + logger <- initLogger + defaultMain (tests logger) -tests :: TestTree -tests = testGroup "Tests" +tests :: Logger -> TestTree +tests logger = testGroup "Tests" [ docTests , qcProperties , encodeUnitTests , decodeUnitTests , parserUnitTests , dotProtoUnitTests - , codeGenTests - , Test.Proto.Generate.Name.tests - , Test.Proto.Parse.Option.tests + , codeGenTests logger + , Test.Proto.Generate.Name.testTree + , Test.Proto.Parse.Option.testTree + , Test.Proto.Interval.testTree #ifdef DHALL , dhallTests @@ -67,7 +98,10 @@ putStrLn "Running all doctests..." Test.DocTest.doctest [ "--verbose" + , "-package" + , "ghc-lib-parser" , "-isrc" + , "-XBlockArguments" #ifdef SWAGGER #ifdef SWAGGER_WRAPPER_FORMAT , "-isrc/swagger-wrapper-format" @@ -133,6 +167,16 @@ encodeUnitTests :: TestTree encodeUnitTests = testGroup "Encoder unit tests" [ encoderMatchesGoldens + , encoderPromotionsAndAuto + , encodeBytesFromBuilder + , encodeMessageReflection + , encodeCachedSubmessage + , testShowMessageEncoder + , testShowMessageEncoding + , testToJSONPBMessageEncoder + , testToJSONPBMessageEncoding + , testFromJSONPBMessageEncoder + , testFromJSONPBMessageEncoding ] -- TODO: We should consider generating the reference encodings @@ -148,7 +192,13 @@ , check "with_enum0.bin" $ TP.WithEnum $ Enumerated $ Right $ TP.WithEnum_TestEnumENUM1 , check "with_enum1.bin" $ TP.WithEnum $ Enumerated $ Right $ TP.WithEnum_TestEnumENUM2 , check "with_repetition.bin" $ TP.WithRepetition [1..5] - , check "with_repeated_signed.bin" $ TP.WithRepeatedSigned [0,1,-1,2,-2] [0,1,-1,2,-2] + , check "with_repeated_signed.bin" $ TP.WithRepeatedSigned + [ 0, -1, 1, -2, 2, + 0x3FFFFFFF, -0x40000000, 0x40000000, -0x40000001, + 0x7FFFFFFF, -0x7FFFFFFF - 1 ] + [ 0, -1, 1, -2, 2, + 0x3FFFFFFFFFFFFFFF, -0x4000000000000000, 0x4000000000000000, -0x4000000000000001, + 0x7FFFFFFFFFFFFFFF, -0x7FFFFFFFFFFFFFFF - 1 ] , check "with_bytes.bin" $ TP.WithBytes (BC.pack "abc") (fromList $ map BC.pack ["abc","123"]) , check "with_nesting_repeated.bin" $ TP.WithNestingRepeated [ TP.WithNestingRepeated_Nested "123abc" 123456 [1,2,3,4] [5,6,7,8] @@ -158,8 +208,518 @@ where check fp v = testCase fp $ do goldenEncoding <- BL.readFile (testFilesPfx <> fp) - toLazyByteString v @?= goldenEncoding + assertEqual (show fp ++ ": encoding from intermediate representation") + goldenEncoding (toLazyByteString v) + -- NOTE: We skip the 'Identity' iterator in this test because we expect it + -- will create longer output for packed fields than the golden result when + -- there is more than one element of the repetition--in which case our test + -- code misuses 'Identity' by using it repeatedly, once for each element. + -- Though suboptimal, the resulting encoding remains decodable by parsers + -- that adhere to the protobuf specification. We check that decodability + -- in other tests that pair a Haskell encoder with a Python decoder. + assertEqual (show fp ++ ": direct encoding, Forward iterator, keep wrappers") + goldenEncoding $ FormE.messageEncoderToLazyByteString $ + let ?iterator = Forward + ?stripping = Keep + in toEncoder v + assertEqual (show fp ++ ": direct encoding, Forward iterator, strip wrappers") + goldenEncoding $ FormE.messageEncoderToLazyByteString $ + let ?iterator = Forward + ?stripping = Strip + in toEncoder v + assertEqual (show fp ++ ": direct encoding, Vector iterator, keep wrappers") + goldenEncoding $ FormE.messageEncoderToLazyByteString $ + let ?iterator = Vector + ?stripping = Keep + in toEncoder v + assertEqual (show fp ++ ": direct encoding, Vector iterator, strip wrappers") + goldenEncoding $ FormE.messageEncoderToLazyByteString $ + let ?iterator = Vector + ?stripping = Strip + in toEncoder v +-- Simulated protobuf message type having a single field named @myBytes@ of +-- type @bytes@ with field number @8@ and the specified 'Form.Cardinality'. +data MyWithBytes (r :: Form.Cardinality) + +type instance Form.NamesOf (MyWithBytes r) = '["x"] + +type instance Form.NumberOf (MyWithBytes r) name = MyWithBytes_NumberOf r name + +type family MyWithBytes_NumberOf (r :: Form.Cardinality) (name :: Symbol) :: Nat + where + MyWithBytes_NumberOf _ "myBytes" = 8 + MyWithBytes_NumberOf r name = TypeError (Form.FieldNotFound (MyWithBytes r) name) + +type instance Form.ProtoTypeOf (MyWithBytes r) name = MyWithBytes_ProtoTypeOf r name + +type family MyWithBytes_ProtoTypeOf (r :: Form.Cardinality) (name :: Symbol) :: Form.ProtoType + where + MyWithBytes_ProtoTypeOf _ "myBytes" = 'Form.Bytes + MyWithBytes_ProtoTypeOf r name = TypeError (Form.FieldNotFound (MyWithBytes r) name) + +type instance Form.OneOfOf (MyWithBytes r) name = MyWithBytes_OneOfOf r name + +type family MyWithBytes_OneOfOf (r :: Form.Cardinality) (name :: Symbol) :: Symbol + where + MyWithBytes_OneOfOf 'Form.Optional "myBytes" = "pickOne" + MyWithBytes_OneOfOf 'Form.Optional "pickOne" = "pickOne" + MyWithBytes_OneOfOf r "myBytes" = "" + MyWithBytes_OneOfOf r name = TypeError (Form.FieldOrOneOfNotFound (MyWithBytes r) name) + +type instance Form.CardinalityOf (MyWithBytes r) name = MyWithBytes_CardinalityOf r name + +type family MyWithBytes_CardinalityOf (r :: Form.Cardinality) (name :: Symbol) :: Form.Cardinality + where + MyWithBytes_CardinalityOf r "myBytes" = r + MyWithBytes_CardinalityOf 'Form.Optional "pickOne" = 'Form.Optional + MyWithBytes_CardinalityOf r name = TypeError (Form.FieldOrOneOfNotFound (MyWithBytes r) name) + +encodeBytesFromBuilder :: TestTree +encodeBytesFromBuilder = testCase "bytes from builder" $ do + assertEqual "implicitly empty" + (enc @'Form.Implicit (mempty :: RB.BuildR)) "" + assertEqual "implicit but nonempty" + (enc @'Form.Implicit (RB.byteString "xyz")) "B\ETXxyz" + assertEqual "unset optional" + (enc @'Form.Optional (Nothing :: Maybe RB.BuildR)) "" + assertEqual "set empty optional" + (enc @'Form.Optional (Just (mempty :: RB.BuildR))) "B\NUL" + assertEqual "set nonempty optional" + (enc @'Form.Optional (Just (RB.byteString "xyz"))) "B\ETXxyz" + assertEqual "zero repetitions" + (enc @('Form.Repeated 'Form.Unpacked) + ([] :: [RB.BuildR])) + "" + assertEqual "single empty" + (enc @('Form.Repeated 'Form.Unpacked) + ([mempty] :: [RB.BuildR])) + "B\NUL" + assertEqual "double empty" + (enc @('Form.Repeated 'Form.Unpacked) + ([mempty, mempty] :: [RB.BuildR])) + "B\NULB\NUL" + assertEqual "empty nonempty" + (enc @('Form.Repeated 'Form.Unpacked) + ([mempty, RB.byteString "xyz"] :: [RB.BuildR])) + "B\NULB\ETXxyz" + assertEqual "nonempty empty" + (enc @('Form.Repeated 'Form.Unpacked) + (V.fromList [RB.byteString "uv", mempty])) + "B\STXuvB\NUL" + assertEqual "double nonempty" + (enc @('Form.Repeated 'Form.Unpacked) + (V.fromList [RB.byteString "uv", RB.byteString "xyz"])) + "B\STXuvB\ETXxyz" + where + enc :: + forall r a . + ( FormE.Distinct (MyWithBytes r) (FormE.Occupy (MyWithBytes r) "myBytes" '[]) + , FormE.Field "myBytes" a (MyWithBytes r) + ) => + a -> + BL.ByteString + enc = + FormE.messageEncoderToLazyByteString . + FormE.fieldsToMessage . + FormE.field @"myBytes" @a @(MyWithBytes r) + +encodeMessageReflection :: TestTree +encodeMessageReflection = testCase "messageReflection" $ do + let msg = TP.Trivial 123 + FormE.messageEncoderToLazyByteString (FormE.messageReflection msg) @?= toLazyByteString msg + +encodeCachedSubmessage :: TestTree +encodeCachedSubmessage = testGroup "Cached Submessages" + [ testOptional + , testRepeated + , testOneof + ] + where + testOptional :: TestTree + testOptional = testCase "cached optional submessage" $ do + let trivial = TP.Trivial 123 + wrappedTrivial = FormE.fieldsToMessage @TP.WrappedTrivial $ + FormE.field @"trivial" (Just (FormE.messageCache trivial)) + FormE.messageEncoderToLazyByteString wrappedTrivial @?= + toLazyByteString (TP.WrappedTrivial (Just trivial)) + + testRepeated :: TestTree + testRepeated = testCase "cached repeated submessage" $ do + let trivials :: V.Vector TP.MapTestEmulation_Trivial + trivials = + [ TP.MapTestEmulation_Trivial 15 (Just (TP.WrappedTrivial (Just (TP.Trivial 465)))) + , TP.MapTestEmulation_Trivial 25 (Just (TP.WrappedTrivial (Just (TP.Trivial 789)))) + ] + mapTestEmulation = FormE.fieldsToMessage @TP.MapTestEmulation $ + FormE.field @"trivial" (V.map FormE.messageCache trivials) + FormE.messageEncoderToLazyByteString mapTestEmulation @?= + toLazyByteString (TP.MapTestEmulation mempty trivials mempty) + + testOneof :: TestTree + testOneof = testCase "cached submessage within oneof" $ do + let withOneof = TPOI.WithOneof (Just (TPOI.WithOneofPickOneB 123)) + withImported = FormE.fieldsToMessage @TPO.WithImported $ + FormE.field @"withOneof" (Just (FormE.messageCache withOneof)) + FormE.messageEncoderToLazyByteString withImported @?= + toLazyByteString (TPO.WithImported (Just (TPO.WithImportedPickOneWithOneof withOneof))) + +testShowMessageEncoding :: TestTree +testShowMessageEncoding = testCase "Show MessageEncoding" $ do + let trivial = TP.Trivial 123 + badForm = "abc" + encoding :: FormE.MessageEncoding TP.Trivial + encoding = FormE.messageCache trivial + bogus :: FormE.MessageEncoding TP.Trivial + bogus = FormE.unsafeByteStringToMessageEncoding badForm + -- Test desired behavior for valid encoding: + show (Just encoding) @?= + "Just (Proto3.Suite.Form.Encode.messageCache " ++ showsPrec 11 trivial ")" + -- Test fallback behavior for invalid encoding: + show (Just bogus) @?= + "Just (Proto3.Suite.Form.Encode.unsafeByteStringToMessageEncoding " ++ showsPrec 11 badForm ")" + +testShowMessageEncoder :: TestTree +testShowMessageEncoder = testCase "Show MessageEncoder" $ do + let trivial = TP.Trivial 123 + badForm = "abc" + encoder :: FormE.MessageEncoder TP.Trivial + encoder = FormE.messageReflection trivial + bogus :: FormE.MessageEncoder TP.Trivial + bogus = FormE.unsafeByteStringToMessageEncoder badForm + -- Test desired behavior for valid encoder: + show (Just encoder) @?= + "Just (Proto3.Suite.Form.Encode.messageReflection " ++ showsPrec 11 trivial ")" + -- Test fallback behavior for invalid encoder: + show (Just bogus) @?= + "Just (Proto3.Suite.Form.Encode.unsafeByteStringToMessageEncoder " ++ showsPrec 11 badForm ")" + +testToJSONPBMessageEncoding :: TestTree +testToJSONPBMessageEncoding = testProperty "ToJSONPB MessageEncoding" $ \opts -> + let trivial = TP.Trivial 123 + badForm = "abc" + encoding :: FormE.MessageEncoding TP.Trivial + encoding = FormE.messageCache trivial + bogus :: FormE.MessageEncoding TP.Trivial + bogus = FormE.unsafeByteStringToMessageEncoding badForm + in + -- Test desired behavior for valid encoding: + JSONPB.toJSONPB encoding opts === JSONPB.toJSONPB trivial opts + .&&. + JSONPB.toEncodingPB encoding opts === JSONPB.toEncodingPB trivial opts + .&&. + -- Test fallback behavior for invalid encoding: + JSONPB.toJSONPB bogus opts === JSONPB.toJSONPB badForm opts + .&&. + JSONPB.toEncodingPB bogus opts === JSONPB.toEncodingPB badForm opts + +testToJSONPBMessageEncoder :: TestTree +testToJSONPBMessageEncoder = testProperty "ToJSONPB MessageEncoder" $ \opts -> + let trivial = TP.Trivial 123 + badForm = "abc" + encoder :: FormE.MessageEncoder TP.Trivial + encoder = FormE.messageReflection trivial + bogus :: FormE.MessageEncoder TP.Trivial + bogus = FormE.unsafeByteStringToMessageEncoder badForm + in + -- Test desired behavior for valid encoder: + JSONPB.toJSONPB encoder opts === JSONPB.toJSONPB trivial opts + .&&. + JSONPB.toEncodingPB encoder opts === JSONPB.toEncodingPB trivial opts + .&&. + -- Test fallback behavior for invalid encoder: + JSONPB.toJSONPB bogus opts === JSONPB.toJSONPB badForm opts + .&&. + JSONPB.toEncodingPB bogus opts === JSONPB.toEncodingPB badForm opts + +testFromJSONPBMessageEncoding :: TestTree +testFromJSONPBMessageEncoding = testProperty "FromJSONPB MessageEncoding" $ \opts -> + let trivial = TP.Trivial 123 + badForm = "abc" + encoding :: FormE.MessageEncoding TP.Trivial + encoding = FormE.messageCache trivial + bogus :: FormE.MessageEncoding TP.Trivial + bogus = FormE.unsafeByteStringToMessageEncoding badForm + edec :: BL.ByteString -> Either String (FormE.MessageEncoding TP.Trivial) + edec = JSONPB.eitherDecode + in + -- Test desired behavior for valid encoder: + fmap (fromByteString . FormE.messageEncodingToByteString) (edec (JSONPB.encode opts encoding)) + === Right (Right trivial) + .&&. + -- Test fallback behavior for invalid encoder: + fmap FormE.messageEncodingToByteString (edec (JSONPB.encode opts bogus)) === Right badForm + +testFromJSONPBMessageEncoder :: TestTree +testFromJSONPBMessageEncoder = testProperty "FromJSONPB MessageEncoder" $ \opts -> + let trivial = TP.Trivial 123 + badForm = "abc" + encoder :: FormE.MessageEncoder TP.Trivial + encoder = FormE.messageReflection trivial + bogus :: FormE.MessageEncoder TP.Trivial + bogus = FormE.unsafeByteStringToMessageEncoder badForm + edec :: BL.ByteString -> Either String (FormE.MessageEncoder TP.Trivial) + edec = JSONPB.eitherDecode + in + -- Test desired behavior for valid encoder: + fmap (fromByteString . FormE.messageEncoderToByteString) (edec (JSONPB.encode opts encoder)) + === Right (Right trivial) + .&&. + -- Test fallback behavior for invalid encoder: + fmap FormE.messageEncoderToByteString (edec (JSONPB.encode opts bogus)) === Right badForm + +data TestMessage + (num :: Nat) + (repetition :: Maybe Form.Cardinality) + (protoType :: Form.ProtoType) + -- ^ Omitting the repetition means that field @"name"@ is in a @oneof@ named @"pickOne"@. + +type instance Form.NamesOf (TestMessage num maybeRepetition protoType) = '[ "name" ] + +type instance Form.NumberOf (TestMessage num maybeRepetition protoType) "name" = num + +type instance Form.ProtoTypeOf (TestMessage num maybeRepetition protoType) "name" = protoType + +type instance Form.OneOfOf (TestMessage num 'Nothing protoType) "name" = "pickOne" +type instance Form.OneOfOf (TestMessage num 'Nothing protoType) "pickOne" = "pickOne" +type instance Form.OneOfOf (TestMessage num ('Just _) protoType) "name" = "" + +type instance Form.CardinalityOf (TestMessage num 'Nothing protoType) "name" = 'Form.Optional +type instance Form.CardinalityOf (TestMessage num 'Nothing protoType) "pickOne" = 'Form.Optional +type instance Form.CardinalityOf (TestMessage num ('Just repetition) protoType) "name" = repetition + +encoderPromotionsAndAuto :: TestTree +encoderPromotionsAndAuto = testGroup "Encoder promotes types correctly and Auto-selection works" + [ testGroup "Encoder promotes types correctly" + [ check @'Form.Int32 @Int8 @Int32 "int32" (fromIntegral @Int8 @Int32) + , check @'Form.Int32 @Word8 @Int32 "int32" (fromIntegral @Word8 @Int32) + , check @'Form.Int32 @Int16 @Int32 "int32" (fromIntegral @Int16 @Int32) + , check @'Form.Int32 @Word16 @Int32 "int32" (fromIntegral @Word16 @Int32) + , check @'Form.Int64 @Int8 @Int64 "int64" (fromIntegral @Int8 @Int64) + , check @'Form.Int64 @Word8 @Int64 "int64" (fromIntegral @Word8 @Int64) + , check @'Form.Int64 @Int16 @Int64 "int64"(fromIntegral @Int16 @Int64) + , check @'Form.Int64 @Word16 @Int64 "int64"(fromIntegral @Word16 @Int64) + , check @'Form.Int64 @Int32 @Int64 "int64"(fromIntegral @Int32 @Int64) + , check @'Form.Int64 @Word32 @Int64 "int64"(fromIntegral @Word32 @Int64) + , check @'Form.SInt32 @Int8 @Int32 "sint32" (fromIntegral @Int8 @Int32) + , check @'Form.SInt32 @Word8 @Int32 "sint32" (fromIntegral @Word8 @Int32) + , check @'Form.SInt32 @Int16 @Int32 "sint32" (fromIntegral @Int16 @Int32) + , check @'Form.SInt32 @Word16 @Int32 "sint32" (fromIntegral @Word16 @Int32) + , check @'Form.SInt64 @Int8 @Int64 "sint64" (fromIntegral @Int8 @Int64) + , check @'Form.SInt64 @Word8 @Int64 "sint64" (fromIntegral @Word8 @Int64) + , check @'Form.SInt64 @Int16 @Int64 "sint64" (fromIntegral @Int16 @Int64) + , check @'Form.SInt64 @Word16 @Int64 "sint64" (fromIntegral @Word16 @Int64) + , check @'Form.SInt64 @Int32 @Int64 "sint64" (fromIntegral @Int32 @Int64) + , check @'Form.SInt64 @Word32 @Int64 "sint64" (fromIntegral @Word32 @Int64) + , check @'Form.UInt32 @Word8 @Word32 "uint32" (fromIntegral @Word8 @Word32) + , check @'Form.UInt32 @Word16 @Word32 "uint32" (fromIntegral @Word16 @Word32) + , check @'Form.UInt64 @Word8 @Word64 "uint64" (fromIntegral @Word8 @Word64) + , check @'Form.UInt64 @Word16 @Word64 "uint64" (fromIntegral @Word16 @Word64) + , check @'Form.UInt64 @Word32 @Word64 "uint64" (fromIntegral @Word32 @Word64) + , check @'Form.Fixed32 @Word8 @Word32 "fixed32" (fromIntegral @Word8 @Word32) + , check @'Form.Fixed32 @Word16 @Word32 "fixed32" (fromIntegral @Word16 @Word32) + , check @'Form.Fixed64 @Word8 @Word64 "fixed64" (fromIntegral @Word8 @Word64) + , check @'Form.Fixed64 @Word16 @Word64 "fixed64" (fromIntegral @Word16 @Word64) + , check @'Form.Fixed64 @Word32 @Word64 "fixed64" (fromIntegral @Word32 @Word64) + , check @'Form.SFixed32 @Int8 @Int32 "sfixed32" (fromIntegral @Int8 @Int32) + , check @'Form.SFixed32 @Word8 @Int32 "sfixed32" (fromIntegral @Word8 @Int32) + , check @'Form.SFixed32 @Int16 @Int32 "sfixed32" (fromIntegral @Int16 @Int32) + , check @'Form.SFixed32 @Word16 @Int32 "sfixed32" (fromIntegral @Word16 @Int32) + , check @'Form.SFixed64 @Int8 @Int64 "sfixed64" (fromIntegral @Int8 @Int64) + , check @'Form.SFixed64 @Word8 @Int64 "sfixed64" (fromIntegral @Word8 @Int64) + , check @'Form.SFixed64 @Int16 @Int64 "sfixed64" (fromIntegral @Int16 @Int64) + , check @'Form.SFixed64 @Word16 @Int64 "sfixed64" (fromIntegral @Word16 @Int64) + , check @'Form.SFixed64 @Int32 @Int64 "sfixed64" (fromIntegral @Int32 @Int64) + , check @'Form.SFixed64 @Word32 @Int64 "sfixed64" (fromIntegral @Word32 @Int64) + , check @'Form.Double @Float @Double "double" (realToFrac @Float @Double) + ] + , testGroup "Encoder Auto wrapper does not change format" + [ check @'Form.Int32 @Int32 @(FormE.Auto Int32) "int32" FormE.Auto + , check @'Form.Int64 @Int64 @(FormE.Auto Int64) "int64" FormE.Auto + , check @'Form.SInt32 @Int32 @(FormE.Auto Int32) "sint32" FormE.Auto + , check @'Form.SInt64 @Int64 @(FormE.Auto Int64) "sint64" FormE.Auto + , check @'Form.UInt32 @Word32 @(FormE.Auto Word32) "uint32" FormE.Auto + , check @'Form.UInt64 @Word64 @(FormE.Auto Word64) "uint64" FormE.Auto + , check @'Form.Fixed32 @Word32 @(FormE.Auto Word32) "fixed32" FormE.Auto + , check @'Form.Fixed64 @Word64 @(FormE.Auto Word64) "fixed64" FormE.Auto + , check @'Form.SFixed32 @Int32 @(FormE.Auto Int32) "sfixed32" FormE.Auto + , check @'Form.SFixed64 @Int64 @(FormE.Auto Int64) "sfixed64" FormE.Auto + , check @'Form.Bool @Bool @(FormE.Auto Bool) "bool" FormE.Auto + , check @'Form.Float @Float @(FormE.Auto Float) "float" FormE.Auto + , check @'Form.Double @Double @(FormE.Auto Double) "double" FormE.Auto + , checkNotPacked @'Form.String @Data.Text.Short.ShortText @(FormE.Auto Data.Text.Short.ShortText) "string" FormE.Auto + , checkNotPacked @'Form.Bytes @BS.ShortByteString @(FormE.Auto BS.ShortByteString) "bytes" FormE.Auto + ] + ] + where + check :: + forall (protoType :: Form.ProtoType) a b . + ( Typeable a + , Typeable b + , Arbitrary a + , Show a + , FormE.FieldForm 'Form.Implicit protoType a + , FormE.FieldForm 'Form.Implicit protoType b + , FormE.FieldForm 'Form.Optional protoType (Maybe a) + , FormE.FieldForm 'Form.Optional protoType (Maybe b) + , FormE.FieldForm ('Form.Repeated 'Form.Unpacked) protoType (Identity a) + , FormE.FieldForm ('Form.Repeated 'Form.Unpacked) protoType (Identity b) + , FormE.FieldForm ('Form.Repeated 'Form.Unpacked) protoType [a] + , FormE.FieldForm ('Form.Repeated 'Form.Unpacked) protoType [b] + , FormE.FieldForm ('Form.Repeated 'Form.Unpacked) protoType (V.Vector a) + , FormE.FieldForm ('Form.Repeated 'Form.Unpacked) protoType (V.Vector b) + , FormE.FieldForm ('Form.Repeated 'Form.Packed) protoType (Identity a) + , FormE.FieldForm ('Form.Repeated 'Form.Packed) protoType (Identity b) + , FormE.FieldForm ('Form.Repeated 'Form.Packed) protoType [a] + , FormE.FieldForm ('Form.Repeated 'Form.Packed) protoType [b] + , FormE.FieldForm ('Form.Repeated 'Form.Packed) protoType (V.Vector a) + , FormE.FieldForm ('Form.Repeated 'Form.Packed) protoType (V.Vector b) + ) => + String -> + (a -> b) -> + TestTree + check protoTypeName convert = + testProperty (showString protoTypeName $ showString ": " $ + showsType @a $ showString " -> " $ showsType @b "") $ + propNotPacked @protoType convert .&&. + propPacked @protoType convert + + checkNotPacked :: + forall (protoType :: Form.ProtoType) a b . + ( Typeable a + , Typeable b + , Arbitrary a + , Show a + , FormE.FieldForm 'Form.Implicit protoType a + , FormE.FieldForm 'Form.Implicit protoType b + , FormE.FieldForm 'Form.Optional protoType (Maybe a) + , FormE.FieldForm 'Form.Optional protoType (Maybe b) + , FormE.FieldForm ('Form.Repeated 'Form.Unpacked) protoType (Identity a) + , FormE.FieldForm ('Form.Repeated 'Form.Unpacked) protoType (Identity b) + , FormE.FieldForm ('Form.Repeated 'Form.Unpacked) protoType [a] + , FormE.FieldForm ('Form.Repeated 'Form.Unpacked) protoType [b] + , FormE.FieldForm ('Form.Repeated 'Form.Unpacked) protoType (V.Vector a) + , FormE.FieldForm ('Form.Repeated 'Form.Unpacked) protoType (V.Vector b) + ) => + String -> + (a -> b) -> + TestTree + checkNotPacked protoTypeName convert = + testProperty (showString protoTypeName $ showString ": " $ + showsType @a $ showString " -> " $ showsType @b "") $ + propNotPacked @protoType convert + + propNotPacked :: + forall (protoType :: Form.ProtoType) a b . + ( Typeable a + , Typeable b + , Arbitrary a + , Show a + , FormE.FieldForm 'Form.Implicit protoType a + , FormE.FieldForm 'Form.Implicit protoType b + , FormE.FieldForm 'Form.Optional protoType (Maybe a) + , FormE.FieldForm 'Form.Optional protoType (Maybe b) + , FormE.FieldForm ('Form.Repeated 'Form.Unpacked) protoType (Identity a) + , FormE.FieldForm ('Form.Repeated 'Form.Unpacked) protoType (Identity b) + , FormE.FieldForm ('Form.Repeated 'Form.Unpacked) protoType [a] + , FormE.FieldForm ('Form.Repeated 'Form.Unpacked) protoType [b] + , FormE.FieldForm ('Form.Repeated 'Form.Unpacked) protoType (V.Vector a) + , FormE.FieldForm ('Form.Repeated 'Form.Unpacked) protoType (V.Vector b) + ) => + (a -> b) -> + Property + propNotPacked convert = + forAll (choose (1, 536870911)) $ \fieldNum -> + case someNatVal fieldNum of + Nothing -> + property False -- Should never happen. + Just (SomeNat (_ :: Proxy num)) -> + forAll arbitrary $ \a -> + forAll arbitrary $ \(as :: [a])-> + let b :: b + b = convert a + bs :: [b] + bs = map convert as + asVec :: V.Vector a + asVec = V.fromList as + bsVec :: V.Vector b + bsVec = V.fromList bs + in + counterexample "Implicit" + (check1 @num @('Just 'Form.Implicit) @protoType a b) .&&. + counterexample "Optional - Nothing" + (check1 @num @('Just 'Form.Optional) @protoType (Nothing @a) (Nothing @b)) .&&. + counterexample "Optional - Just" + (check1 @num @('Just 'Form.Optional) @protoType (Just a) (Just b)) .&&. + counterexample "inside oneof" + (check1 @num @'Nothing @protoType (Just a) (Just b)) .&&. + counterexample "Unpacked Identity" + (check1 @num @('Just ('Form.Repeated 'Form.Unpacked)) @protoType (Identity a) (Identity b)) .&&. + counterexample "Unpacked Forward" + (check1 @num @('Just ('Form.Repeated 'Form.Unpacked)) @protoType as bs) .&&. + counterexample "Unpacked Vector" + (check1 @num @('Just ('Form.Repeated 'Form.Unpacked)) @protoType asVec bsVec) + + propPacked :: + forall (protoType :: Form.ProtoType) a b . + ( Typeable a + , Typeable b + , Arbitrary a + , Show a + , FormE.FieldForm ('Form.Repeated 'Form.Packed) protoType (Identity a) + , FormE.FieldForm ('Form.Repeated 'Form.Packed) protoType (Identity b) + , FormE.FieldForm ('Form.Repeated 'Form.Packed) protoType [a] + , FormE.FieldForm ('Form.Repeated 'Form.Packed) protoType [b] + , FormE.FieldForm ('Form.Repeated 'Form.Packed) protoType (V.Vector a) + , FormE.FieldForm ('Form.Repeated 'Form.Packed) protoType (V.Vector b) + ) => + (a -> b) -> + Property + propPacked convert = + forAll (choose (1, 536870911)) $ \fieldNum -> + case someNatVal fieldNum of + Nothing -> + property False -- Should never happen. + Just (SomeNat (_ :: Proxy num)) -> + forAll arbitrary $ \a -> + forAll arbitrary $ \(as :: [a])-> + let b :: b + b = convert a + bs :: [b] + bs = map convert as + asVec :: V.Vector a + asVec = V.fromList as + bsVec :: V.Vector b + bsVec = V.fromList bs + in + counterexample "Packed Identity" + (check1 @num @('Just ('Form.Repeated 'Form.Packed)) @protoType (Identity a) (Identity b)) .&&. + counterexample "Packed Forward" + (check1 @num @('Just ('Form.Repeated 'Form.Packed)) @protoType as bs) .&&. + counterexample "Packed Vector" + (check1 @num @('Just ('Form.Repeated 'Form.Packed)) @protoType asVec bsVec) + + check1 :: + forall (num :: Nat) (maybeRepetition :: Maybe Form.Cardinality) + (protoType :: Form.ProtoType) a b . + ( FormE.Field "name" a (TestMessage num maybeRepetition protoType) + , FormE.Field "name" b (TestMessage num maybeRepetition protoType) + , FormE.Distinct (TestMessage num maybeRepetition protoType) + (FormE.Occupy (TestMessage num maybeRepetition protoType) "name" '[]) + ) => + a -> + b -> + Property + check1 a b = + FormE.messageEncoderToLazyByteString + (FormE.fieldsToMessage (FormE.field @"name" @a @(TestMessage num maybeRepetition protoType) a)) + === + FormE.messageEncoderToLazyByteString + (FormE.fieldsToMessage (FormE.field @"name" @b @(TestMessage num maybeRepetition protoType) b)) + + showsType :: forall a . Typeable a => ShowS + showsType = showsTypeRep (typeRep (Proxy :: Proxy a)) + -------------------------------------------------------------------------------- -- Decoding @@ -203,7 +763,13 @@ , check "with_enum0.bin" $ TP.WithEnum $ Enumerated $ Right $ TP.WithEnum_TestEnumENUM1 , check "with_enum1.bin" $ TP.WithEnum $ Enumerated $ Right $ TP.WithEnum_TestEnumENUM2 , check "with_repetition.bin" $ TP.WithRepetition [1..5] - , check "with_repeated_signed.bin" $ TP.WithRepeatedSigned [0,1,-1,2,-2] [0,1,-1,2,-2] + , check "with_repeated_signed.bin" $ TP.WithRepeatedSigned + [ 0, -1, 1, -2, 2, + 0x3FFFFFFF, -0x40000000, 0x40000000, -0x40000001, + 0x7FFFFFFF, -0x7FFFFFFF - 1 ] + [ 0, -1, 1, -2, 2, + 0x3FFFFFFFFFFFFFFF, -0x4000000000000000, 0x4000000000000000, -0x4000000000000001, + 0x7FFFFFFFFFFFFFFF, -0x7FFFFFFFFFFFFFFF - 1 ] , check "with_fixed.bin" $ TP.WithFixed 16 (-123) 4096 (-4096) , check "with_bytes.bin" $ TP.WithBytes (BC.pack "abc") (fromList $ map BC.pack ["abc","123"]) , check "with_packing.bin" $ TP.WithPacking [1,2,3] [1,2,3] @@ -264,6 +830,7 @@ dotProtoUnitTests = testGroup ".proto parsing tests" [ dotProtoParseTrivial , dotProtoPrintTrivial + , dotProtoParseEmptyStatement , dotProtoRoundtripTrivial , dotProtoRoundtripSimpleMessage , dotProtoRoundtripExtend @@ -282,6 +849,44 @@ dotProtoPrintTrivial = testCase "Print a content-less DotProto" $ testDotProtoPrint trivialDotProto "syntax = \"proto3\";" + +dotProtoParseEmptyStatement :: TestTree +dotProtoParseEmptyStatement = + testCase "Parse empty statements" (testDotProtoParse filePath dotProtoAST) + where + filePath :: FilePath + filePath = testFilesPfx <> "test_proto_empty_field.proto" + + dotProtoAST :: DotProto + dotProtoAST = + DotProto [] [] + (DotProtoPackageSpec (Single "TestProtoEmptyField")) + [ DotProtoEnum + "" + (Single "EnumWithEmptyField") + [ DotProtoEnumField (Single "enum_foo") 0 [] + , DotProtoEnumField (Single "enum_bar") 1 [] + ] + , DotProtoMessage + "" + (Single "MessageWithEmptyField") + [ DotProtoMessageField (DotProtoField + { dotProtoFieldNumber = 1 + , dotProtoFieldType = Prim UInt32 + , dotProtoFieldName = Single "foo" + , dotProtoFieldOptions = [] + , dotProtoFieldComment = "" + }) + , DotProtoMessageField (DotProtoField + { dotProtoFieldNumber = 2 + , dotProtoFieldType = Prim UInt32 + , dotProtoFieldName = Single "bar" + , dotProtoFieldOptions = [] + , dotProtoFieldComment = "" + }) + ] + ] + (DotProtoMeta (Path (testFilesPfx NE.:| ["test_proto_empty_field.proto"]))) dotProtoRoundtripTrivial :: TestTree dotProtoRoundtripTrivial = testCase diff --git a/tests/Test/Proto/Generate/Name.hs b/tests/Test/Proto/Generate/Name.hs --- a/tests/Test/Proto/Generate/Name.hs +++ b/tests/Test/Proto/Generate/Name.hs @@ -4,7 +4,7 @@ -- | -- -module Test.Proto.Generate.Name (tests) where +module Test.Proto.Generate.Name (testTree) where import Test.Tasty (TestTree, testGroup) import Test.Tasty.Hedgehog (testProperty) @@ -20,8 +20,8 @@ -- ----------------------------------------------------------------------------- -tests :: TestTree -tests = +testTree :: TestTree +testTree = testGroup "Test.Proto.Generate.Name" [ testProperty "filenames" resolve'protofile diff --git a/tests/Test/Proto/Interval.hs b/tests/Test/Proto/Interval.hs new file mode 100644 --- /dev/null +++ b/tests/Test/Proto/Interval.hs @@ -0,0 +1,181 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE NegativeLiterals #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE TypeApplications #-} + +module Test.Proto.Interval (testTree) where + +import Data.Foldable (for_) + +import Proto3.Suite.DotProto.Internal (joinIntervals, normalizeIntervals) + +import Hedgehog (Gen, forAll, property, (===)) +import Hedgehog qualified +import Hedgehog.Gen qualified as Gen +import Hedgehog.Range qualified as Range + +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.Hedgehog (testProperty) + +-------------------------------------------------------------------------------- + +-- | Check if the given value is some given bounds (inclusive). +isIn :: (Ord a) => a -> (a, a) -> Bool +isIn x (a, b) = a <= x && x <= b + +-- | Check if the given value is any of the given bounds (inclusive). +isInAnyOf :: (Ord a) => a -> [(a, a)] -> Bool +isInAnyOf = any . isIn + +-- | Generates an arbitrary interval. May generate +-- empty intervals, though at about 10% probability. +genInterval :: (Bounded a, Integral a) => Gen (a, a) +genInterval = Gen.frequency [(4, alwaysNonempty), (1, halfEmpty)] + where + alwaysNonempty = do + x <- Gen.integral Range.constantBounded + y <- Gen.integral Range.constantBounded + pure (min x y, max x y) + + halfEmpty = do + x <- Gen.integral Range.constantBounded + y <- Gen.integral Range.constantBounded + pure (x, y) + +-- | A value in the range [-8 .. 7]. We intentionally limit this type to +-- just a few values in order to increase the chance of overlapping intervals +-- in some tests, while still retaining enough distinct values to allow many +-- different relationships between intervals. We also want to check for +-- arithmetic overflow in the code under test by throwing an exception, +-- which should cause the test to fail. +newtype Nybble = UnsafeNybble Int + deriving newtype (Eq, Ord, Real, Show) + +{-# COMPLETE Nybble #-} + +pattern Nybble :: Int -> Nybble +pattern Nybble x <- UnsafeNybble x + where + Nybble x + | -8 <= x && x <= 7 = UnsafeNybble x + | otherwise = error $ "Nybble out of bounds: " ++ show x + +instance Bounded Nybble + where + minBound = Nybble -8 + maxBound = Nybble 7 + +-- | Manual implementation to ensure an exception is thrown for out-of-bounds values. +instance Enum Nybble + where + toEnum x = Nybble x + fromEnum (Nybble x) = x + +-- | Manual implementation to ensure an exception is thrown for arithmetic overflow. +instance Num Nybble + where + Nybble x + Nybble y = Nybble (x + y) + Nybble x - Nybble y = Nybble (x - y) + Nybble x * Nybble y = Nybble (x * y) + negate (Nybble x) = Nybble (negate x) + abs (Nybble x) = Nybble (abs x) + signum (Nybble x) = Nybble (signum x) + fromInteger x = Nybble (fromInteger x) + +-- | Manual implementation to ensure an exception is thrown for arithmetic overflow. +instance Integral Nybble + where + quotRem (Nybble n) (Nybble d) = let (q, r) = quotRem n d in (Nybble q, Nybble r) + toInteger (Nybble x) = toInteger x + +-------------------------------------------------------------------------------- + +testTree :: TestTree +testTree = + testGroup + "Test.Proto.Interval" + [ testJoinIntervals + , testNormalizeIntervals + ] + +-- This test verifies the documented behavior of 'joinIntervals'. +testJoinIntervals :: TestTree +testJoinIntervals = testProperty "joinIntervals" $ property do + (a, b) <- forAll $ genInterval @Nybble + (c, d) <- forAll $ genInterval @Nybble + case joinIntervals (a, b) (c, d) of + Nothing -> do + -- The code under test says that one cannot merge the two intervals into + -- a single interval. For that to be true, both intervals must be nonempty/valid: + Hedgehog.assert (a <= b) + Hedgehog.assert (c <= d) + -- And in addition, the least interval containing both of the given intervals + -- must /not/ be their union. Namely, it must include some extra element: + let extra x = not (x `isIn` (a, b) || x `isIn` (c, d)) + Hedgehog.assert (any extra [min a c .. max b d]) + -- That suffices to verify that the intervals cannot be combined, but because + -- the code under test currently considers similar issues, we note that there + -- must be at least one value strictly between the two given intervals; + -- otherwise we could merge them because there would be nothing between them: + let between x = (b < x && x < c) || (d < x && x < a) + Hedgehog.assert (any between [minBound .. maxBound]) + Just combined -> do + -- The code under test claims that 'combined' equals the union of the given + -- intervals. We check that conclusion by testing every possible element: + Hedgehog.annotateShow combined + for_ [minBound .. maxBound] \x -> do + x `isIn` combined === (x `isIn` (a, b) || x `isIn` (c, d)) + +-- This test verifies the documented behavior of 'normalizeIntervals'. +-- (Note the correspondence between the various documented properties +-- and the specific checks included here.) +-- +-- This test also checks an additional property: that 'normalizeIntervals' +-- never increases the sum of the sizes of the listed intervals, where by +-- "size" we mean the count of elements within the interval. That is, we +-- are only eliminating redundancy in the +testNormalizeIntervals :: TestTree +testNormalizeIntervals = testProperty "normalizeIntervals" $ property do + messy <- forAll $ Gen.list (Range.linear 0 20) $ genInterval @Nybble + + let clean :: [(Nybble, Nybble)] + clean = normalizeIntervals messy + Hedgehog.annotateShow clean + + -- The result must not contain any empty intervals. + for_ clean \(a, b) -> + Hedgehog.assert (a <= b) + + -- The union of the result must be the same as the union of the input. + for_ [minBound .. maxBound] \x -> do + (x, isInAnyOf x clean) === (x, isInAnyOf x messy) + + -- Check that the listed intervals do not overlap, and moreover, + -- cannot be merged because there are no values between them. + -- + -- Note that here we rely upon the accuracy of 'joinIntervals', + -- which is checked in isolation by the test 'testJoinIntervals'. + for_ (zip [1 ..] clean) \(d, i1) -> + for_ (drop d clean) \i2 -> do + (i1, i2, joinIntervals i1 i2) === (i1, i2, Nothing) + + -- The code under test should have ensured that for any two consecutive intervals, + -- there is at least one value strictly inbetween those two intervals. This check + -- should subsume the previous one, but we run both checks just to be sure. + -- + -- The nonempty gaps between intervals prevent further merging, making 'clean' + -- at least locally minimal. But a simple exhaustive search would be extremely + -- expensive, and hence we rely upon the mathematical argument in the comments for + -- 'normalizeIntervals' to completely rule out the possibility of shorter lists. + for_ (zip clean (drop 1 clean)) \((_, b), (c, _)) -> + Hedgehog.assert (b < c && succ b < c) -- The first check is to sure that 'succ' is safe. + + -- Verify interval merging by checking that the size of the merged intervals is + -- bounded below the sum of the sizes of each individual interval that was merged. + let intervalSize :: (Nybble, Nybble) -> Integer + intervalSize (a, b) = if a <= b then toInteger b + 1 - toInteger a else 0 + overallSize :: [(Nybble, Nybble)] -> Integer + overallSize = sum . map intervalSize + Hedgehog.annotateShow (overallSize clean, overallSize messy) + Hedgehog.assert (overallSize clean <= overallSize messy) diff --git a/tests/Test/Proto/Parse.hs b/tests/Test/Proto/Parse.hs new file mode 100644 --- /dev/null +++ b/tests/Test/Proto/Parse.hs @@ -0,0 +1,21 @@ + +module Test.Proto.Parse (testTree) where + +import Hedgehog (property, (===)) + +import Proto3.Suite.DotProto.Parsing qualified as Proto3 +import Proto3.Suite.DotProto.Rendering () + +import Test.Proto.Parse.Core (runParseTest) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.Hedgehog (testProperty) + +-------------------------------------------------------------------------------- + +testTree :: TestTree +testTree = + testGroup + "Test.Proto.Parse" + [ testProperty "empty" $ property do + runParseTest Proto3.pEmptyStmt ";" === Right () + ] diff --git a/tests/Test/Proto/Parse/Core.hs b/tests/Test/Proto/Parse/Core.hs new file mode 100644 --- /dev/null +++ b/tests/Test/Proto/Parse/Core.hs @@ -0,0 +1,24 @@ + +module Test.Proto.Parse.Core + ( runParseTest + , parseTrip + ) where + +import Hedgehog (PropertyT) +import Hedgehog qualified as Hedgehog + +import Text.Parsec (ParseError) +import Text.Parsec qualified as Parsec +import Text.PrettyPrint (render) +import Text.PrettyPrint.HughesPJClass (Pretty, pPrint) + +import Proto3.Suite.DotProto.Parsing (ProtoParser) +import Proto3.Suite.DotProto.Parsing qualified as Proto3 + +-------------------------------------------------------------------------------- + +runParseTest :: ProtoParser a -> String -> Either ParseError a +runParseTest p = Parsec.parse (Proto3.runProtoParser p) "" + +parseTrip :: (Eq a, Pretty a, Show a) => a -> ProtoParser a -> PropertyT IO () +parseTrip x p = Hedgehog.tripping x (render . pPrint) (runParseTest p) diff --git a/tests/Test/Proto/Parse/Option.hs b/tests/Test/Proto/Parse/Option.hs --- a/tests/Test/Proto/Parse/Option.hs +++ b/tests/Test/Proto/Parse/Option.hs @@ -1,27 +1,26 @@ -module Test.Proto.Parse.Option (tests) where +module Test.Proto.Parse.Option (testTree) where -import Hedgehog (Property, PropertyT, forAll, property, (===)) +import Hedgehog (Property, forAll, property, (===)) import qualified Hedgehog as Hedgehog import qualified Hedgehog.Gen as Gen import Test.Tasty (TestTree, testGroup) import Test.Tasty.Hedgehog (testProperty) +import Test.Proto.Parse.Core (runParseTest, parseTrip) import qualified Test.Proto.Parse.Gen as Gen import qualified Data.Char as Char import Data.Either (isLeft) import Text.Parsec (ParseError) -import qualified Text.Parsec as Parsec -import Text.PrettyPrint (render) -import Text.PrettyPrint.HughesPJClass (Pretty, pPrint) -import Proto3.Suite.DotProto.Parsing (ProtoParser) import qualified Proto3.Suite.DotProto.Parsing as Proto3 import Proto3.Suite.DotProto.Rendering () -- orphan Pretty DotProtoIdentifier -tests :: TestTree -tests = +-------------------------------------------------------------------------------- + +testTree :: TestTree +testTree = testGroup "Test.Proto.Parse.Option" [ testProperty "Unqualified Option Identifier" propParseName @@ -29,12 +28,6 @@ , testProperty "Keyword 'Option'" propParseOptionKw , testsOptionKw ] - -runParseTest :: ProtoParser a -> String -> Either ParseError a -runParseTest p = Parsec.parse (Proto3.runProtoParser p) "" - -parseTrip :: (Eq a, Pretty a, Show a) => a -> ProtoParser a -> PropertyT IO () -parseTrip x p = Hedgehog.tripping x (render . pPrint) (runParseTest p) propParseName :: Property propParseName = property $ do diff --git a/tests/Test/Proto/ToEncoder.hs b/tests/Test/Proto/ToEncoder.hs new file mode 100644 --- /dev/null +++ b/tests/Test/Proto/ToEncoder.hs @@ -0,0 +1,531 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE ImplicitParams #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} + +module Test.Proto.ToEncoder + ( Iterator(..) + , Stripping(..) + , ToEncoder(..) + ) where + +import Control.Category ((.)) +import Prelude hiding ((.)) + +import Data.Foldable (toList) +import qualified Data.Functor.Identity as Functor (Identity(..)) +import Data.Kind (Type) +import qualified Data.Map as M +import qualified Data.Vector +import qualified Proto3.Suite.Form as Form +import qualified Proto3.Suite.Form.Encode as FormE +import Proto3.Wire.Encode.Repeated (mapRepeated) + +import TestProto +import qualified TestProtoImport +import qualified TestProtoNegativeEnum +import qualified TestProtoOneof +import qualified TestProtoOneofImport +import qualified TestProtoOptional +import qualified TestProtoWrappers + +-- | Which kind of iteration we should test for repeated fields. +data Iterator + = Identity + | Forward + | Vector + deriving stock (Bounded, Enum, Eq, Read, Show) + +-- | Whether we should strip 'FormE.Wrap' from the types of the values to be contained +-- in standard wrappers; either approach should be supported for typically-used types. +data Stripping + = Keep + | Strip + deriving stock (Bounded, Enum, Eq, Read, Show) + +class ToEncoder a + where + toEncoder :: (?iterator :: Iterator, ?stripping :: Stripping) => a -> FormE.MessageEncoder a + +#if TYPE_LEVEL_FORMAT + +type family IsWrapped (a :: Type) :: Bool + where + IsWrapped (FormE.Wrap _) = 'True + IsWrapped _ = 'False + +class (IsWrapped a ~ w) => + Strip a b w | a w -> b + where + strip :: a -> b + +instance (IsWrapped a ~ 'False) => + Strip a a 'False + where + strip = id + +instance Strip (FormE.Wrap a) a 'True + where + strip = FormE.unwrap + +implicit :: + forall name a message names b . + ( Strip a b (IsWrapped a) + , FormE.Field name a message + , FormE.Field name b message + , ?stripping :: Stripping + ) => + a -> + FormE.FieldsEncoder message names (FormE.Occupy message name names) +implicit v = case ?stripping of + Keep -> FormE.field @name @a v + Strip -> FormE.field @name @b (strip v) + +optional :: + forall name a message names b . + ( Strip a b (IsWrapped a) + , FormE.Field name (Maybe a) message + , FormE.Field name (Maybe b) message + , ?stripping :: Stripping + ) => + Maybe a -> + FormE.FieldsEncoder message names (FormE.Occupy message name names) +optional v = case ?stripping of + Keep -> FormE.field @name @(Maybe a) v + Strip -> FormE.field @name @(Maybe b) (fmap @Maybe strip v) + +repeated :: + forall name a b c message names . + ( ?iterator :: Iterator + , ?stripping :: Stripping + , Strip b c (IsWrapped b) + , FormE.Occupy message name names ~ names + , FormE.Field name (Functor.Identity b) message + , FormE.Field name ([b]) message + , FormE.Field name (Data.Vector.Vector b) message + , FormE.Field name (Functor.Identity c) message + , FormE.Field name ([c]) message + , FormE.Field name (Data.Vector.Vector c) message + ) => + (a -> b) -> + Data.Vector.Vector a -> + FormE.FieldsEncoder message names names +repeated f = case (?iterator, ?stripping) of + (Identity, Keep) -> + -- We use 'Identity' to indicate we should emit the field elements one at a time, + -- without the potential for packing, though in any case not all types support packing. + FormE.foldFieldsEncoders . fmap (FormE.field @name . Functor.Identity . f) + (Identity, Strip) -> + -- We use 'Identity' to indicate we should emit the field elements one at a time, + -- without the potential for packing, though in any case not all types support packing. + FormE.foldFieldsEncoders . fmap (FormE.field @name . Functor.Identity . strip . f) + (Forward, Keep) -> + FormE.field @name . map f . toList + (Forward, Strip) -> + FormE.field @name . map (strip . f) . toList + (Vector, Keep) -> + FormE.field @name . Data.Vector.map f + (Vector, Strip) -> + FormE.field @name . Data.Vector.map f + +associations :: + forall name k v key value message names . + ( Form.ProtoTypeOf message name ~ 'Form.Map key value + , Form.CardinalityOf message name ~ 'Form.Repeated 'Form.Unpacked + , ?iterator :: Iterator + , FormE.Field name (Functor.Identity (FormE.MessageEncoder (Form.Association key value))) message + , FormE.Field name [FormE.MessageEncoder (Form.Association key value)] message + , FormE.Field name (Data.Vector.Vector (FormE.MessageEncoder (Form.Association key value))) message + , FormE.KnownFieldNumber message name + ) => + ((k, v) -> FormE.MessageEncoder (Form.Association key value)) -> + M.Map k v -> + FormE.FieldsEncoder message names names +associations f = case ?iterator of + Identity -> FormE.foldFieldsEncoders . + mapRepeated (FormE.associations @name . Functor.Identity . f) . + M.toAscList + Forward -> FormE.associations @name . map f . M.toAscList + Vector -> FormE.associations @name . Data.Vector.map f . Data.Vector.fromList . M.toAscList + +instance ToEncoder Trivial + where + toEncoder (Trivial f1) = FormE.fieldsToMessage @Trivial @'["trivialField"] $ + implicit @"trivialField" f1 + +instance ToEncoder MultipleFields + where + toEncoder (MultipleFields f1 f2 f3 f4 f5 f6) = FormE.fieldsToMessage $ + implicit @"multiFieldDouble" f1 . + implicit @"multiFieldFloat" f2 . + implicit @"multiFieldInt32" f3 . + implicit @"multiFieldInt64" f4 . + implicit @"multiFieldString" f5 . + implicit @"multiFieldBool" f6 + +instance ToEncoder SignedInts + where + toEncoder (SignedInts f1 f2) = FormE.fieldsToMessage $ + implicit @"signed32" f1 . + implicit @"signed64" f2 + +instance ToEncoder WithEnum + where + toEncoder (WithEnum f1) = FormE.fieldsToMessage $ + implicit @"enumField" f1 + +instance ToEncoder WithNesting_Nested + where + toEncoder (WithNesting_Nested f1 f2 f3 f4) = FormE.fieldsToMessage $ + implicit @"nestedField1" f1 . + implicit @"nestedField2" f2 . + repeated @"nestedPacked" id f3 . + repeated @"nestedUnpacked" id f4 + +instance ToEncoder WithNesting + where + toEncoder (WithNesting f1) = FormE.fieldsToMessage $ + optional @"nestedMessage" (fmap @Maybe toEncoder f1) + +instance ToEncoder WithNestingRepeated_Nested + where + toEncoder (WithNestingRepeated_Nested f1 f2 f3 f4) = FormE.fieldsToMessage $ + implicit @"nestedField1" f1 . + implicit @"nestedField2" f2 . + repeated @"nestedPacked" id f3 . + repeated @"nestedUnpacked" id f4 + +instance ToEncoder WithNestingRepeated + where + toEncoder (WithNestingRepeated f1) = FormE.fieldsToMessage $ + repeated @"nestedMessages" toEncoder f1 + +instance ToEncoder NestedInts + where + toEncoder (NestedInts f1 f2) = FormE.fieldsToMessage $ + implicit @"nestedInt1" f1 . + implicit @"nestedInt2" f2 + +instance ToEncoder WithNestingRepeatedInts + where + toEncoder (WithNestingRepeatedInts f1) = FormE.fieldsToMessage $ + repeated @"nestedInts" toEncoder f1 + +instance ToEncoder WithRepetition + where + toEncoder (WithRepetition f1) = FormE.fieldsToMessage $ + repeated @"repeatedField1" id f1 + +instance ToEncoder WithRepeatedSigned + where + toEncoder (WithRepeatedSigned f1 f2) = FormE.fieldsToMessage $ + repeated @"r32" id f1 . + repeated @"r64" id f2 + +instance ToEncoder WithFixed + where + toEncoder (WithFixed f1 f2 f3 f4) = FormE.fieldsToMessage $ + implicit @"fixed1" f1 . + implicit @"fixed2" f2 . + implicit @"fixed3" f3 . + implicit @"fixed4" f4 + +instance ToEncoder WithBytes + where + toEncoder (WithBytes f1 f2) = FormE.fieldsToMessage $ + implicit @"bytes1" f1 . + repeated @"bytes2" id f2 + +instance ToEncoder WithPacking + where + toEncoder (WithPacking f1 f2) = FormE.fieldsToMessage $ + repeated @"packing1" id f1 . + repeated @"packing2" id f2 + +instance ToEncoder AllPackedTypes + where + toEncoder (AllPackedTypes f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 f12 f13) = FormE.fieldsToMessage $ + repeated @"packedWord32" id f1 . + repeated @"packedWord64" id f2 . + repeated @"packedInt32" id f3 . + repeated @"packedInt64" id f4 . + repeated @"packedFixed32" id f5 . + repeated @"packedFixed64" id f6 . + repeated @"packedFloat" id f7 . + repeated @"packedDouble" id f8 . + repeated @"packedSFixed32" id f9 . + repeated @"packedSFixed64" id f10 . + repeated @"packedBool" id f11 . + repeated @"packedEnum" id f12 . + repeated @"unpackedEnum" id f13 + +instance ToEncoder OutOfOrderFields + where + toEncoder (OutOfOrderFields f1 f2 f3 f4) = FormE.fieldsToMessage $ + repeated @"field1" id f1 . + implicit @"field2" f2 . + implicit @"field3" f3 . + repeated @"field4" id f4 + +instance ToEncoder ShadowedMessage + where + toEncoder (ShadowedMessage f1 f2) = FormE.fieldsToMessage $ + implicit @"name" f1 . + implicit @"value" f2 + +instance ToEncoder MessageShadower_ShadowedMessage + where + toEncoder (MessageShadower_ShadowedMessage f1 f2) = FormE.fieldsToMessage $ + implicit @"name" f1 . + implicit @"value" f2 + +instance ToEncoder MessageShadower + where + toEncoder (MessageShadower f1 f2) = FormE.fieldsToMessage $ + optional @"shadowed_message" (fmap @Maybe toEncoder f1) . + implicit @"name" f2 + +instance ToEncoder WithQualifiedName + where + toEncoder (WithQualifiedName f1 f2) = FormE.fieldsToMessage $ + optional @"qname1" (fmap @Maybe toEncoder f1) . + optional @"qname2" (fmap @Maybe toEncoder f2) + +instance ToEncoder TestProtoImport.WithNesting_Nested + where + toEncoder (TestProtoImport.WithNesting_Nested f1 f2) = FormE.fieldsToMessage $ + implicit @"nestedField1" f1 . + implicit @"nestedField2" f2 + +instance ToEncoder TestProtoImport.WithNesting + where + toEncoder (TestProtoImport.WithNesting f1 f2) = FormE.fieldsToMessage $ + optional @"nestedMessage1" (fmap @Maybe toEncoder f1) . + optional @"nestedMessage2" (fmap @Maybe toEncoder f2) + +instance ToEncoder UsingImported + where + toEncoder (UsingImported f1 f2) = FormE.fieldsToMessage $ + optional @"importedNesting" (fmap @Maybe toEncoder f1) . + optional @"localNesting" (fmap @Maybe toEncoder f2) + +instance ToEncoder TestProtoOneof.DummyMsg + where + toEncoder (TestProtoOneof.DummyMsg f1) = FormE.fieldsToMessage $ + implicit @"dummy" f1 + +instance ToEncoder TestProtoOneofImport.AMessage + where + toEncoder (TestProtoOneofImport.AMessage f1 f2) = FormE.fieldsToMessage $ + implicit @"x" f1 . + implicit @"y" f2 + +instance ToEncoder TestProtoOneofImport.WithOneof + where + toEncoder (TestProtoOneofImport.WithOneof f1) = FormE.fieldsToMessage $ + case f1 of + Nothing -> + FormE.omitted + Just (TestProtoOneofImport.WithOneofPickOneA v) -> + optional @"a" (Just v) + Just (TestProtoOneofImport.WithOneofPickOneB v) -> + optional @"b" (Just v) + Just (TestProtoOneofImport.WithOneofPickOneC v) -> + optional @"c" (Just (toEncoder v)) + +instance ToEncoder TestProtoOneof.Something + where + toEncoder (TestProtoOneof.Something f1 f2 f3) = FormE.fieldsToMessage $ + implicit @"value" f1 . + implicit @"another" f2 . + case f3 of + Nothing -> + FormE.omitted + Just (TestProtoOneof.SomethingPickOneName v) -> + optional @"name" (Just v) + Just (TestProtoOneof.SomethingPickOneSomeid v) -> + optional @"someid" (Just v) + Just (TestProtoOneof.SomethingPickOneDummyMsg1 v) -> + optional @"dummyMsg1" (Just (toEncoder v)) + Just (TestProtoOneof.SomethingPickOneDummyMsg2 v) -> + optional @"dummyMsg2" (Just (toEncoder v)) + Just (TestProtoOneof.SomethingPickOneDummyEnum v) -> + optional @"dummyEnum" (Just v) + +instance ToEncoder TestProtoOneof.WithImported + where + toEncoder (TestProtoOneof.WithImported f1) = FormE.fieldsToMessage $ + case f1 of + Nothing -> + FormE.omitted + Just (TestProtoOneof.WithImportedPickOneDummyMsg1 v) -> + optional @"dummyMsg1" (Just (toEncoder v)) + Just (TestProtoOneof.WithImportedPickOneWithOneof v) -> + optional @"withOneof" (Just (toEncoder v)) + +instance ToEncoder TestProtoWrappers.TestDoubleValue + where + toEncoder (TestProtoWrappers.TestDoubleValue f1 f2 f3) = FormE.fieldsToMessage $ + optional @"wrapper" (fmap FormE.Wrap f1) . + repeated @"many" FormE.Wrap f2 . + case f3 of + Nothing -> + FormE.omitted + Just (TestProtoWrappers.TestDoubleValuePickOneOne v) -> + optional @"one" (Just (FormE.Wrap v)) + +instance ToEncoder TestProtoWrappers.TestFloatValue + where + toEncoder (TestProtoWrappers.TestFloatValue f1 f2 f3) = FormE.fieldsToMessage $ + optional @"wrapper" (fmap FormE.Wrap f1) . + repeated @"many" FormE.Wrap f2 . + case f3 of + Nothing -> + FormE.omitted + Just (TestProtoWrappers.TestFloatValuePickOneOne v) -> + optional @"one" (Just (FormE.Wrap v)) + +instance ToEncoder TestProtoWrappers.TestInt64Value + where + toEncoder (TestProtoWrappers.TestInt64Value f1 f2 f3) = FormE.fieldsToMessage $ + optional @"wrapper" (fmap FormE.Wrap f1) . + repeated @"many" FormE.Wrap f2 . + case f3 of + Nothing -> + FormE.omitted + Just (TestProtoWrappers.TestInt64ValuePickOneOne v) -> + optional @"one" (Just (FormE.Wrap v)) + +instance ToEncoder TestProtoWrappers.TestUInt64Value + where + toEncoder (TestProtoWrappers.TestUInt64Value f1 f2 f3) = FormE.fieldsToMessage $ + optional @"wrapper" (fmap FormE.Wrap f1) . + repeated @"many" FormE.Wrap f2 . + case f3 of + Nothing -> + FormE.omitted + Just (TestProtoWrappers.TestUInt64ValuePickOneOne v) -> + optional @"one" (Just (FormE.Wrap v)) + +instance ToEncoder TestProtoWrappers.TestInt32Value + where + toEncoder (TestProtoWrappers.TestInt32Value f1 f2 f3) = FormE.fieldsToMessage $ + optional @"wrapper" (fmap FormE.Wrap f1) . + repeated @"many" FormE.Wrap f2 . + case f3 of + Nothing -> + FormE.omitted + Just (TestProtoWrappers.TestInt32ValuePickOneOne v) -> + optional @"one" (Just (FormE.Wrap v)) + +instance ToEncoder TestProtoWrappers.TestUInt32Value + where + toEncoder (TestProtoWrappers.TestUInt32Value f1 f2 f3) = FormE.fieldsToMessage $ + optional @"wrapper" (fmap FormE.Wrap f1) . + repeated @"many" FormE.Wrap f2 . + case f3 of + Nothing -> + FormE.omitted + Just (TestProtoWrappers.TestUInt32ValuePickOneOne v) -> + optional @"one" (Just (FormE.Wrap v)) + +instance ToEncoder TestProtoWrappers.TestBoolValue + where + toEncoder (TestProtoWrappers.TestBoolValue f1 f2 f3) = FormE.fieldsToMessage $ + optional @"wrapper" (fmap FormE.Wrap f1) . + repeated @"many" FormE.Wrap f2 . + case f3 of + Nothing -> + FormE.omitted + Just (TestProtoWrappers.TestBoolValuePickOneOne v) -> + optional @"one" (Just (FormE.Wrap v)) + +instance ToEncoder TestProtoWrappers.TestStringValue + where + toEncoder (TestProtoWrappers.TestStringValue f1 f2 f3) = FormE.fieldsToMessage $ + optional @"wrapper" (fmap FormE.Wrap f1) . + repeated @"many" FormE.Wrap f2 . + case f3 of + Nothing -> + FormE.omitted + Just (TestProtoWrappers.TestStringValuePickOneOne v) -> + optional @"one" (Just (FormE.Wrap v)) + +instance ToEncoder TestProtoWrappers.TestBytesValue + where + toEncoder (TestProtoWrappers.TestBytesValue f1 f2 f3) = FormE.fieldsToMessage $ + optional @"wrapper" (fmap FormE.Wrap f1) . + repeated @"many" FormE.Wrap f2 . + case f3 of + Nothing -> + FormE.omitted + Just (TestProtoWrappers.TestBytesValuePickOneOne v) -> + optional @"one" (Just (FormE.Wrap v)) + +instance ToEncoder WrappedTrivial + where + toEncoder (WrappedTrivial f1) = FormE.fieldsToMessage $ + optional @"trivial" (fmap @Maybe toEncoder f1) + +instance ToEncoder MapTest + where + toEncoder (MapTest f1 f2 f3) = FormE.fieldsToMessage $ + associations @"prim" assoc1 f1 . + associations @"trivial" assoc2 f2 . + associations @"signed" assoc3 f3 + where + assoc1 (k, v) = FormE.fieldsToMessage $ + implicit @"key" k . + implicit @"value" v + + assoc2 (k, v) = FormE.fieldsToMessage $ + implicit @"key" k . + optional @"value" (fmap @Maybe toEncoder v) + + assoc3 (k, v) = FormE.fieldsToMessage $ + implicit @"key" k . + implicit @"value" v + +instance ToEncoder TestProtoNegativeEnum.WithNegativeEnum + where + toEncoder (TestProtoNegativeEnum.WithNegativeEnum f1) = FormE.fieldsToMessage $ + implicit @"v" f1 + +instance ToEncoder TestProtoOptional.Submessage + where + toEncoder (TestProtoOptional.Submessage f1) = FormE.fieldsToMessage $ + implicit @"someField" f1 + +instance ToEncoder TestProtoOptional.WithOptional + where + toEncoder (TestProtoOptional.WithOptional + f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 f12 f13 f14 f15 f16 f17 + ) = FormE.fieldsToMessage $ + optional @"optionalDouble" f1 . + optional @"optionalFloat" f2 . + optional @"optionalInt32" f3 . + optional @"optionalInt64" f4 . + optional @"optionalUint32" f5 . + optional @"optionalUint64" f6 . + optional @"optionalSint32" f7 . + optional @"optionalSint64" f8 . + optional @"optionalFixed32" f9 . + optional @"optionalFixed64" f10 . + optional @"optionalSfixed32" f11 . + optional @"optionalSfixed64" f12 . + optional @"optionalBool" f13 . + optional @"optionalString" f14 . + optional @"optionalBytes" f15 . + optional @"optionalEnum" f16 . + optional @"optionalSubmessage" (fmap @Maybe toEncoder f17) + +#endif diff --git a/tests/TestCodeGen.hs b/tests/TestCodeGen.hs --- a/tests/TestCodeGen.hs +++ b/tests/TestCodeGen.hs @@ -1,105 +1,127 @@ {-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE DisambiguateRecordFields #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedLists #-} -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeApplications #-} module TestCodeGen where import ArbitraryGeneratedTestTypes () import Control.Applicative import Control.Monad +#ifdef SWAGGER import qualified Data.Aeson +#endif import qualified Data.ByteString.Lazy as LBS import Data.Proxy (Proxy(..)) import Data.String (IsString) +#ifdef SWAGGER import Data.Swagger (ToSchema) import qualified Data.Swagger +#endif import qualified Data.Text as T -import Data.Typeable (Typeable, splitTyConApp, - tyConName, typeRep) +import Data.Typeable (Typeable, typeRep, +#ifdef SWAGGER + splitTyConApp, tyConName +#endif + ) +import GHC.Exts (Proxy#, proxy#) +#ifdef SWAGGER +import GHC.Stack (HasCallStack) +#endif import Google.Protobuf.Timestamp (Timestamp(..)) import Prelude hiding (FilePath) -import Proto3.Suite.Class (def) -import Proto3.Suite.DotProto.Generate +import Proto3.Suite.Class (Message(..), def) import Proto3.Suite.DotProto (fieldLikeName, prefixedEnumFieldName, typeLikeName) +import Proto3.Suite.DotProto.AST (DotProtoField(..), DotProtoIdentifier(..), + DotProtoType(..), DotProtoPrimType(..)) +import Proto3.Suite.DotProto.Generate +import Proto3.Suite.Haskell.Parser (Logger) import Proto3.Suite.JSONPB (FromJSONPB (..), Options (..), ToJSONPB (..), defaultOptions, eitherDecode, encode, jsonPBOptions) import Proto3.Suite.Types (Enumerated(..)) import System.Exit +import Test.Proto.ToEncoder (Iterator, Stripping) import Test.Tasty import Test.Tasty.HUnit (testCase, (@?=)) import Test.Tasty.QuickCheck (Arbitrary, (===), testProperty) import qualified Turtle import qualified Turtle.Format as F import qualified TestProto +import qualified TestProtoNegativeEnum import qualified TestProtoOneof +import qualified TestProtoOptional +#ifdef SWAGGER import qualified TestProtoWrappers +#endif -codeGenTests :: TestTree -codeGenTests = testGroup "Code generator unit tests" - [ jsonpbTests - , swaggerTests +codeGenTests :: Logger -> TestTree +codeGenTests logger = testGroup "Code generator unit tests" + [ dotProtoTests + , jsonpbTests , hasDefaultTests - , swaggerWrapperFormat , pascalCaseMessageNames , camelCaseMessageFieldNames , don'tAlterEnumFieldNames , knownTypeMessages - , pythonInteroperation + , pythonInteroperation logger +#ifdef SWAGGER + , swaggerTests + , swaggerWrapperFormat +#endif ] -pythonInteroperation :: TestTree -pythonInteroperation = testGroup "Python interoperation" $ do -#ifdef LARGE_RECORDS - recStyle <- [RegularRecords, LargeRecords] -#else - recStyle <- [RegularRecords] -#endif +pythonInteroperation :: Logger -> TestTree +pythonInteroperation logger = testGroup "Python interoperation" $ do tt <- ["Data.Text.Lazy.Text", "Data.Text.Text", "Data.Text.Short.ShortText"] format <- ["Binary", "Jsonpb"] - direction <- [simpleEncodeDotProto, simpleDecodeDotProto] - pure @[] (direction recStyle tt format) + testEncode <- [True, False] + direct <- [False, True] + guard $ not direct || (testEncode && format == "Binary") + let f = if testEncode then simpleEncodeDotProto direct else simpleDecodeDotProto + pure @[] (f logger tt format) +#ifdef SWAGGER swaggerWrapperFormat :: TestTree swaggerWrapperFormat = testGroup "Swagger Wrapper Format" [ expectSchema @TestProtoWrappers.TestDoubleValue - "{\"properties\":{\"wrapper\":{\"format\":\"DoubleValue\",\"type\":\"number\"}},\"type\":\"object\"}" - "{\"properties\":{\"wrapper\":{\"format\":\"double\",\"type\":\"number\"}},\"type\":\"object\"}" + "{\"properties\":{\"wrapper\":{\"format\":\"DoubleValue\",\"type\":\"number\"},\"many\":{\"items\":{\"format\":\"double\",\"type\":\"number\"},\"type\":\"array\"},\"pickOne\":{\"$ref\":\"#/definitions/TestDoubleValuePickOne\"}},\"type\":\"object\"}" + "{\"properties\":{\"wrapper\":{\"format\":\"double\",\"type\":\"number\"},\"many\":{\"items\":{\"format\":\"double\",\"type\":\"number\"},\"type\":\"array\"},\"pickOne\":{\"$ref\":\"#/definitions/TestDoubleValuePickOne\"}},\"type\":\"object\"}" , expectSchema @TestProtoWrappers.TestFloatValue - "{\"properties\":{\"wrapper\":{\"format\":\"FloatValue\",\"type\":\"number\"}},\"type\":\"object\"}" - "{\"properties\":{\"wrapper\":{\"format\":\"float\",\"type\":\"number\"}},\"type\":\"object\"}" + "{\"properties\":{\"wrapper\":{\"format\":\"FloatValue\",\"type\":\"number\"},\"many\":{\"items\":{\"format\":\"float\",\"type\":\"number\"},\"type\":\"array\"},\"pickOne\":{\"$ref\":\"#/definitions/TestFloatValuePickOne\"}},\"type\":\"object\"}" + "{\"properties\":{\"wrapper\":{\"format\":\"float\",\"type\":\"number\"},\"many\":{\"items\":{\"format\":\"float\",\"type\":\"number\"},\"type\":\"array\"},\"pickOne\":{\"$ref\":\"#/definitions/TestFloatValuePickOne\"}},\"type\":\"object\"}" , expectSchema @TestProtoWrappers.TestInt64Value - "{\"properties\":{\"wrapper\":{\"format\":\"Int64Value\",\"maximum\":9223372036854775807,\"minimum\":-9223372036854775808,\"type\":\"integer\"}},\"type\":\"object\"}" - "{\"properties\":{\"wrapper\":{\"format\":\"int64\",\"maximum\":9223372036854775807,\"minimum\":-9223372036854775808,\"type\":\"integer\"}},\"type\":\"object\"}" + "{\"properties\":{\"wrapper\":{\"format\":\"Int64Value\",\"maximum\":9223372036854775807,\"minimum\":-9223372036854775808,\"type\":\"integer\"},\"many\":{\"items\":{\"format\":\"int64\",\"maximum\":9223372036854775807,\"minimum\":-9223372036854775808,\"type\":\"integer\"},\"type\":\"array\"},\"pickOne\":{\"$ref\":\"#/definitions/TestInt64ValuePickOne\"}},\"type\":\"object\"}" + "{\"properties\":{\"wrapper\":{\"format\":\"int64\",\"maximum\":9223372036854775807,\"minimum\":-9223372036854775808,\"type\":\"integer\"},\"many\":{\"items\":{\"format\":\"int64\",\"maximum\":9223372036854775807,\"minimum\":-9223372036854775808,\"type\":\"integer\"},\"type\":\"array\"},\"pickOne\":{\"$ref\":\"#/definitions/TestInt64ValuePickOne\"}},\"type\":\"object\"}" , expectSchema @TestProtoWrappers.TestUInt64Value - "{\"properties\":{\"wrapper\":{\"format\":\"UInt64Value\",\"maximum\":18446744073709551615,\"minimum\":0,\"type\":\"integer\"}},\"type\":\"object\"}" - "{\"properties\":{\"wrapper\":{\"format\":\"int64\",\"maximum\":18446744073709551615,\"minimum\":0,\"type\":\"integer\"}},\"type\":\"object\"}" + "{\"properties\":{\"wrapper\":{\"format\":\"UInt64Value\",\"maximum\":18446744073709551615,\"minimum\":0,\"type\":\"integer\"},\"many\":{\"items\":{\"format\":\"int64\",\"maximum\":18446744073709551615,\"minimum\":0,\"type\":\"integer\"},\"type\":\"array\"},\"pickOne\":{\"$ref\":\"#/definitions/TestUInt64ValuePickOne\"}},\"type\":\"object\"}" + "{\"properties\":{\"wrapper\":{\"format\":\"int64\",\"maximum\":18446744073709551615,\"minimum\":0,\"type\":\"integer\"},\"many\":{\"items\":{\"format\":\"int64\",\"maximum\":18446744073709551615,\"minimum\":0,\"type\":\"integer\"},\"type\":\"array\"},\"pickOne\":{\"$ref\":\"#/definitions/TestUInt64ValuePickOne\"}},\"type\":\"object\"}" , expectSchema @TestProtoWrappers.TestInt32Value - "{\"properties\":{\"wrapper\":{\"format\":\"Int32Value\",\"maximum\":2147483647,\"minimum\":-2147483648,\"type\":\"integer\"}},\"type\":\"object\"}" - "{\"properties\":{\"wrapper\":{\"format\":\"int32\",\"maximum\":2147483647,\"minimum\":-2147483648,\"type\":\"integer\"}},\"type\":\"object\"}" + "{\"properties\":{\"wrapper\":{\"format\":\"Int32Value\",\"maximum\":2147483647,\"minimum\":-2147483648,\"type\":\"integer\"},\"many\":{\"items\":{\"format\":\"int32\",\"maximum\":2147483647,\"minimum\":-2147483648,\"type\":\"integer\"},\"type\":\"array\"},\"pickOne\":{\"$ref\":\"#/definitions/TestInt32ValuePickOne\"}},\"type\":\"object\"}" + "{\"properties\":{\"wrapper\":{\"format\":\"int32\",\"maximum\":2147483647,\"minimum\":-2147483648,\"type\":\"integer\"},\"many\":{\"items\":{\"format\":\"int32\",\"maximum\":2147483647,\"minimum\":-2147483648,\"type\":\"integer\"},\"type\":\"array\"},\"pickOne\":{\"$ref\":\"#/definitions/TestInt32ValuePickOne\"}},\"type\":\"object\"}" , expectSchema @TestProtoWrappers.TestUInt32Value - "{\"properties\":{\"wrapper\":{\"format\":\"UInt32Value\",\"maximum\":4294967295,\"minimum\":0,\"type\":\"integer\"}},\"type\":\"object\"}" - "{\"properties\":{\"wrapper\":{\"format\":\"int32\",\"maximum\":4294967295,\"minimum\":0,\"type\":\"integer\"}},\"type\":\"object\"}" + "{\"properties\":{\"wrapper\":{\"format\":\"UInt32Value\",\"maximum\":4294967295,\"minimum\":0,\"type\":\"integer\"},\"many\":{\"items\":{\"format\":\"int32\",\"maximum\":4294967295,\"minimum\":0,\"type\":\"integer\"},\"type\":\"array\"},\"pickOne\":{\"$ref\":\"#/definitions/TestUInt32ValuePickOne\"}},\"type\":\"object\"}" + "{\"properties\":{\"wrapper\":{\"format\":\"int32\",\"maximum\":4294967295,\"minimum\":0,\"type\":\"integer\"},\"many\":{\"items\":{\"format\":\"int32\",\"maximum\":4294967295,\"minimum\":0,\"type\":\"integer\"},\"type\":\"array\"},\"pickOne\":{\"$ref\":\"#/definitions/TestUInt32ValuePickOne\"}},\"type\":\"object\"}" , expectSchema @TestProtoWrappers.TestBoolValue - "{\"properties\":{\"wrapper\":{\"format\":\"BoolValue\",\"type\":\"boolean\"}},\"type\":\"object\"}" - "{\"properties\":{\"wrapper\":{\"type\":\"boolean\"}},\"type\":\"object\"}" + "{\"properties\":{\"wrapper\":{\"format\":\"BoolValue\",\"type\":\"boolean\"},\"many\":{\"items\":{\"type\":\"boolean\"},\"type\":\"array\"},\"pickOne\":{\"$ref\":\"#/definitions/TestBoolValuePickOne\"}},\"type\":\"object\"}" + "{\"properties\":{\"wrapper\":{\"type\":\"boolean\"},\"many\":{\"items\":{\"type\":\"boolean\"},\"type\":\"array\"},\"pickOne\":{\"$ref\":\"#/definitions/TestBoolValuePickOne\"}},\"type\":\"object\"}" , expectSchema @TestProtoWrappers.TestStringValue - "{\"properties\":{\"wrapper\":{\"format\":\"StringValue\",\"type\":\"string\"}},\"type\":\"object\"}" - "{\"properties\":{\"wrapper\":{\"type\":\"string\"}},\"type\":\"object\"}" + "{\"properties\":{\"wrapper\":{\"format\":\"StringValue\",\"type\":\"string\"},\"many\":{\"items\":{\"type\":\"string\"},\"type\":\"array\"},\"pickOne\":{\"$ref\":\"#/definitions/TestStringValuePickOne\"}},\"type\":\"object\"}" + "{\"properties\":{\"wrapper\":{\"type\":\"string\"},\"many\":{\"items\":{\"type\":\"string\"},\"type\":\"array\"},\"pickOne\":{\"$ref\":\"#/definitions/TestStringValuePickOne\"}},\"type\":\"object\"}" , expectSchema @TestProtoWrappers.TestBytesValue - "{\"properties\":{\"wrapper\":{\"format\":\"BytesValue\",\"type\":\"string\"}},\"type\":\"object\"}" - "{\"properties\":{\"wrapper\":{\"format\":\"byte\",\"type\":\"string\"}},\"type\":\"object\"}" + "{\"properties\":{\"wrapper\":{\"format\":\"BytesValue\",\"type\":\"string\"},\"many\":{\"items\":{\"format\":\"byte\",\"type\":\"string\"},\"type\":\"array\"},\"pickOne\":{\"$ref\":\"#/definitions/TestBytesValuePickOne\"}},\"type\":\"object\"}" + "{\"properties\":{\"wrapper\":{\"format\":\"byte\",\"type\":\"string\"},\"many\":{\"items\":{\"format\":\"byte\",\"type\":\"string\"},\"type\":\"array\"},\"pickOne\":{\"$ref\":\"#/definitions/TestBytesValuePickOne\"}},\"type\":\"object\"}" ] where expectSchema :: forall a . - (ToSchema a, Typeable a) => + (ToSchema a, Typeable a, HasCallStack) => LBS.ByteString -> LBS.ByteString -> TestTree @@ -113,6 +135,7 @@ #else wf = False #endif +#endif knownTypeMessages :: TestTree knownTypeMessages = @@ -174,41 +197,58 @@ setPythonPath = Turtle.export "PYTHONPATH" . maybe pyTmpDir (\p -> pyTmpDir <> ":" <> p) =<< Turtle.need "PYTHONPATH" -simpleEncodeDotProto :: RecordStyle -> String -> T.Text -> TestTree -simpleEncodeDotProto recStyle chosenStringType format = +simpleEncodeDotProto :: Bool -> Logger -> String -> T.Text -> TestTree +simpleEncodeDotProto direct logger chosenStringType format = testCase ("generate code for a simple .proto and then use it to encode messages" ++ " with string type " ++ chosenStringType ++ " in format " ++ show format ++ - ", record style " ++ show recStyle) + (if direct then ", direct mode" else ", intermediate mode")) $ do decodedStringType <- either die pure (parseStringType chosenStringType) - compileTestDotProtos recStyle decodedStringType + compileTestDotProtos logger decodedStringType direct -- Compile our generated encoder let encodeCmd = "tests/encode.sh " <> hsTmpDir + <> (if direct then " -DTYPE_LEVEL_FORMAT" else "") #if DHALL <> " -DDHALL" #endif Turtle.shell encodeCmd empty >>= (@?= ExitSuccess) - -- The python encoder test exits with a special error code to indicate - -- all tests were successful + -- The python test of encoding exits with a special error code to indicate + -- all tests were successful. When directly encoding without an intermediate + -- data structure, we run the test several times (still compiling just once) + -- in order to cover various supported ways of iterating over repeated fields. setPythonPath - let cmd = hsTmpDir <> "/simpleEncodeDotProto " <> format <> " | python tests/check_simple_dot_proto.py " <> format - Turtle.shell cmd empty >>= (@?= ExitFailure 12) + let iterators :: [Iterator] + iterators + | direct = [minBound .. maxBound] + | otherwise = [minBound] -- Just an unused placeholder + strippings :: [Stripping] + strippings + | direct = [minBound .. maxBound] + | otherwise = [minBound] -- Just an unused placeholder + forM_ iterators $ \(iterator :: Iterator) -> do + forM_ strippings $ \(stripping :: Stripping) -> do + when direct $ do + putStrLn $ " iterator: " ++ show iterator + putStrLn $ " stripping: " ++ show stripping + let cmd = hsTmpDir <> "/simpleEncodeDotProto " <> format <> + " " <> T.pack (show iterator) <> " " <> T.pack (show stripping) <> + " | python tests/check_simple_dot_proto.py " <> format + Turtle.shell cmd empty >>= (@?= ExitFailure 12) -- Not using bracket so that we can inspect the output to fix the tests Turtle.rmtree hsTmpDir Turtle.rmtree pyTmpDir -simpleDecodeDotProto :: RecordStyle -> String -> T.Text -> TestTree -simpleDecodeDotProto recStyle chosenStringType format = +simpleDecodeDotProto :: Logger -> String -> T.Text -> TestTree +simpleDecodeDotProto logger chosenStringType format = testCase ("generate code for a simple .proto and then use it to decode messages" ++ - " with string type " ++ chosenStringType ++ " in format " ++ show format ++ - ", record style " ++ show recStyle) + " with string type " ++ chosenStringType ++ " in format " ++ show format) $ do decodedStringType <- either die pure (parseStringType chosenStringType) - compileTestDotProtos recStyle decodedStringType + compileTestDotProtos logger decodedStringType False -- Compile our generated decoder let decodeCmd = "tests/decode.sh " <> hsTmpDir #if DHALL @@ -233,14 +273,15 @@ defaultStringType :: StringType defaultStringType = StringType "Data.Text.Lazy" "Text" -compileTestDotProtos :: RecordStyle -> StringType -> IO () -compileTestDotProtos recStyle decodedStringType = do +compileTestDotProtos :: Logger -> StringType -> Bool -> IO () +compileTestDotProtos logger decodedStringType typeLevel = do Turtle.mktree hsTmpDir Turtle.mktree pyTmpDir let protoFiles :: [Turtle.FilePath] protoFiles = [ "test_proto.proto" , "test_proto_import.proto" + , "test_proto_negative_enum.proto" , "test_proto_oneof.proto" , "test_proto_oneof_import.proto" {- These tests have been temporarily removed to pass CI. @@ -249,16 +290,18 @@ -} , "test_proto_nested_message.proto" , "test_proto_wrappers.proto" + , "test_proto_negative_enum.proto" + , "test_proto_optional.proto" ] forM_ protoFiles $ \protoFile -> do - compileDotProtoFileOrDie + compileDotProtoFileOrDie logger CompileArgs{ includeDir = ["test-files"] , extraInstanceFiles = ["test-files" Turtle. "Orphan.hs"] , outputDir = hsTmpDir , inputProto = protoFile , stringType = decodedStringType - , recordStyle = recStyle + , typeLevelFormat = typeLevel } let cmd = T.concat [ "protoc --python_out=" @@ -270,6 +313,57 @@ Turtle.touch (pyTmpDir Turtle. "__init__.py") +dotProtoTests :: TestTree +dotProtoTests = testGroup "dotProto method tests" + [ dotProtoTest @TestProto.Trivial + [ DotProtoField 1 (Prim Int32) (Single "trivialField") [] "" + ] + , dotProtoTest @TestProto.MultipleFields + [ DotProtoField 1 (Prim Double) (Single "multiFieldDouble") [] "" + , DotProtoField 2 (Prim Float) (Single "multiFieldFloat") [] "" + , DotProtoField 3 (Prim Int32) (Single "multiFieldInt32") [] "" + , DotProtoField 4 (Prim Int64) (Single "multiFieldInt64") [] "" + , DotProtoField 5 (Prim String) (Single "multiFieldString") [] "" + , DotProtoField 6 (Prim Bool) (Single "multiFieldBool") [] "" + ] + , dotProtoTest @TestProto.SignedInts + [ DotProtoField 1 (Prim SInt32) (Single "signed32") [] "" + , DotProtoField 2 (Prim SInt64) (Single "signed64") [] "" + ] + , dotProtoTest @TestProto.MapTest + [ DotProtoField 1 (Map String SInt32) (Single "prim") [] "" + , DotProtoField 2 (Map Int32 (Named (Single "WrappedTrivial"))) (Single "trivial") [] "" + , DotProtoField 3 (Map SInt32 SInt32) (Single "signed") [] "" + -- Current parser discards comments. + ] + , dotProtoTest @TestProto.WithNestingRepeatedInts + [ DotProtoField 1 (Repeated (Named (Single "NestedInts"))) (Single "nestedInts") [] "" + ] + , dotProtoTest @TestProto.WithRepeatedSigned + [ DotProtoField 1 (Repeated SInt32) (Single "r32") [] "" + , DotProtoField 2 (Repeated SInt64) (Single "r64") [] "" + ] + , dotProtoTest @TestProtoOptional.WithOptional + [ DotProtoField 10 (Optional Double) (Single "optionalDouble") [] "" + , DotProtoField 20 (Optional Float) (Single "optionalFloat") [] "" + , DotProtoField 30 (Optional Int32) (Single "optionalInt32") [] "" + , DotProtoField 40 (Optional Int64) (Single "optionalInt64") [] "" + , DotProtoField 50 (Optional UInt32) (Single "optionalUint32") [] "" + , DotProtoField 60 (Optional UInt64) (Single "optionalUint64") [] "" + , DotProtoField 70 (Optional SInt32) (Single "optionalSint32") [] "" + , DotProtoField 80 (Optional SInt64) (Single "optionalSint64") [] "" + , DotProtoField 90 (Optional Fixed32) (Single "optionalFixed32") [] "" + , DotProtoField 100 (Optional Fixed64) (Single "optionalFixed64") [] "" + , DotProtoField 110 (Optional SFixed32) (Single "optionalSfixed32") [] "" + , DotProtoField 120 (Optional SFixed64) (Single "optionalSfixed64") [] "" + , DotProtoField 130 (Optional Bool) (Single "optionalBool") [] "" + , DotProtoField 140 (Optional String) (Single "optionalString") [] "" + , DotProtoField 150 (Optional Bytes) (Single "optionalBytes") [] "" + , DotProtoField 160 (Optional (Named (Single "Enum"))) (Single "optionalEnum") [] "" + , DotProtoField 170 (Optional (Named (Single "Submessage"))) (Single "optionalSubmessage") [] "" + ] + ] + jsonpbTests :: TestTree jsonpbTests = testGroup "JSONPB tests" [ testGroup "Round-trip tests" @@ -291,6 +385,8 @@ , roundTripTest @TestProto.Wrapped , roundTripTest @TestProtoOneof.Something , roundTripTest @TestProtoOneof.WithImported + , roundTripTest @TestProtoNegativeEnum.WithNegativeEnum + , roundTripTest @TestProtoOptional.WithOptional ] , testGroup "Specific encoding tests" $ let jsonPB = jsonPBOptions @@ -376,6 +472,7 @@ ] ] +#ifdef SWAGGER swaggerTests :: TestTree swaggerTests = testGroup "Swagger tests" [ schemaOf @TestProtoOneof.Something @@ -386,8 +483,28 @@ "{\"properties\":{\"dummy\":{\"format\":\"int32\",\"maximum\":2147483647,\"minimum\":-2147483648,\"type\":\"integer\"}},\"type\":\"object\"}" , schemaOf @(Enumerated TestProtoOneof.DummyEnum) "{\"enum\":[\"DUMMY0\",\"DUMMY1\"],\"type\":\"string\"}" - + , schemaOf @TestProtoOptional.WithOptional $ + "{\"properties\":{" <> + "\"optionalDouble\":{\"format\":\"double\",\"type\":\"number\"}," <> + "\"optionalFloat\":{\"format\":\"float\",\"type\":\"number\"}," <> + "\"optionalInt32\":{\"format\":\"int32\",\"maximum\":2147483647,\"minimum\":-2147483648,\"type\":\"integer\"}," <> + "\"optionalInt64\":{\"format\":\"int64\",\"maximum\":9223372036854775807,\"minimum\":-9223372036854775808,\"type\":\"integer\"}," <> + "\"optionalUint32\":{\"format\":\"int32\",\"maximum\":4294967295,\"minimum\":0,\"type\":\"integer\"}," <> + "\"optionalUint64\":{\"format\":\"int64\",\"maximum\":18446744073709551615,\"minimum\":0,\"type\":\"integer\"}," <> + "\"optionalSint32\":{\"format\":\"int32\",\"maximum\":2147483647,\"minimum\":-2147483648,\"type\":\"integer\"}," <> + "\"optionalSint64\":{\"format\":\"int64\",\"maximum\":9223372036854775807,\"minimum\":-9223372036854775808,\"type\":\"integer\"}," <> + "\"optionalFixed32\":{\"format\":\"int32\",\"maximum\":4294967295,\"minimum\":0,\"type\":\"integer\"}," <> + "\"optionalFixed64\":{\"format\":\"int64\",\"maximum\":18446744073709551615,\"minimum\":0,\"type\":\"integer\"}," <> + "\"optionalSfixed32\":{\"format\":\"int32\",\"maximum\":2147483647,\"minimum\":-2147483648,\"type\":\"integer\"}," <> + "\"optionalSfixed64\":{\"format\":\"int64\",\"maximum\":9223372036854775807,\"minimum\":-9223372036854775808,\"type\":\"integer\"}," <> + "\"optionalBool\":{\"type\":\"boolean\"}," <> + "\"optionalString\":{\"type\":\"string\"}," <> + "\"optionalBytes\":{\"format\":\"byte\",\"type\":\"string\"}," <> + "\"optionalEnum\":{\"$ref\":\"#/definitions/Enum\"}," <> + "\"optionalSubmessage\":{\"$ref\":\"#/definitions/Submessage\"}" <> + "},\"type\":\"object\"}" ] +#endif hasDefaultTests :: TestTree hasDefaultTests = testGroup "Generic HasDefault" @@ -407,6 +524,15 @@ -- * Helper quickcheck props +dotProtoTest :: + forall a . + (Message a, Typeable a) => + [DotProtoField] -> + TestTree +dotProtoTest expected = + testProperty ("dotProtoTest @" ++ show (typeRep (Proxy :: Proxy a))) $ + dotProto (proxy# :: Proxy# a) === expected + roundTripTest :: forall a . (ToJSONPB a, FromJSONPB a, Eq a, Arbitrary a, Show a, Typeable a) => @@ -454,6 +580,7 @@ showString " == Right " . showsPrec 11 x +#ifdef SWAGGER schemaOf :: forall a . (ToSchema a, Eq a, Show a, Typeable a) => @@ -468,3 +595,4 @@ lbsSchemaOf :: forall a . ToSchema a => LBS.ByteString lbsSchemaOf = Data.Aeson.encode (Data.Swagger.toSchema (Proxy @a)) +#endif diff --git a/tests/decode.sh b/tests/decode.sh --- a/tests/decode.sh +++ b/tests/decode.sh @@ -11,8 +11,10 @@ "$@" \ $hsTmpDir/TestProto.hs \ $hsTmpDir/TestProtoImport.hs \ + $hsTmpDir/TestProtoNegativeEnum.hs \ $hsTmpDir/TestProtoOneof.hs \ $hsTmpDir/TestProtoOneofImport.hs \ + $hsTmpDir/TestProtoOptional.hs \ $hsTmpDir/TestProtoWrappers.hs \ tests/Test/Dhall/Orphan.hs \ tests/SimpleDecodeDotProto.hs \ diff --git a/tests/encode.sh b/tests/encode.sh --- a/tests/encode.sh +++ b/tests/encode.sh @@ -11,10 +11,13 @@ "$@" \ $hsTmpDir/TestProto.hs \ $hsTmpDir/TestProtoImport.hs \ + $hsTmpDir/TestProtoNegativeEnum.hs \ $hsTmpDir/TestProtoOneof.hs \ $hsTmpDir/TestProtoOneofImport.hs \ + $hsTmpDir/TestProtoOptional.hs \ $hsTmpDir/TestProtoWrappers.hs \ tests/Test/Dhall/Orphan.hs \ + tests/Test/Proto/ToEncoder.hs \ tests/SimpleEncodeDotProto.hs \ >/dev/null diff --git a/tools/canonicalize-proto-file/Main.hs b/tools/canonicalize-proto-file/Main.hs --- a/tools/canonicalize-proto-file/Main.hs +++ b/tools/canonicalize-proto-file/Main.hs @@ -1,6 +1,5 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE LambdaCase #-} @@ -11,26 +10,61 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} -module Main (main) where +module Main where -import Control.Monad.Except -import Data.List (sort, sortOn) -import qualified Data.List.NonEmpty as NE -import Data.RangeSet.List (fromRangeList, toRangeList) -import Data.Semigroup (Min(..)) -import Options.Generic -import Prelude hiding (FilePath) -import Proto3.Suite.DotProto.AST -import Proto3.Suite.DotProto.Generate -import Proto3.Suite.DotProto.Rendering -import Proto3.Wire.Types (FieldNumber (..)) -import Turtle (FilePath) +import Control.Monad.Except (runExceptT) +import Data.List (sort, sortOn) +import Data.List.NonEmpty qualified as NE +import Data.Semigroup (Min(..)) + +import GHC.Generics (Generic) + +import Options.Generic + ( ParseRecord + , Unwrapped + , Wrapped + , (:::) + , type () (..) + , unwrapRecord + ) + +import Prelude hiding (FilePath) + +import Proto3.Suite.DotProto.AST + ( DotProto (..) + , DotProtoDefinition (..) + , DotProtoEnumPart (..) + , DotProtoEnumValue + , DotProtoField (..) + , DotProtoIdentifier (..) + , DotProtoImport (..) + , DotProtoMessagePart (..) + , DotProtoOption (..) + , DotProtoPackageSpec (..) + , DotProtoServicePart (..) + , DotProtoReservedField (..) + , DotProtoType (..) + , DotProtoValue (..) + , Path (..) + , RPCMethod (..) + ) +import Proto3.Suite.DotProto.Generate (readDotProtoWithContext) +import Proto3.Suite.DotProto.Internal (normalizeIntervals) +import Proto3.Suite.DotProto.Rendering (defRenderingOptions, toProtoFile) +import Proto3.Wire.Types (FieldNumber (..)) + +import Turtle (FilePath) + +-------------------------------------------------------------------------------- + data Args w = Args { includeDir :: w ::: [FilePath] "Path to search for included .proto files (can be repeated, and paths will be searched in order; the current directory is used if this option is not provided)" , proto :: w ::: FilePath "Path to input .proto file" } deriving Generic + instance ParseRecord (Args Wrapped) + deriving instance Show (Args Unwrapped) main :: IO () @@ -150,15 +184,10 @@ fmap getMin . foldMap (fmap Min . canonicalRank) instance Canonicalize [DotProtoField] where - canonicalize = canonicalSort . filter keep - where - keep DotProtoEmptyField = False - keep _ = True + canonicalize = canonicalSort instance CanonicalRank DotProtoField (Maybe FieldNumber) where - canonicalRank = \case - DotProtoField{..} -> Just dotProtoFieldNumber - DotProtoEmptyField -> Nothing + canonicalRank DotProtoField{..} = Just dotProtoFieldNumber instance Canonicalize DotProtoField where canonicalize DotProtoField{..} = DotProtoField @@ -169,7 +198,6 @@ , dotProtoFieldComment = "" -- In future we might add a command-line -- option to preserve comments. } - canonicalize DotProtoEmptyField = DotProtoEmptyField instance Canonicalize DotProtoType where canonicalize = id @@ -187,23 +215,20 @@ unique [n] = [n] unique (x : xs@(y : _)) = (if x == y then id else (x :)) (unique xs) - numbers = map reserveNumbers (toRangeList (fromRangeList rangeList)) + numbers = map reserveNumbers (normalizeIntervals rangeList) reserveNumbers (lo, hi) | lo == hi = SingleField lo | otherwise = FieldRange lo hi instance Canonicalize [DotProtoEnumPart] where - canonicalize = canonicalSort . filter keep - where - keep DotProtoEnumEmpty = False - keep _ = True + canonicalize = canonicalSort instance CanonicalRank DotProtoEnumPart (Either (Maybe DotProtoOption) DotProtoEnumValue) where canonicalRank = \case DotProtoEnumField _ value _ -> Right value DotProtoEnumOption option -> Left (Just option) - DotProtoEnumEmpty -> Left Nothing + DotProtoEnumReserved _ -> Left Nothing instance Canonicalize DotProtoEnumPart where canonicalize = \case @@ -211,21 +236,17 @@ DotProtoEnumField (canonicalize name) value (map canonicalize opts) DotProtoEnumOption option -> DotProtoEnumOption (canonicalize option) - DotProtoEnumEmpty -> - DotProtoEnumEmpty + DotProtoEnumReserved reservedFields -> + DotProtoEnumReserved (canonicalize reservedFields) instance Canonicalize [DotProtoServicePart] where - canonicalize = canonicalSort . filter keep - where - keep DotProtoServiceEmpty = False - keep _ = True + canonicalize = canonicalSort instance CanonicalRank DotProtoServicePart (Either (Maybe DotProtoOption) DotProtoIdentifier) where canonicalRank = \case DotProtoServiceRPCMethod method -> Right (rpcMethodName method) DotProtoServiceOption option -> Left (Just option) - DotProtoServiceEmpty -> Left Nothing instance Canonicalize DotProtoServicePart where canonicalize = \case @@ -233,8 +254,6 @@ DotProtoServiceRPCMethod (canonicalize guts) DotProtoServiceOption option -> DotProtoServiceOption (canonicalize option) - DotProtoServiceEmpty -> - DotProtoServiceEmpty instance Canonicalize RPCMethod where canonicalize (RPCMethod name reqN reqS rspN rspS options) = diff --git a/tools/compile-proto-file/Main.hs b/tools/compile-proto-file/Main.hs --- a/tools/compile-proto-file/Main.hs +++ b/tools/compile-proto-file/Main.hs @@ -11,11 +11,18 @@ import Options.Applicative import Prelude hiding (FilePath) import Proto3.Suite.DotProto.Generate +import Proto3.Suite.Haskell.Parser (initLogger) parseArgs :: ParserInfo CompileArgs parseArgs = info (helper <*> parser) (fullDesc <> progDesc "Compiles a .proto file to a Haskell module") where - parser = CompileArgs <$> includes <*> extraInstances <*> proto <*> out <*> stringType <*> recordStyle + parser = CompileArgs + <$> includes + <*> extraInstances + <*> proto + <*> out + <*> stringType + <*> typeLevelFormat includes = many $ strOption $ long "includeDir" @@ -38,14 +45,18 @@ <> help "Output directory path where generated Haskell modules will be written (directory is created if it does not exist; note that files in the output directory may be overwritten!)" stringType = option (eitherReader parseStringType) - $ long "string-type" + $ long "stringType" + <> long "string-type" <> metavar "Data.Text.Lazy.Text" - <> help "Haskell representation of strings" + <> help "Haskell representation of strings (--stringType is the preferred spelling)" <> value (StringType "Data.Text.Lazy" "Text") - recordStyle = flag RegularRecords LargeRecords - $ long "largeRecords" - <> help "Use large-records library to optimize the core code size of generated records" + typeLevelFormat = switch + $ long "typeLevelFormat" + <> help "Define formats at the type level (by instantiating type family FieldFormsOf)." main :: IO () -main = execParser parseArgs >>= compileDotProtoFileOrDie +main = do + logger <- initLogger + compileArgs <- execParser parseArgs + compileDotProtoFileOrDie logger compileArgs