proto3-suite 0.7.0 → 0.9.4

raw patch · 34 files changed

+8100/−2787 lines, 34 filesdep +attoparsec-aesondep +ghc-lib-parserdep +template-haskelldep −haskell-srcdep −large-genericsdep −large-recordsdep ~QuickCheckdep ~aesondep ~aeson-prettyPVP ok

version bump matches the API change (PVP)

Dependencies added: attoparsec-aeson, ghc-lib-parser, template-haskell

Dependencies removed: haskell-src, large-generics, large-records, range-set-list, semigroups

Dependency ranges changed: QuickCheck, aeson, aeson-pretty, attoparsec, base, binary, bytestring, containers, deepseq, dhall, filepath, foldl, hashable, insert-ordered-containers, lens, mtl, neat-interpolation, optparse-applicative, optparse-generic, parsec, pretty-show, proto3-wire, split, system-filepath, tasty, tasty-quickcheck, text, time, transformers, turtle, vector

API changes (from Hackage documentation)

Files

• CHANGELOG.md +91/−0
• proto3-suite.cabal +165/−131
• src/Google/Protobuf/Wrappers/Polymorphic.hs +1/−0
• src/Proto3/Suite/Class.hs +118/−40
• src/Proto3/Suite/DhallPB.hs +10/−0
• src/Proto3/Suite/DotProto/AST.hs +104/−11
• src/Proto3/Suite/DotProto/Generate.hs +2319/−2051
• src/Proto3/Suite/DotProto/Generate/LargeRecord.hs +0/−22
• src/Proto3/Suite/DotProto/Generate/Record.hs +6/−8
• src/Proto3/Suite/DotProto/Generate/Swagger.hs +4/−0
• src/Proto3/Suite/DotProto/Generate/Syntax.hs +1213/−178
• src/Proto3/Suite/DotProto/Internal.hs +211/−26
• src/Proto3/Suite/DotProto/Parsing.hs +99/−60
• src/Proto3/Suite/DotProto/Rendering.hs +12/−107
• src/Proto3/Suite/Form.hs +403/−0
• src/Proto3/Suite/Form/Encode.hs +573/−0
• src/Proto3/Suite/Form/Encode/Core.hs +778/−0
• src/Proto3/Suite/Haskell/Parser.hs +248/−0
• src/Proto3/Suite/JSONPB/Class.hs +26/−8
• src/Proto3/Suite/Types.hs +19/−5
• test-files/with_repeated_signed.bin binary
• tests/ArbitraryGeneratedTestTypes.hs +42/−0
• tests/Main.hs +623/−18
• tests/Test/Proto/Generate/Name.hs +3/−3
• tests/Test/Proto/Interval.hs +181/−0
• tests/Test/Proto/Parse.hs +21/−0
• tests/Test/Proto/Parse/Core.hs +24/−0
• tests/Test/Proto/Parse/Option.hs +7/−14
• tests/Test/Proto/ToEncoder.hs +531/−0
• tests/TestCodeGen.hs +189/−61
• tests/decode.sh +2/−0
• tests/encode.sh +3/−0
• tools/canonicalize-proto-file/Main.hs +56/−37
• tools/compile-proto-file/Main.hs +18/−7

@@ -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.

@@ -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 <https://github.com/awakesecurity/proto3-wire the `proto3-wire` library>@@ -17,12 +17,19 @@ license:             Apache-2.0 author:              Arista Networks <opensource@awakesecurity.com> maintainer:          Arista Networks <opensource@awakesecurity.com>-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

@@ -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

@@ -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+    -- <https://protobuf.dev/programming-guides/proto3/#updating> 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:+    -- <https://protobuf.dev/programming-guides/dos-donts/> 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

@@ -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)) --------------------------------------------------------------------------------

@@ -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 ";"

@@ -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 = (<case expr scrutinising foo> :: Options -> Value)-    -- >        in \option -> if optEmitNamedOneof option-    -- >                      then ("Foo" .= (PB.objectOrNull [encodeFoo] option)) option-    -- >                      else encodeFoo option-    -- >       )-    -- >     , <encode more>-    -- >     , <encode stuff>-    -- >     ]-    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 = <FUNCTION, see tryParseDisjunctsE>-    --  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-        -- <https://hackage.haskell.org/package/large-records-0.4/changelog>-        -- 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 = (<case expr scrutinising foo> :: Options -> Value)+    -- >        in \option -> if optEmitNamedOneof option+    -- >                      then ("Foo" .= (PB.objectOrNull [encodeFoo] option)) option+    -- >                      else encodeFoo option+    -- >       )+    -- >     , <encode more>+    -- >     , <encode stuff>+    -- >     ]+    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 = <FUNCTION, see tryParseDisjunctsE>+    --  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" ]

@@ -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")))-                     []

@@ -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 ]+            []

@@ -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)

@@ -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 "<generated>" 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