proto3-suite 0.4.2 → 0.5.0

raw patch · 32 files changed

+1042/−190 lines, 32 filesdep +hedgehogdep +tasty-hedgehogdep ~aesondep ~base64-bytestringdep ~dhallsetup-changedPVP ok

version bump matches the API change (PVP)

Dependencies added: hedgehog, tasty-hedgehog

Dependency ranges changed: aeson, base64-bytestring, dhall, proto3-wire, swagger2

API changes (from Hackage documentation)

Files

• CHANGELOG.md +20/−0
• Setup.hs +0/−2
• gen/TestProto.hs +0/−1
• gen/TestProtoImport.hs +0/−1
• gen/TestProtoNestedMessage.hs +283/−0
• gen/TestProtoOneof.hs +0/−1
• gen/TestProtoOneofImport.hs +0/−1
• proto3-suite.cabal +83/−46
• src/Google/Protobuf/Timestamp.hs +3/−0
• src/Proto3/Suite/Class.hs +80/−2
• src/Proto3/Suite/DhallPB.hs +2/−0
• src/Proto3/Suite/DotProto/AST.hs +1/−1
• src/Proto3/Suite/DotProto/Generate.hs +70/−29
• src/Proto3/Suite/DotProto/Generate/Swagger.hs +13/−12
• src/Proto3/Suite/DotProto/Generate/Swagger.hs-boot +6/−0
• src/Proto3/Suite/DotProto/Internal.hs +169/−50
• src/Proto3/Suite/DotProto/Parsing.hs +7/−8
• src/Proto3/Suite/DotProto/Rendering.hs +2/−1
• src/Proto3/Suite/JSONPB/Class.hs +18/−4
• src/Proto3/Suite/Types.hs +0/−1
• src/no-swagger-wrapper-format/Proto3/Suite/DotProto/Generate/Swagger/Wrappers.hs +1/−0
• src/swagger-wrapper-format/Proto3/Suite/DotProto/Generate/Swagger/Wrappers.hs +93/−0
• tests/ArbitraryGeneratedTestTypes.hs +3/−2
• tests/Main.hs +8/−4
• tests/Test/Proto/Generate/Name.hs +53/−0
• tests/Test/Proto/Generate/Name/Gen.hs +92/−0
• tests/TestCodeGen.hs +12/−12
• tests/TestDhall.hs +0/−1
• tests/decode.sh +4/−1
• tests/encode.sh +4/−1
• tools/canonicalize-proto-file/Main.hs +15/−8
• tools/compile-proto-file/Main.hs +0/−1

@@ -0,0 +1,20 @@+* [BREAKING CHANGE: Proto3 standard compatibility improvements](https://github.com/awakesecurity/proto3-suite/pull/143)+  * This is a breaking change due to adding a new `DotProtoMessageOption`+    constructor to `DotProtoMessagePart`, which requires updating any+    exhaustive pattern matches+* [BREAKING CHANGE: Don't capitalize first character of prefixed service method names](https://github.com/awakesecurity/proto3-suite/pull/171)+  * This is a breaking change because the generated Haskell code will have+    slightly different field names for service methods+* [BREAKING CHANGE: Remove `Optional` from Protobuf AST](https://github.com/awakesecurity/proto3-suite/pull/165)+  * This is a technically breaking change because we no longer support the+    `optional` keyword, but this wasn't supported by proto3 anyway+* [Support GHC 9.0.2](https://github.com/awakesecurity/proto3-suite/pull/176)+* [Fix dashes in Haskell module names](https://github.com/awakesecurity/proto3-suite/pull/173)+  * This prevents the code generator from generating invalid Haskell module+    names with dashes in them+* [Add `Message` instance for wrapped types](https://github.com/awakesecurity/proto3-suite/pull/162)+  * This adds `Message` instances for several scalar Haskell types that+    correspond to the standard `*Wrapper` protobuf types+* [Use Swagger schema `format` to distinguish wrapper types from primitives](https://github.com/awakesecurity/proto3-suite/pull/167)+* [Update codegen to add the `serverMaxMetadataSize` field to generated `ServiceOptions`](https://github.com/awakesecurity/proto3-suite/pull/181)+* [Fix module renaming in `compile-proto-file`](https://github.com/awakesecurity/proto3-suite/pull/183)

@@ -1,2 +0,0 @@-import Distribution.Simple-main = defaultMain

@@ -10,7 +10,6 @@ {-# OPTIONS_GHC -fno-warn-missing-export-lists #-}  -- | Generated by Haskell protocol buffer compiler. DO NOT EDIT!- module TestProto where import qualified Prelude as Hs import qualified Proto3.Suite.Class as HsProtobuf

@@ -10,7 +10,6 @@ {-# OPTIONS_GHC -fno-warn-missing-export-lists #-}  -- | Generated by Haskell protocol buffer compiler. DO NOT EDIT!- module TestProtoImport where import qualified Prelude as Hs import qualified Proto3.Suite.Class as HsProtobuf

@@ -0,0 +1,283 @@+{-# LANGUAGE DeriveGeneric     #-}+{-# LANGUAGE DeriveAnyClass    #-}+{-# LANGUAGE DataKinds         #-}+{-# LANGUAGE GADTs             #-}+{-# LANGUAGE TypeApplications  #-}+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -fno-warn-unused-imports       #-}+{-# OPTIONS_GHC -fno-warn-name-shadowing       #-}+{-# OPTIONS_GHC -fno-warn-unused-matches       #-}+{-# OPTIONS_GHC -fno-warn-missing-export-lists #-}++-- | Generated by Haskell protocol buffer compiler. DO NOT EDIT!+module TestProtoNestedMessage where+import qualified Prelude as Hs+import qualified Proto3.Suite.Class as HsProtobuf+import qualified Proto3.Suite.DotProto as HsProtobuf+import qualified Proto3.Suite.JSONPB as HsJSONPB+import Proto3.Suite.JSONPB ((.=), (.:))+import qualified Proto3.Suite.Types as HsProtobuf+import qualified Proto3.Wire as HsProtobuf+import qualified Control.Applicative as Hs+import Control.Applicative ((<*>), (<|>), (<$>))+import qualified Control.DeepSeq as Hs+import qualified Control.Monad as Hs+import qualified Data.ByteString as Hs+import qualified Data.Coerce as Hs+import qualified Data.Int as Hs (Int16, Int32, Int64)+import qualified Data.List.NonEmpty as Hs (NonEmpty(..))+import qualified Data.Map as Hs (Map, mapKeysMonotonic)+import qualified Data.Proxy as Proxy+import qualified Data.String as Hs (fromString)+import qualified Data.Text.Lazy as Hs (Text)+import qualified Data.Vector as Hs (Vector)+import qualified Data.Word as Hs (Word16, Word32, Word64)+import qualified GHC.Enum as Hs+import qualified GHC.Generics as Hs+import qualified Unsafe.Coerce as Hs+ +newtype Request = Request{requestFoo ::+                          Hs.Maybe TestProtoNestedMessage.Request_Foo}+                  deriving (Hs.Show, Hs.Eq, Hs.Ord, Hs.Generic, Hs.NFData)+ +instance HsProtobuf.Named Request where+        nameOf _ = (Hs.fromString "Request")+ +instance HsProtobuf.HasDefault Request+ +instance HsProtobuf.Message Request where+        encodeMessage _ Request{requestFoo = requestFoo}+          = (Hs.mconcat+               [(HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 1)+                   (Hs.coerce @(Hs.Maybe TestProtoNestedMessage.Request_Foo)+                      @(HsProtobuf.Nested TestProtoNestedMessage.Request_Foo)+                      requestFoo))])+        decodeMessage _+          = (Hs.pure Request) <*>+              (Hs.coerce+                 @(_ (HsProtobuf.Nested TestProtoNestedMessage.Request_Foo))+                 @(_ (Hs.Maybe TestProtoNestedMessage.Request_Foo))+                 (HsProtobuf.at HsProtobuf.decodeMessageField+                    (HsProtobuf.FieldNumber 1)))+        dotProto _+          = [(HsProtobuf.DotProtoField (HsProtobuf.FieldNumber 1)+                (HsProtobuf.Prim (HsProtobuf.Named (HsProtobuf.Single "Foo")))+                (HsProtobuf.Single "foo")+                []+                "")]+ +instance HsJSONPB.ToJSONPB Request where+        toJSONPB (Request f1) = (HsJSONPB.object ["foo" .= f1])+        toEncodingPB (Request f1) = (HsJSONPB.pairs ["foo" .= f1])+ +instance HsJSONPB.FromJSONPB Request where+        parseJSONPB+          = (HsJSONPB.withObject "Request"+               (\ obj -> (Hs.pure Request) <*> obj .: "foo"))+ +instance HsJSONPB.ToJSON Request where+        toJSON = HsJSONPB.toAesonValue+        toEncoding = HsJSONPB.toAesonEncoding+ +instance HsJSONPB.FromJSON Request where+        parseJSON = HsJSONPB.parseJSONPB+ +instance HsJSONPB.ToSchema Request where+        declareNamedSchema _+          = do let declare_foo = HsJSONPB.declareSchemaRef+               requestFoo <- declare_foo Proxy.Proxy+               let _ = Hs.pure Request <*> HsJSONPB.asProxy declare_foo+               Hs.return+                 (HsJSONPB.NamedSchema{HsJSONPB._namedSchemaName =+                                         Hs.Just "Request",+                                       HsJSONPB._namedSchemaSchema =+                                         Hs.mempty{HsJSONPB._schemaParamSchema =+                                                     Hs.mempty{HsJSONPB._paramSchemaType =+                                                                 Hs.Just HsJSONPB.SwaggerObject},+                                                   HsJSONPB._schemaProperties =+                                                     HsJSONPB.insOrdFromList+                                                       [("foo", requestFoo)]}})+ +newtype Request_Foo = Request_Foo{request_FooBar ::+                                  Hs.Maybe TestProtoNestedMessage.Request_Foo_Bar}+                      deriving (Hs.Show, Hs.Eq, Hs.Ord, Hs.Generic, Hs.NFData)+ +instance HsProtobuf.Named Request_Foo where+        nameOf _ = (Hs.fromString "Request_Foo")+ +instance HsProtobuf.HasDefault Request_Foo+ +instance HsProtobuf.Message Request_Foo where+        encodeMessage _ Request_Foo{request_FooBar = request_FooBar}+          = (Hs.mconcat+               [(HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 1)+                   (Hs.coerce @(Hs.Maybe TestProtoNestedMessage.Request_Foo_Bar)+                      @(HsProtobuf.Nested TestProtoNestedMessage.Request_Foo_Bar)+                      request_FooBar))])+        decodeMessage _+          = (Hs.pure Request_Foo) <*>+              (Hs.coerce+                 @(_ (HsProtobuf.Nested TestProtoNestedMessage.Request_Foo_Bar))+                 @(_ (Hs.Maybe TestProtoNestedMessage.Request_Foo_Bar))+                 (HsProtobuf.at HsProtobuf.decodeMessageField+                    (HsProtobuf.FieldNumber 1)))+        dotProto _+          = [(HsProtobuf.DotProtoField (HsProtobuf.FieldNumber 1)+                (HsProtobuf.Prim (HsProtobuf.Named (HsProtobuf.Single "Bar")))+                (HsProtobuf.Single "bar")+                []+                "")]+ +instance HsJSONPB.ToJSONPB Request_Foo where+        toJSONPB (Request_Foo f1) = (HsJSONPB.object ["bar" .= f1])+        toEncodingPB (Request_Foo f1) = (HsJSONPB.pairs ["bar" .= f1])+ +instance HsJSONPB.FromJSONPB Request_Foo where+        parseJSONPB+          = (HsJSONPB.withObject "Request_Foo"+               (\ obj -> (Hs.pure Request_Foo) <*> obj .: "bar"))+ +instance HsJSONPB.ToJSON Request_Foo where+        toJSON = HsJSONPB.toAesonValue+        toEncoding = HsJSONPB.toAesonEncoding+ +instance HsJSONPB.FromJSON Request_Foo where+        parseJSON = HsJSONPB.parseJSONPB+ +instance HsJSONPB.ToSchema Request_Foo where+        declareNamedSchema _+          = do let declare_bar = HsJSONPB.declareSchemaRef+               request_FooBar <- declare_bar Proxy.Proxy+               let _ = Hs.pure Request_Foo <*> HsJSONPB.asProxy declare_bar+               Hs.return+                 (HsJSONPB.NamedSchema{HsJSONPB._namedSchemaName =+                                         Hs.Just "Request_Foo",+                                       HsJSONPB._namedSchemaSchema =+                                         Hs.mempty{HsJSONPB._schemaParamSchema =+                                                     Hs.mempty{HsJSONPB._paramSchemaType =+                                                                 Hs.Just HsJSONPB.SwaggerObject},+                                                   HsJSONPB._schemaProperties =+                                                     HsJSONPB.insOrdFromList+                                                       [("bar", request_FooBar)]}})+ +newtype Request_Foo_Bar = Request_Foo_Bar{request_Foo_BarBuz ::+                                          Hs.Maybe TestProtoNestedMessage.Request_Foo_Bar_Buz}+                          deriving (Hs.Show, Hs.Eq, Hs.Ord, Hs.Generic, Hs.NFData)+ +instance HsProtobuf.Named Request_Foo_Bar where+        nameOf _ = (Hs.fromString "Request_Foo_Bar")+ +instance HsProtobuf.HasDefault Request_Foo_Bar+ +instance HsProtobuf.Message Request_Foo_Bar where+        encodeMessage _+          Request_Foo_Bar{request_Foo_BarBuz = request_Foo_BarBuz}+          = (Hs.mconcat+               [(HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 1)+                   (Hs.coerce @(Hs.Maybe TestProtoNestedMessage.Request_Foo_Bar_Buz)+                      @(HsProtobuf.Nested TestProtoNestedMessage.Request_Foo_Bar_Buz)+                      request_Foo_BarBuz))])+        decodeMessage _+          = (Hs.pure Request_Foo_Bar) <*>+              (Hs.coerce+                 @(_ (HsProtobuf.Nested TestProtoNestedMessage.Request_Foo_Bar_Buz))+                 @(_ (Hs.Maybe TestProtoNestedMessage.Request_Foo_Bar_Buz))+                 (HsProtobuf.at HsProtobuf.decodeMessageField+                    (HsProtobuf.FieldNumber 1)))+        dotProto _+          = [(HsProtobuf.DotProtoField (HsProtobuf.FieldNumber 1)+                (HsProtobuf.Prim (HsProtobuf.Named (HsProtobuf.Single "Buz")))+                (HsProtobuf.Single "buz")+                []+                "")]+ +instance HsJSONPB.ToJSONPB Request_Foo_Bar where+        toJSONPB (Request_Foo_Bar f1) = (HsJSONPB.object ["buz" .= f1])+        toEncodingPB (Request_Foo_Bar f1) = (HsJSONPB.pairs ["buz" .= f1])+ +instance HsJSONPB.FromJSONPB Request_Foo_Bar where+        parseJSONPB+          = (HsJSONPB.withObject "Request_Foo_Bar"+               (\ obj -> (Hs.pure Request_Foo_Bar) <*> obj .: "buz"))+ +instance HsJSONPB.ToJSON Request_Foo_Bar where+        toJSON = HsJSONPB.toAesonValue+        toEncoding = HsJSONPB.toAesonEncoding+ +instance HsJSONPB.FromJSON Request_Foo_Bar where+        parseJSON = HsJSONPB.parseJSONPB+ +instance HsJSONPB.ToSchema Request_Foo_Bar where+        declareNamedSchema _+          = do let declare_buz = HsJSONPB.declareSchemaRef+               request_Foo_BarBuz <- declare_buz Proxy.Proxy+               let _ = Hs.pure Request_Foo_Bar <*> HsJSONPB.asProxy declare_buz+               Hs.return+                 (HsJSONPB.NamedSchema{HsJSONPB._namedSchemaName =+                                         Hs.Just "Request_Foo_Bar",+                                       HsJSONPB._namedSchemaSchema =+                                         Hs.mempty{HsJSONPB._schemaParamSchema =+                                                     Hs.mempty{HsJSONPB._paramSchemaType =+                                                                 Hs.Just HsJSONPB.SwaggerObject},+                                                   HsJSONPB._schemaProperties =+                                                     HsJSONPB.insOrdFromList+                                                       [("buz", request_Foo_BarBuz)]}})+ +newtype Request_Foo_Bar_Buz = Request_Foo_Bar_Buz{request_Foo_Bar_BuzX+                                                  :: Hs.Word32}+                              deriving (Hs.Show, Hs.Eq, Hs.Ord, Hs.Generic, Hs.NFData)+ +instance HsProtobuf.Named Request_Foo_Bar_Buz where+        nameOf _ = (Hs.fromString "Request_Foo_Bar_Buz")+ +instance HsProtobuf.HasDefault Request_Foo_Bar_Buz+ +instance HsProtobuf.Message Request_Foo_Bar_Buz where+        encodeMessage _+          Request_Foo_Bar_Buz{request_Foo_Bar_BuzX = request_Foo_Bar_BuzX}+          = (Hs.mconcat+               [(HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 1)+                   request_Foo_Bar_BuzX)])+        decodeMessage _+          = (Hs.pure Request_Foo_Bar_Buz) <*>+              (HsProtobuf.at HsProtobuf.decodeMessageField+                 (HsProtobuf.FieldNumber 1))+        dotProto _+          = [(HsProtobuf.DotProtoField (HsProtobuf.FieldNumber 1)+                (HsProtobuf.Prim HsProtobuf.UInt32)+                (HsProtobuf.Single "x")+                []+                "")]+ +instance HsJSONPB.ToJSONPB Request_Foo_Bar_Buz where+        toJSONPB (Request_Foo_Bar_Buz f1) = (HsJSONPB.object ["x" .= f1])+        toEncodingPB (Request_Foo_Bar_Buz f1)+          = (HsJSONPB.pairs ["x" .= f1])+ +instance HsJSONPB.FromJSONPB Request_Foo_Bar_Buz where+        parseJSONPB+          = (HsJSONPB.withObject "Request_Foo_Bar_Buz"+               (\ obj -> (Hs.pure Request_Foo_Bar_Buz) <*> obj .: "x"))+ +instance HsJSONPB.ToJSON Request_Foo_Bar_Buz where+        toJSON = HsJSONPB.toAesonValue+        toEncoding = HsJSONPB.toAesonEncoding+ +instance HsJSONPB.FromJSON Request_Foo_Bar_Buz where+        parseJSON = HsJSONPB.parseJSONPB+ +instance HsJSONPB.ToSchema Request_Foo_Bar_Buz where+        declareNamedSchema _+          = do let declare_x = HsJSONPB.declareSchemaRef+               request_Foo_Bar_BuzX <- declare_x Proxy.Proxy+               let _ = Hs.pure Request_Foo_Bar_Buz <*> HsJSONPB.asProxy declare_x+               Hs.return+                 (HsJSONPB.NamedSchema{HsJSONPB._namedSchemaName =+                                         Hs.Just "Request_Foo_Bar_Buz",+                                       HsJSONPB._namedSchemaSchema =+                                         Hs.mempty{HsJSONPB._schemaParamSchema =+                                                     Hs.mempty{HsJSONPB._paramSchemaType =+                                                                 Hs.Just HsJSONPB.SwaggerObject},+                                                   HsJSONPB._schemaProperties =+                                                     HsJSONPB.insOrdFromList+                                                       [("x", request_Foo_Bar_BuzX)]}})

@@ -10,7 +10,6 @@ {-# OPTIONS_GHC -fno-warn-missing-export-lists #-}  -- | Generated by Haskell protocol buffer compiler. DO NOT EDIT!- module TestProtoOneof where import qualified Prelude as Hs import qualified Proto3.Suite.Class as HsProtobuf

@@ -10,7 +10,6 @@ {-# OPTIONS_GHC -fno-warn-missing-export-lists #-}  -- | Generated by Haskell protocol buffer compiler. DO NOT EDIT!- module TestProtoOneofImport where import qualified Prelude as Hs import qualified Proto3.Suite.Class as HsProtobuf

@@ -1,36 +1,59 @@+cabal-version:       2.0 name:                proto3-suite-version:             0.4.2-synopsis:            A low level library for writing out data in the Protocol Buffers wire format+version:             0.5.0+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>+  that supports:+  .+  - Type classes for encoding and decoding messages, and instances for all wire+    formats identified in the specification+  - A higher-level approach to encoding and decoding, based on `GHC.Generics`+  - A way of creating `.proto` files from Haskell types.+  .+  See <https://hackage.haskell.org/package/proto3-suite/docs/Proto3-Suite-Tutorial.html the `Proto3.Suite.Tutorial` module>+  for more details.+  . license:             Apache-2.0-author:              Awake Security-maintainer:          opensource@awakesecurity.com-copyright:           2017-2018 Awake Security+author:              Arista Networks <opensource@awakesecurity.com>+maintainer:          Arista Networks <opensource@awakesecurity.com>+copyright:           2017-2020 Awake Security, 2021 Arista Networks category:            Codec build-type:          Simple-cabal-version:       2.0 data-files:          test-files/*.bin tests/encode.sh tests/decode.sh+extra-source-files:  CHANGELOG.md -Flag dhall+flag dhall   Description:   Turn on Dhall interpret and inject codegen   Default:       False   Manual:        True -Flag swagger+flag swagger   Description:   Turn on Swagger doc generation.   Default:       True   Manual:        True +flag swagger-wrapper-format+  Description:   Change Swagger schema format for Protobuf wrapper types+  Default:       False+  Manual:        True+ library    if flag(dhall)     exposed-modules:   Proto3.Suite.DhallPB-    build-depends:     dhall >=1.13 && < 1.34+    build-depends:     dhall >=1.13 && < 1.39     cpp-options:       -DDHALL    if flag(swagger)     exposed-modules:   Proto3.Suite.DotProto.Generate.Swagger-    build-depends:     swagger2 >=2.1.6 && <2.7+                       Proto3.Suite.DotProto.Generate.Swagger.Wrappers+    build-depends:     swagger2 >=2.1.6 && <2.8     cpp-options:       -DSWAGGER+    if flag(swagger-wrapper-format)+      hs-source-dirs:  src/swagger-wrapper-format+    else+      hs-source-dirs:  src/no-swagger-wrapper-format    exposed-modules:     Proto3.Suite                        Proto3.Suite.Class@@ -49,11 +72,11 @@                        Proto3.Suite.DotProto.Internal                        Proto3.Suite.JSONPB.Class -  build-depends:       aeson >= 1.1.1.0 && < 1.6,+  build-depends:       aeson >= 1.1.1.0 && < 2.1,                        aeson-pretty,                        attoparsec >= 0.13.0.1,                        base >=4.8 && <5.0,-                       base64-bytestring >= 1.0.0.1 && < 1.2,+                       base64-bytestring >= 1.0.0.1 && < 1.3,                        binary >=0.8.3,                        bytestring >=0.10.6.0 && <0.11.0,                        deepseq ==1.4.*,@@ -89,50 +112,64 @@   ghc-options:         -O2 -Wall  test-suite tests-  type:                exitcode-stdio-1.0-  main-is:             Main.hs+  default-language: Haskell2010+  type:             exitcode-stdio-1.0+  main-is:          Main.hs +  hs-source-dirs:+    gen+    tests+   if flag(dhall)     other-modules:     TestDhall-    build-depends:     dhall >=1.13 && < 1.34+    build-depends:     dhall >=1.13 && < 1.39     cpp-options:       -DDHALL    if flag(swagger)     build-depends:     swagger2     cpp-options:       -DSWAGGER+    if flag(swagger-wrapper-format)+      cpp-options:       -DSWAGGER_WRAPPER_FORMAT -  other-modules:       ArbitraryGeneratedTestTypes-                       TestCodeGen-                       TestProto-                       TestProtoImport-                       TestProtoOneof-                       TestProtoOneofImport+  other-modules:+    ArbitraryGeneratedTestTypes+    TestCodeGen+    TestProto+    TestProtoImport+    TestProtoOneof+    TestProtoOneofImport+    --TestProtoLeadingDot+    TestProtoNestedMessage+    --TestProtoProtocPlugin+    Test.Proto.Generate.Name+    Test.Proto.Generate.Name.Gen -  hs-source-dirs:      tests gen-  default-language:    Haskell2010-  build-depends:       base >=4.8 && <5.0,-                       QuickCheck >=2.10 && <2.15,-                       aeson >= 1.1.1.0 && < 1.6,-                       attoparsec >= 0.13.0.1,-                       base >=4.8 && <5.0,-                       base64-bytestring >= 1.0.0.1 && < 1.2,-                       bytestring >=0.10.6.0 && <0.11.0,-                       cereal >= 0.5.1 && <0.6,-                       containers >=0.5 && < 0.7,-                       deepseq ==1.4.*,-                       doctest,-                       generic-arbitrary,-                       mtl ==2.2.*,-                       pretty-show >= 1.6.12 && < 2.0,-                       proto3-suite,-                       proto3-wire == 1.2.*,-                       tasty >= 0.11 && <1.3,-                       tasty-hunit >= 0.9 && <0.11,-                       tasty-quickcheck >= 0.8.4 && <0.11,-                       text >= 0.2 && <1.3,-                       transformers >=0.4 && <0.6,-                       turtle,-                       vector >=0.11 && < 0.13+  build-depends:+      aeson >= 1.1.1.0 && < 2.1+    , attoparsec >= 0.13.0.1+    , base >=4.8 && <5.0+    , base64-bytestring >= 1.0.0.1 && < 1.3+    , bytestring >=0.10.6.0 && <0.11.0+    , cereal >= 0.5.1 && <0.6+    , containers >=0.5 && < 0.7+    , deepseq ==1.4.*+    , doctest+    , generic-arbitrary+    , hedgehog+    , mtl ==2.2.*+    , pretty-show >= 1.6.12 && < 2.0+    , proto3-suite+    , proto3-wire == 1.2.*+    , QuickCheck >=2.10 && <2.15+    , tasty >= 0.11 && <1.5+    , tasty-hedgehog+    , tasty-hunit >= 0.9 && <0.11+    , tasty-quickcheck >= 0.8.4 && <0.11+    , text >= 0.2 && <1.3+    , 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

@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-}@@ -136,6 +137,7 @@ instance HsJSONPB.FromJSON Timestamp where   parseJSON = HsJSONPB.parseJSONPB +#ifdef SWAGGER instance HsJSONPB.ToSchema Timestamp where   declareNamedSchema _ =     do@@ -165,3 +167,4 @@                   }             }         )+#endif

@@ -102,7 +102,6 @@ import           Data.Int               (Int32, Int64) import qualified Data.Map               as M import           Data.Maybe             (fromMaybe, isNothing)-import           Data.Monoid            ((<>)) import           Data.Proxy             (Proxy (..)) import           Data.String            (IsString (..)) import qualified Data.Text              as T@@ -117,7 +116,6 @@ import           Proto3.Suite.DotProto  as DotProto import           Proto3.Suite.Types     as Wire import           Proto3.Wire-import           Proto3.Wire.Class      (ProtoEnum(..)) import           Proto3.Wire.Decode     (ParseError, Parser (..), RawField,                                          RawMessage, RawPrimitive, runParser) import qualified Proto3.Wire.Decode     as Decode@@ -699,6 +697,86 @@ message proxy = DotProtoMessage ""                                 (Single $ nameOf proxy)                                 (DotProtoMessageField <$> dotProto proxy)++-- * Wrapped Type Instances++encodeWrapperMessage+  :: MessageField a+  => FieldNumber+  -> a+  -> Encode.MessageBuilder+encodeWrapperMessage _ x = encodeMessageField (FieldNumber 1) x++decodeWrapperMessage+  :: MessageField a+  => FieldNumber+  -> Decode.Parser Decode.RawMessage a+decodeWrapperMessage _ = at decodeMessageField (FieldNumber 1)++dotProtoWrapper :: Primitive a => Proxy# a -> [DotProtoField]+dotProtoWrapper proxy =+  [ DotProtoField+      (FieldNumber 1)+      (Prim (primType proxy))+      (Single "value")+      []+      ""+  ]++instance Message Double where+  encodeMessage = encodeWrapperMessage+  decodeMessage = decodeWrapperMessage+  dotProto = dotProtoWrapper++instance Message Float where+  encodeMessage = encodeWrapperMessage+  decodeMessage = decodeWrapperMessage+  dotProto = dotProtoWrapper++instance Message Int64 where+  encodeMessage = encodeWrapperMessage+  decodeMessage = decodeWrapperMessage+  dotProto = dotProtoWrapper++instance Message Word64 where+  encodeMessage = encodeWrapperMessage+  decodeMessage = decodeWrapperMessage+  dotProto = dotProtoWrapper++instance Message Int32 where+  encodeMessage = encodeWrapperMessage+  decodeMessage = decodeWrapperMessage+  dotProto = dotProtoWrapper++instance Message Word32 where+  encodeMessage = encodeWrapperMessage+  decodeMessage = decodeWrapperMessage+  dotProto = dotProtoWrapper++instance Message Bool where+  encodeMessage = encodeWrapperMessage+  decodeMessage = decodeWrapperMessage+  dotProto = dotProtoWrapper++instance Message T.Text where+  encodeMessage = encodeWrapperMessage+  decodeMessage = decodeWrapperMessage+  dotProto = dotProtoWrapper++instance Message TL.Text where+  encodeMessage = encodeWrapperMessage+  decodeMessage = decodeWrapperMessage+  dotProto = dotProtoWrapper++instance Message B.ByteString where+  encodeMessage = encodeWrapperMessage+  decodeMessage = decodeWrapperMessage+  dotProto = dotProtoWrapper++instance Message BL.ByteString where+  encodeMessage = encodeWrapperMessage+  decodeMessage = decodeWrapperMessage+  dotProto = dotProtoWrapper  -- * Generic Instances 

@@ -69,6 +69,7 @@ -- TODO: we should perform run-time bounds-checking to at least hint -- to the user that we interpreted something bad. +#if !MIN_VERSION_dhall(1,35,0) instance Dhall.FromDhall Int where   autoWith _ = fmap fromInteger Dhall.integer @@ -83,6 +84,7 @@  instance Dhall.FromDhall Word64 where   autoWith _ = fmap fromIntegral Dhall.integer+#endif  instance Dhall.FromDhall (Fixed Int32) where   autoWith = fmap Fixed . Dhall.autoWith

@@ -268,7 +268,6 @@ --   are meaningful in every type context. data DotProtoType   = Prim           DotProtoPrimType-  | Optional       DotProtoPrimType   | Repeated       DotProtoPrimType   | NestedRepeated DotProtoPrimType   | Map            DotProtoPrimType DotProtoPrimType@@ -342,6 +341,7 @@   | DotProtoMessageOneOf DotProtoIdentifier [DotProtoField]   | DotProtoMessageDefinition DotProtoDefinition   | DotProtoMessageReserved   [DotProtoReservedField]+  | DotProtoMessageOption DotProtoOption   deriving (Show, Eq)  instance Arbitrary DotProtoMessagePart where

@@ -26,6 +26,7 @@   , CompileArgs(..)   , compileDotProtoFile   , compileDotProtoFileOrDie+  , renameProtoFile   , hsModuleForDotProto   , renderHsModuleForDotProto   , readDotProtoWithContext@@ -57,12 +58,13 @@ import           Proto3.Suite.DotProto import           Proto3.Suite.DotProto.AST.Lens import           Proto3.Suite.DotProto.Internal-import           Proto3.Suite.DotProto.Rendering (Pretty(..)) import           Proto3.Wire.Types              (FieldNumber (..))-import           System.IO                      (writeFile, readFile)+import Text.Parsec (Parsec, alphaNum, eof, parse, satisfy, try)+import qualified Text.Parsec as Parsec import qualified Turtle import           Turtle                         (FilePath) +--------------------------------------------------------------------------------  -- -- * Public interface@@ -77,20 +79,21 @@ -- | 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 typeLikeName . components . metaModulePath . protoMeta $ dotProto--    let relativePath = FP.concat (map fromString $ NE.toList modulePathPieces) <.> "hs"-    let modulePath   = outputDir </> relativePath+  (dotProto, importTypeContext) <- readDotProtoWithContext includeDir inputProto+  modulePathPieces <- traverse renameProtoFile (toModuleComponents dotProto) -    Turtle.mktree (Turtle.directory modulePath)+  let relativePath = FP.concat (map fromString $ NE.toList modulePathPieces) <.> "hs"+  let modulePath = outputDir </> relativePath -    extraInstances <- foldMapM getExtraInstances extraInstanceFiles+  Turtle.mktree (Turtle.directory modulePath) -    haskellModule <- renderHsModuleForDotProto extraInstances dotProto importTypeContext+  extraInstances <- foldMapM getExtraInstances extraInstanceFiles+  haskellModule <- renderHsModuleForDotProto extraInstances dotProto importTypeContext -    liftIO (writeFile (FP.encodeString modulePath) haskellModule)+  liftIO (writeFile (FP.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.@@ -107,6 +110,49 @@     |]   _ -> 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.@@ -314,10 +360,10 @@ --   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-                      => DotProtoTypeInfo -> DotProtoIdentifier -> m HsType-msgTypeFromDpTypeInfo DotProtoTypeInfo{..} ident = do+                      => TypeContext -> DotProtoTypeInfo -> DotProtoIdentifier -> m HsType+msgTypeFromDpTypeInfo ctxt DotProtoTypeInfo{..} ident = do     modName   <- modulePathModName dotProtoTypeInfoModulePath-    identName <- qualifiedMessageName dotProtoTypeInfoParent ident+    identName <- qualifiedMessageTypeName ctxt dotProtoTypeInfoParent ident     pure $ HsTyCon (Qual modName (HsIdent identName))  haskellName, jsonpbName, grpcName, protobufName, protobufWrapperName, proxyName :: String -> HsQName@@ -446,8 +492,8 @@       Named msgName ->         case M.lookup msgName ctxt of           Just ty@(DotProtoTypeInfo { dotProtoTypeInfoKind = DotProtoKindEnum }) ->-              HsTyApp (protobufType_ "Enumerated") <$> msgTypeFromDpTypeInfo ty msgName-          Just ty -> msgTypeFromDpTypeInfo ty msgName+              HsTyApp (protobufType_ "Enumerated") <$> msgTypeFromDpTypeInfo ctxt ty msgName+          Just ty -> msgTypeFromDpTypeInfo ctxt ty msgName           Nothing -> noSuchTypeError msgName  foldDPT :: MonadError CompileError m@@ -464,7 +510,6 @@   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 -> HsTyApp . cont <$> prim k <*> go (Prim v) -- need to 'Nest' message types@@ -490,7 +535,6 @@ dptToHsContType ctxt = \case   Prim (Named tyName) | isMessage ctxt tyName                      -> HsTyApp $ primType_ "Maybe"-  Optional _         -> HsTyApp $ primType_ "Maybe"   Repeated _         -> HsTyApp $ primType_ "Vector"   NestedRepeated _   -> HsTyApp $ primType_ "Vector"   Map _ _            -> HsTyApp $ primType_ "Map"@@ -541,8 +585,8 @@   Named msgName ->     case M.lookup msgName ctxt of       Just ty@(DotProtoTypeInfo { dotProtoTypeInfoKind = DotProtoKindEnum }) ->-          HsTyApp (protobufType_ "Enumerated") <$> msgTypeFromDpTypeInfo ty msgName-      Just ty -> msgTypeFromDpTypeInfo ty msgName+          HsTyApp (protobufType_ "Enumerated") <$> msgTypeFromDpTypeInfo ctxt ty msgName+      Just ty -> msgTypeFromDpTypeInfo ctxt ty msgName       Nothing -> noSuchTypeError msgName  validMapKey :: DotProtoPrimType -> Bool@@ -1282,10 +1326,7 @@       | i == 0 -> return ()       | otherwise -> throwError $ NonzeroFirstEnumeration enumName conIdent i -  enumCons <- fmap (sortBy (comparing fst)) $-    traverse (traverse-                (fmap (prefixedEnumFieldName enumName) . dpIdentUnqualName))-             enumeratorDecls+  enumCons <- sortBy (comparing fst) <$> traverse (traverse (fmap (prefixedEnumFieldName enumName) . dpIdentUnqualName)) enumeratorDecls    let enumConNames = map snd enumCons @@ -1430,7 +1471,7 @@      let endpointPrefix = "/" ++ packageName ++ "." ++ serviceName ++ "/"       let serviceFieldD (DotProtoServiceRPCMethod RPCMethod{..}) = do-           fullName <- prefixedFieldName serviceName =<< dpIdentUnqualName rpcMethodName+           fullName <- prefixedMethodName serviceName =<< dpIdentUnqualName rpcMethodName             methodName <- case rpcMethodName of                            Single nm -> pure nm@@ -1495,6 +1536,7 @@                                , patVar "sslConfig"                                , patVar "logger"                                , patVar "serverMaxReceiveMessageLength"+                               , patVar "serverMaxMetadataSize"                                ]                       ]                       (HsUnGuardedRhs (apply serverLoopE [ serverOptsE ]))@@ -1539,6 +1581,7 @@                  , update "optSSLConfig" "sslConfig"                  , update "optLogger" "logger"                  , update "optMaxReceiveMessageLength" "serverMaxReceiveMessageLength"+                 , update "optMaxMetadataSize" "serverMaxMetadataSize"                  ]       let clientT = tyApp (HsTyCon (unqual_ serviceName)) [ clientRequestT, clientResultT ]@@ -1583,7 +1626,7 @@ -- * Common Haskell expressions, constructors, and operators -- -dotProtoFieldC, primC, optionalC, repeatedC, nestedRepeatedC, namedC, mapC,+dotProtoFieldC, primC, repeatedC, nestedRepeatedC, namedC, mapC,   fieldNumberC, singleC, dotsC, pathC, nestedC, anonymousC, dotProtoOptionC,   identifierC, stringLitC, intLitC, floatLitC, boolLitC, trueC, falseC,   unaryHandlerC, clientStreamHandlerC, serverStreamHandlerC, biDiStreamHandlerC,@@ -1595,7 +1638,6 @@  dotProtoFieldC       = HsVar (protobufName "DotProtoField") primC                = HsVar (protobufName "Prim")-optionalC            = HsVar (protobufName "Optional") repeatedC            = HsVar (protobufName "Repeated") nestedRepeatedC      = HsVar (protobufName "NestedRepeated") namedC               = HsVar (protobufName "Named")@@ -1720,7 +1762,6 @@ -- | 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]

@@ -1,9 +1,10 @@ {-# LANGUAGE CPP                 #-} {-# LANGUAGE DataKinds           #-}-{-# LANGUAGE FlexibleInstances   #-} {-# LANGUAGE FlexibleContexts    #-}-{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE FlexibleInstances   #-} {-# LANGUAGE MagicHash           #-}+{-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications    #-}  {-# OPTIONS_GHC -fno-warn-orphans #-}@@ -27,7 +28,7 @@                                                   ToJSONKeyFunction(..)) import qualified Data.Aeson                      as Aeson import           Data.Aeson.Encode.Pretty        (encodePretty)-import           Data.ByteString                 (ByteString)+import qualified Data.ByteString                 as B import qualified Data.ByteString.Lazy.Char8      as LC8 import           Data.Hashable                   (Hashable) import           Data.HashMap.Strict.InsOrd      (InsOrdHashMap)@@ -42,6 +43,7 @@ import           GHC.Word import           Proto3.Suite                    (Enumerated (..), Finite (..),                                                   Fixed (..), Named (..), enumerate)+import           Proto3.Suite.DotProto.Generate.Swagger.Wrappers ()  -- | Convenience re-export so that users of generated code don't have to add --   an explicit dependency on @insert-ordered-containers@@@ -56,15 +58,10 @@ instance {-# OVERLAPPABLE #-} ToSchema a => ToSchema (OverrideToSchema a) where   declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy a) -instance {-# OVERLAPPING #-} ToSchema (OverrideToSchema ByteString) where-  declareNamedSchema _ = return (NamedSchema Nothing byteSchema)---- | This instance is the same as the instance for @OverrideToSchema ByteString@.--- See: https://hackage.haskell.org/package/swagger2-2.6/docs/src/Data.Swagger.Internal.Schema.html#line-451-instance {-# OVERLAPPING #-} ToSchema (OverrideToSchema (Maybe ByteString)) where+instance {-# OVERLAPPING #-} ToSchema (OverrideToSchema B.ByteString) where   declareNamedSchema _ = return (NamedSchema Nothing byteSchema) -instance {-# OVERLAPPING #-} ToSchema (OverrideToSchema (V.Vector ByteString)) where+instance {-# OVERLAPPING #-} ToSchema (OverrideToSchema (V.Vector B.ByteString)) where   declareNamedSchema _ = return (NamedSchema Nothing schema_)     where       schema_ = mempty@@ -75,15 +72,19 @@ #endif         & items ?~ SwaggerItemsObject (Inline byteSchema) -instance {-# OVERLAPPING #-} (ToJSONKey k, ToSchema k) => ToSchema (OverrideToSchema (Map k ByteString)) where+instance {-# OVERLAPPING #-} (ToJSONKey k, ToSchema k) => ToSchema (OverrideToSchema (Map k B.ByteString)) where   declareNamedSchema _ = case Aeson.toJSONKey :: ToJSONKeyFunction k of       ToJSONKeyText _ _ -> do           return (NamedSchema Nothing schema_)       ToJSONKeyValue _ _ -> do-          declareNamedSchema (Proxy :: Proxy [(k, (OverrideToSchema ByteString))])+          declareNamedSchema (Proxy :: Proxy [(k, (OverrideToSchema B.ByteString))])     where       schema_ = mempty+#if MIN_VERSION_swagger2(2,4,0)         & type_ ?~ SwaggerObject+#else+        & type_ .~ SwaggerObject+#endif         & additionalProperties ?~ AdditionalPropertiesSchema (Inline byteSchema)  {-| This is a convenience function that uses type inference to select the

@@ -0,0 +1,6 @@+module Proto3.Suite.DotProto.Generate.Swagger+  ( OverrideToSchema (..)+  )+where++newtype OverrideToSchema a = OverrideToSchema { unOverride :: a }

@@ -9,6 +9,7 @@ {-# LANGUAGE QuasiQuotes       #-} {-# LANGUAGE RankNTypes        #-} {-# LANGUAGE RecordWildCards   #-}+{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections     #-} {-# LANGUAGE ViewPatterns      #-} @@ -27,11 +28,10 @@ import           Data.Foldable import           Data.Functor.Compose import           Data.Int                  (Int32)-import           Data.List                 (find, intercalate)+import           Data.List                 (intercalate) import qualified Data.List.NonEmpty        as NE import qualified Data.Map                  as M import           Data.Maybe                (fromMaybe)-import           Data.Semigroup            (Semigroup(..)) import qualified Data.Text                 as T import           Data.Tuple                (swap) import           Filesystem.Path.CurrentOS ((</>))@@ -45,8 +45,7 @@ import           System.FilePath           (isPathSeparator) import           Text.Parsec               (ParseError) import qualified Turtle-import           Turtle                    (ExitCode (..), FilePath, MonadIO,-                                            Text)+import           Turtle                    (ExitCode (..), FilePath, Text) import           Turtle.Format             ((%)) import qualified Turtle.Format             as F @@ -323,17 +322,17 @@ isMessage :: TypeContext -> DotProtoIdentifier -> Bool isMessage ctxt n = Just DotProtoKindMessage == (dotProtoTypeInfoKind <$> M.lookup n ctxt) +boolOption :: String -> [DotProtoOption] -> Maybe Bool+boolOption desired opts =+    case find (\(DotProtoOption name _) -> name == Single desired) opts of+        Just (DotProtoOption _ (BoolLit x)) -> Just x+        _ -> Nothing+ isPacked :: [DotProtoOption] -> Bool-isPacked opts =-    case find (\(DotProtoOption name _) -> name == Single "packed") opts of-        Just (DotProtoOption _ (BoolLit x)) -> x-        _ -> False+isPacked = fromMaybe False . boolOption "packed"  isUnpacked :: [DotProtoOption] -> Bool-isUnpacked opts =-    case find (\(DotProtoOption name _) -> name == Single "packed") opts of-        Just (DotProtoOption _ (BoolLit x)) -> not x-        _ -> False+isUnpacked = maybe False not . boolOption "packed"  -- | Returns 'True' if the given primitive type is packable. The 'TypeContext' -- is used to distinguish Named enums and messages, only the former of which are@@ -366,8 +365,11 @@ -- * Name resolution -- -concatDotProtoIdentifier :: MonadError CompileError m-                         => DotProtoIdentifier -> DotProtoIdentifier -> m DotProtoIdentifier+concatDotProtoIdentifier ::+  MonadError CompileError m =>+  DotProtoIdentifier ->+  DotProtoIdentifier ->+  m DotProtoIdentifier concatDotProtoIdentifier i1 i2 = case (i1, i2) of   (Qualified{}  ,  _           ) -> internalError "concatDotProtoIdentifier: Qualified"   (_            , Qualified{}  ) -> internalError "concatDotProtoIdentifier Qualified"@@ -378,41 +380,135 @@   (a            , Single b     ) -> concatDotProtoIdentifier a (Dots (Path (pure b)))   (Dots (Path a), Dots (Path b)) -> pure (Dots (Path (a <> b))) -camelCased :: String -> String-camelCased s = do-  (prev, cur) <- zip (Nothing:map Just s) (map Just s ++ [Nothing])-  case (prev, cur) of-    (Just '_', Just x)-      | isAlpha x        -> pure (toUpper x)-    (Just '_', Nothing)  -> pure '_'-    (Just '_', Just '_') -> pure '_'-    (_, Just '_')        -> empty-    (_, Just x)          -> pure x-    (_, _)               -> empty+-- | @'toPascalCase' xs'@ sends a snake-case string @xs@ to a pascal-cased string. Trailing underscores are not dropped+-- from the input string and exactly double underscores are replaced by a single underscore.+toPascalCase :: String -> String+toPascalCase xs = foldMap go (segmentBy (== '_') xs)+  where+    go (Left seg) = toUpperFirst seg+    go (Right seg)+      | seg == "__" = "_"+      | otherwise = "" +-- | @'toCamelCase' xs@ sends a snake-case string @xs@ to a camel-cased string.+toCamelCase :: String -> String+toCamelCase xs =+  case toPascalCase xs of+    "" -> ""+    x : xs' -> toLower x : xs'++-- | Uppercases the first character of a string.+--+-- ==== __Examples__+--+-- >>> toUpperFirst "abc"+-- "Abc"+--+-- >>> toUpperFirst ""+-- ""+toUpperFirst :: String -> String+toUpperFirst "" = ""+toUpperFirst (x : xs) = toUpper x : xs++-- | @'segmentBy' p xs@  partitions @xs@ into segments of @'Either' [a] [a]@+-- with:+--+-- * 'Right' sublists containing elements satisfying @p@, otherwise;+--+-- * 'Left' sublists containing elements that do not satisfy @p@+--+-- ==== __Examples__+--+-- >>> segmentBy (\c -> c == '_') "abc_123_xyz"+-- [Left "abc",Right "_",Left "123",Right "_",Left "xyz"]+segmentBy :: (a -> Bool) -> [a] -> [Either [a] [a]]+segmentBy p xs = case span p xs of+  ([], []) -> []+  (ys, []) -> [Right ys]+  ([], ys) -> Left seg : segmentBy p ys'+    where+      (seg, ys') = break p ys+  (xs', ys) -> Right xs' : Left seg : segmentBy p ys'+    where+      (seg, ys') = break p ys++-- | @'suffixBy' p xs@ yields @'Right' (xs', suf)@ if @suf@ is the longest suffix satisfying @p@ and @xs'@ is the rest+-- of the rest, otherwise the string is given back as @'Left' xs@ signifying @xs@ had no suffix satisfying @p@.+suffixBy :: forall a. (a -> Bool) -> [a] -> Either [a] ([a], [a])+suffixBy p xs' = do+  (pref, suf) <- foldr go (Left []) xs'+  if null suf+    then Left pref+    else return (pref, suf)+  where+    go :: a -> Either [a] ([a], [a]) -> Either [a] ([a], [a])+    go x (Right (xs, suf)) = Right (x : xs, suf)+    go x (Left xs)+      | p x = Left (x : xs)+      | otherwise = Right ([x], xs)++-- | @'typeLikeName' xs@ produces either the pascal-cased version of the string @xs@ if it begins with an alphabetical+-- character or underscore - which is replaced with 'X'. A 'CompileError' is emitted if the starting character is+-- non-alphabetic or if @xs == ""@. typeLikeName :: MonadError CompileError m => String -> m String-typeLikeName ident@(c:cs)-  | isUpper c = pure (camelCased ident)-  | isLower c = pure (camelCased (toUpper c : cs))-  | '_'  == c = pure (camelCased ('X':ident))-typeLikeName ident = invalidTypeNameError ident+typeLikeName "" = invalidTypeNameError "<empty name>"+typeLikeName s@(x : xs)+  | isAlpha x = pure $ case suffixBy (== '_') s of+      Left xs' -> invalidToCamelCase $ toPascalCase xs'+      Right (xs', suf) -> invalidToCamelCase $ toPascalCase xs' <> suf+  | x == '_' = pure $ case suffixBy (== '_') xs of+      Left xs' -> invalidToCamelCase $ 'X' : toPascalCase xs'+      Right (xs', suf) -> invalidToCamelCase $ 'X' : (toPascalCase xs' <> suf)+  | otherwise = invalidTypeNameError s+  where+    -- Transforms special characters that are not valid as a part of a Haskell name to CamelCase.+    -- For instance “foo-bar---baz” will become “FooBarBaz”.+    -- This function presumes that the first character of the initial value satisfies "isAlpha".+    -- This must be checked outside of this function.+    invalidToCamelCase a =+      case span isValidNameChar a of+        ("", "") -> ""+        ("", cs) -> invalidToCamelCase . dropWhile (not . isValidNameChar) $ cs+        (b : bs, cs) -> toUpper b : bs <> invalidToCamelCase cs +    -- Only valid as a secondary character.+    -- First character of a Haskell name can only be "isAlpha".+    isValidNameChar ch = isAlphaNum ch || ch == '_'++-- | @'fieldLikeName' field@ is the casing transformation used to produce record selectors from message fields. If+-- @field@ is prefixed by a span of uppercase characters then that prefix will be lowercased while the remaining string+-- is left unchanged. fieldLikeName :: String -> String-fieldLikeName ident@(c:_)-  | isUpper c = let (prefix, suffix) = span isUpper ident-                in map toLower prefix ++ suffix-fieldLikeName ident = ident+fieldLikeName "" = ""+fieldLikeName (x : xs)+  | isUpper x = map toLower prefix ++ suffix+  | otherwise = x : xs+  where (prefix, suffix) = span isUpper (x : xs)  prefixedEnumFieldName :: String -> String -> String-prefixedEnumFieldName enumName fieldName = enumName <> fieldName+prefixedEnumFieldName enumName enumItem = enumName ++ enumItem  prefixedConName :: MonadError CompileError m => String -> String -> m String-prefixedConName msgName conName = (msgName ++) <$> typeLikeName conName+prefixedConName msgName conName = do+  constructor <- typeLikeName conName+  return (msgName ++ constructor) --- TODO: This should be ~:: MessageName -> FieldName -> ...; same elsewhere, the--- String types are a bit of a hassle.+-- | @'prefixedMethodName' service method@ produces a Haskell record selector name for the service method @method@ by+-- joining the names @service@, @method@ under concatenation on a camel-casing transformation.+prefixedMethodName :: MonadError CompileError m => String -> String -> m String+prefixedMethodName _ "" = invalidTypeNameError "<empty name>"+prefixedMethodName serviceName (x : xs)+  | isLower x = return (fieldLikeName serviceName ++ fieldLikeName (x : xs))+  | otherwise = do+      method <- typeLikeName (x : xs)+      return (fieldLikeName serviceName ++ method)++-- | @'prefixedFieldName' prefix field@ constructs a Haskell record selector name by prepending @prefix@ in camel-case+-- to the message field/service method name @field@. prefixedFieldName :: MonadError CompileError m => String -> String -> m String-prefixedFieldName msgName fieldName = (fieldLikeName msgName ++) <$> typeLikeName fieldName+prefixedFieldName msgName fieldName = do+  field <- typeLikeName fieldName+  return (fieldLikeName msgName ++ field)  dpIdentUnqualName :: MonadError CompileError m => DotProtoIdentifier -> m String dpIdentUnqualName (Single name)       = pure name@@ -437,6 +533,28 @@ qualifiedMessageName :: MonadError CompileError m => DotProtoIdentifier -> DotProtoIdentifier -> m String qualifiedMessageName parentIdent msgIdent = nestedTypeName parentIdent =<< dpIdentUnqualName msgIdent +qualifiedMessageTypeName :: MonadError CompileError m =>+                            TypeContext ->+                            DotProtoIdentifier ->+                            DotProtoIdentifier ->+                            m String+qualifiedMessageTypeName ctxt parentIdent msgIdent = do+  xs <- parents parentIdent []+  case xs of+    [] -> nestedTypeName parentIdent =<< dpIdentUnqualName msgIdent+    x : xs' -> nestedTypeName (Dots . Path $ x NE.:| xs') =<< dpIdentUnqualName msgIdent+  where+    parents par@(Single x) xs =+      case M.lookup par ctxt of+        Just (DotProtoTypeInfo { dotProtoTypeInfoParent = parentIdent' }) ->+          parents parentIdent' $ x : xs+        Nothing ->+          pure $ x : xs+    parents Anonymous xs =+      pure xs+    parents par _ =+      internalError $ "qualifiedMessageTypeName: wrong parent " <> show par+ -------------------------------------------------------------------------------- -- -- ** Codegen bookkeeping helpers@@ -474,7 +592,7 @@ getQualifiedFields msgName msgParts = flip foldMapM msgParts $ \case   DotProtoMessageField DotProtoField{..} -> do     fieldName <- dpIdentUnqualName dotProtoFieldName-    qualName  <- prefixedFieldName msgName fieldName+    qualName <- prefixedFieldName msgName fieldName     pure . (:[]) $ QualifiedField { recordFieldName = coerce qualName                                   , fieldInfo = FieldNormal (coerce fieldName)                                                             dotProtoFieldNumber@@ -526,18 +644,19 @@ --  data CompileError-  = CircularImport          FilePath-  | CompileParseError       ParseError-  | InternalError           String-  | InvalidPackageName      DotProtoIdentifier-  | InvalidMethodName       DotProtoIdentifier-  | InvalidTypeName         String-  | InvalidMapKeyType       String+  = CircularImport FilePath+  | CompileParseError ParseError+  | InternalError String+  | InvalidPackageName DotProtoIdentifier+  | InvalidMethodName DotProtoIdentifier+  | InvalidModuleName String+  | InvalidTypeName String+  | InvalidMapKeyType String   | NoPackageDeclaration-  | NoSuchType              DotProtoIdentifier+  | NoSuchType DotProtoIdentifier   | NonzeroFirstEnumeration String DotProtoIdentifier Int32-  | EmptyEnumeration        String-  | Unimplemented           String+  | EmptyEnumeration String+  | Unimplemented String   deriving (Show, Eq)  

@@ -103,12 +103,10 @@ identifier :: ProtoParser DotProtoIdentifier identifier = token _identifier --- [note] message and enum types are defined by the proto3 spec to have an optional leading period (messageType and enumType in the spec)---        what this indicates is, as far as i can tell, not documented, and i haven't found this syntax used in practice---        it's ommitted but can be fairly easily added if there is in fact a use for it---- [update] the leading dot denotes that the identifier path starts in global scope---          i still haven't seen a use case for this but i can add it upon request+-- Parses a full identifier, consuming trailing space.+-- The leading dot denotes that the identifier path starts in global scope.+globalIdentifier :: ProtoParser DotProtoIdentifier+globalIdentifier = token $ string "." >> _identifier  -- Parses a nested identifier, consuming trailing space. nestedIdentifier :: ProtoParser DotProtoIdentifier@@ -162,7 +160,7 @@        <|> try (symbol "string"   $> String)        <|> try (symbol "bytes"    $> Bytes)        <|> try (symbol "bool"     $> Bool)-       <|> Named <$> identifier+       <|> Named <$> (identifier <|> globalIdentifier)  -------------------------------------------------------------------------------- -- top-level parser and version annotation@@ -256,7 +254,7 @@  rpcClause :: ProtoParser (DotProtoIdentifier, Streaming) rpcClause = do-  let sid ctx = (,ctx) <$> identifier+  let sid ctx = (,ctx) <$> (identifier <|> globalIdentifier)   -- NB: Distinguish "stream stream.foo" from "stream.foo"   try (symbol "stream" *> sid Streaming) <|> sid NonStreaming @@ -296,6 +294,7 @@           <|> try (DotProtoMessageDefinition <$> message)           <|> try messageOneOf           <|> try (DotProtoMessageField      <$> messageField)+          <|> try (DotProtoMessageOption     <$> topOption)  messageType :: ProtoParser DotProtoType messageType = try mapType <|> try repType <|> (Prim <$> primType)

@@ -129,6 +129,8 @@     <+> (PP.hcat . PP.punctuate (PP.text ", ") $ pPrint <$> reservations)     <>  PP.text ";"   msgPart msgName (DotProtoMessageOneOf name fields)     = vbraces (PP.text "oneof" <+> pPrint name) (PP.vcat $ field msgName <$> fields)+  msgPart _       (DotProtoMessageOption opt)+    = PP.text "option" <+> pPrint opt <> PP.text ";"    field :: DotProtoIdentifier -> DotProtoField -> PP.Doc   field msgName (DotProtoField number mtype name options comments)@@ -185,7 +187,6 @@  instance Pretty DotProtoType where   pPrint (Prim           ty) = pPrint ty-  pPrint (Optional       ty) = pPrint ty   pPrint (Repeated       ty) = PP.text "repeated" <+> pPrint ty   pPrint (NestedRepeated ty) = PP.text "repeated" <+> pPrint ty   pPrint (Map keyty valuety) = PP.text "map<" <> pPrint keyty <> PP.text ", " <> pPrint valuety <> PP.text ">"

@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE DefaultSignatures   #-} {-# LANGUAGE DeriveGeneric       #-} {-# LANGUAGE FlexibleInstances   #-}@@ -71,6 +72,9 @@ import qualified Data.Aeson.Encoding              as E import qualified Data.Aeson.Encoding.Internal     as E import qualified Data.Aeson.Internal              as A (formatError, iparse)+#if MIN_VERSION_aeson(2,0,0)+import qualified Data.Aeson.Key                   as A+#endif import qualified Data.Aeson.Parser                as A (eitherDecodeWith) import qualified Data.Aeson.Types                 as A (Object, Pair, Parser,                                                         Series,@@ -102,6 +106,16 @@ import           Proto3.Wire.Class                (ProtoEnum(..)) import           Test.QuickCheck.Arbitrary        (Arbitrary(..)) +#if MIN_VERSION_aeson(2,0,0)+type Key = A.Key+keyFromText :: Text -> Key+keyFromText = A.fromText+#else+type Key = Text+keyFromText :: Text -> Text+keyFromText = id+#endif+ -- * Typeclass definitions  -- | 'A.ToJSON' variant for JSONPB direct encoding via 'A.Encoding'@@ -164,8 +178,8 @@ class Monoid m => KeyValuePB m where   pair :: ToJSONPB v => Text -> v -> Options -> m -instance KeyValuePB A.Series where pair k v opts = E.pair k (toEncodingPB v opts)-instance KeyValuePB [A.Pair] where pair k v opts = pure (k, toJSONPB v opts)+instance KeyValuePB A.Series where pair k v opts = E.pair (keyFromText k) (toEncodingPB v opts)+instance KeyValuePB [A.Pair] where pair k v opts = pure (keyFromText k, toJSONPB v opts)  -- | Construct a monoidal key-value pair, using 'mempty' to represent omission -- of default values (unless the given 'Options' force their emission).@@ -183,12 +197,12 @@ -- object, or if it is present but its value is null, we produce the default -- protobuf value for the field type (.:) :: (FromJSONPB a, HasDefault a) => A.Object -> Text -> A.Parser a-obj .: key = obj .:? key A..!= def+obj .: key = obj .:? keyFromText key A..!= def   where     (.:?) = A.explicitParseFieldMaybe parseJSONPB  parseField :: FromJSONPB a-           => A.Object -> Text -> A.Parser a+           => A.Object -> Key -> A.Parser a parseField = A.explicitParseField parseJSONPB  -- | >>> isDefault (def @E.Encoding)

@@ -32,7 +32,6 @@ import           GHC.Exts (IsList(..)) import           GHC.Generics import           Data.Int (Int32)-import           Data.Semigroup (Semigroup) import qualified Data.Vector as V import           GHC.TypeLits (Symbol) import           Proto3.Wire.Class (ProtoEnum(..))

@@ -0,0 +1,1 @@+module Proto3.Suite.DotProto.Generate.Swagger.Wrappers where

@@ -0,0 +1,93 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}++{-# OPTIONS_GHC -Wno-orphans #-}++module Proto3.Suite.DotProto.Generate.Swagger.Wrappers where++#if MIN_VERSION_swagger2(2,4,0)+import Control.Lens ((?~))+#else+import Control.Lens ((.~))+#endif+import Data.Functor ((<&>))+import Data.Int (Int32, Int64)+import Data.Proxy (Proxy (..))+import Data.Swagger+  ( Definitions+  , NamedSchema (..)+  , Schema+  , ToSchema (..)+  , byteSchema+  , format+  , paramSchema+  , schema+  )+import Data.Swagger.Declare (Declare)+import Data.Word (Word32, Word64)+import {-# SOURCE #-} Proto3.Suite.DotProto.Generate.Swagger (OverrideToSchema (..))++import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as BL+import qualified Data.Text as T+import qualified Data.Text.Lazy as TL++-- | Wrapped Type Schemas++setFormat+  :: T.Text+  -> Declare (Definitions Schema) NamedSchema+  -> Declare (Definitions Schema) NamedSchema+setFormat formatValue namedSchema =+  namedSchema+#if MIN_VERSION_swagger2(2,4,0)+    <&> schema . paramSchema . format ?~ formatValue+#else+    <&> schema . paramSchema . format .~ formatValue+#endif++declareWrapperNamedSchema+  :: forall a+   . ToSchema a+  => T.Text+  -> Proxy (OverrideToSchema a)+  -> Declare (Definitions Schema) NamedSchema+declareWrapperNamedSchema formatValue _ =+  setFormat formatValue (declareNamedSchema (Proxy :: Proxy a))++instance {-# OVERLAPPING #-} ToSchema (OverrideToSchema (Maybe Double)) where+  declareNamedSchema = declareWrapperNamedSchema "DoubleValue"++instance {-# OVERLAPPING #-} ToSchema (OverrideToSchema (Maybe Float)) where+  declareNamedSchema = declareWrapperNamedSchema "FloatValue"++instance {-# OVERLAPPING #-} ToSchema (OverrideToSchema (Maybe Int64)) where+  declareNamedSchema = declareWrapperNamedSchema "Int64Value"++instance {-# OVERLAPPING #-} ToSchema (OverrideToSchema (Maybe Word64)) where+  declareNamedSchema = declareWrapperNamedSchema "UInt64Value"++instance {-# OVERLAPPING #-} ToSchema (OverrideToSchema (Maybe Int32)) where+  declareNamedSchema = declareWrapperNamedSchema "Int32Value"++instance {-# OVERLAPPING #-} ToSchema (OverrideToSchema (Maybe Word32)) where+  declareNamedSchema = declareWrapperNamedSchema "UInt32Value"++instance {-# OVERLAPPING #-} ToSchema (OverrideToSchema (Maybe Bool)) where+  declareNamedSchema = declareWrapperNamedSchema "BoolValue"++instance {-# OVERLAPPING #-} ToSchema (OverrideToSchema (Maybe T.Text)) where+  declareNamedSchema = declareWrapperNamedSchema "StringValue"++instance {-# OVERLAPPING #-} ToSchema (OverrideToSchema (Maybe TL.Text)) where+  declareNamedSchema = declareWrapperNamedSchema "StringValue"++instance {-# OVERLAPPING #-} ToSchema (OverrideToSchema (Maybe B.ByteString)) where+  declareNamedSchema _ =+    setFormat "BytesValue" (pure (NamedSchema Nothing byteSchema))++instance {-# OVERLAPPING #-} ToSchema (OverrideToSchema (Maybe BL.ByteString)) where+  declareNamedSchema _ =+    setFormat "BytesValue" (pure (NamedSchema Nothing byteSchema))

@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} {-# OPTIONS_GHC -fno-warn-orphans #-}  module ArbitraryGeneratedTestTypes where@@ -5,9 +6,9 @@ import qualified Data.Text.Lazy        as T import qualified Data.Vector           as V import qualified Proto3.Suite.Types as DotProto-import           Test.QuickCheck       (Arbitrary, arbitrary, listOf)+import           Test.QuickCheck       (listOf) import qualified Test.QuickCheck       as QC-import           Test.QuickCheck.Arbitrary.Generic (genericArbitrary)+import           Test.QuickCheck.Arbitrary.Generic (genericArbitrary, Arbitrary (arbitrary)) import           TestProto import qualified TestProtoImport import qualified TestProtoOneof

@@ -15,7 +15,6 @@ import           Data.Either                 (isRight) import qualified Data.List.NonEmpty          as NE import           Data.String-import           Data.Semigroup              ((<>)) import           GHC.Exts                    (fromList, Proxy#) import           Proto3.Suite import           Proto3.Wire.Decode          (ParseError)@@ -35,6 +34,10 @@ import           TestDhall #endif +import qualified Test.Proto.Generate.Name++-- -----------------------------------------------------------------------------+ main :: IO () main = defaultMain tests @@ -47,13 +50,14 @@   , parserUnitTests   , dotProtoUnitTests   , codeGenTests+  , Test.Proto.Generate.Name.tests  #ifdef DHALL   , dhallTests #endif   ] ---------------------------------------------------------------------------------+-- ----------------------------------------------------------------------------- -- Doctests  docTests :: TestTree@@ -255,12 +259,12 @@   ]  trivialDotProto :: DotProto-trivialDotProto = DotProto [] [] DotProtoNoPackage [] (DotProtoMeta (Path $ "test-files" NE.:| ["trivial"]))+trivialDotProto = DotProto [] [] DotProtoNoPackage [] (DotProtoMeta (Path $ "test-files" NE.:| ["test_trivial"]))  dotProtoParseTrivial :: TestTree dotProtoParseTrivial = testCase   "Parse a content-less file" $-  testDotProtoParse "test-files/trivial.proto" trivialDotProto+  testDotProtoParse (testFilesPfx <> "trivial.proto") trivialDotProto  dotProtoPrintTrivial :: TestTree dotProtoPrintTrivial = testCase

@@ -0,0 +1,53 @@+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE TypeApplications #-}++-- |+--+module Test.Proto.Generate.Name (tests) where++import Test.Tasty (TestTree, testGroup)+import Test.Tasty.Hedgehog (testProperty)++import Hedgehog (MonadTest, Property, annotate, forAll, property, (===))+import Hedgehog.Gen qualified as Gen+import Hedgehog.Range qualified as Range++import Test.Proto.Generate.Name.Gen (GenName)+import Test.Proto.Generate.Name.Gen qualified as Name.Gen++import Proto3.Suite.DotProto.Generate++-- -----------------------------------------------------------------------------++tests :: TestTree+tests =+  testGroup+    "Test.Proto.Generate.Name"+    [ testProperty "filenames" resolve'protofile+    ]++-- | Testing combinator for name resolution functions.+testResolution ::+  (MonadTest m, Applicative f, Eq (f String), Show (f String)) =>+  (String -> f String) -> GenName -> m ()+testResolution resolve nm = do+  let occ = Name.Gen.nameOcc nm+  let res = Name.Gen.nameRes nm+  let got = resolve occ++  annotate ("protobuf name: " ++ occ)+  annotate ("expected name: " ++ res)+  annotate ("resolved name: " ++ show got)++  pure res === got++-- -----------------------------------------------------------------------------+--+-- Name Resolution Tests+--++resolve'protofile :: Property+resolve'protofile = property do+  nm <- forAll $ Gen.sized (Name.Gen.protofile . Range.linear 1 . fromIntegral)+  testResolution (renameProtoFile @(Either CompileError)) nm

@@ -0,0 +1,92 @@+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- |+module Test.Proto.Generate.Name.Gen+  ( GenName (GenName, nameOcc, nameRes),+    protofile,+  )+where++import Hedgehog (MonadGen, Range)+import Hedgehog.Gen qualified as Gen+import Hedgehog.Range qualified as Range++import Control.Applicative+import Data.Char qualified as Char++-- -----------------------------------------------------------------------------++-- | 'GenName' is an association between generated names.+--+--   * 'nameOcc' is how the name occurs in the context of protocol buffers.+--+--   * 'nameRes' is a Haskell name that 'nameOcc' is expected to resolve as.+--+-- ==== __Example__+--+-- The *.proto filename "my_messages" should be resolved to the Haskell module+-- "MyMessages", so we would generate a 'GenName':+--+-- >>> GenName "my_messages" "MyMessages"+-- GenName {nameOcc = "my_messages", nameRes = "MyMessages"}+--+-- After an associated pair is generated, it can be used to test a renaming (call+-- it @f@) by checking:+--+-- prop> f (nameOcc nm) == nameRes nm+data GenName = GenName+  { nameOcc :: String+  , nameRes :: String+  }+  deriving (Eq, Show)++-- | Generate the name of a Protobuf file and the Haskell module it should be+-- resolved to.+protofile :: forall m. MonadGen m => Range Int -> m GenName+protofile len = do+  (psize, usize) <- Gen.sized \sz -> do+    x <- Gen.int (Range.linear 0 (fromIntegral sz))+    y <- Gen.int (Range.linear 0 (fromIntegral sz))+    pure (x, y)++  nm <- Gen.sized (ident . Range.linear 1 . fromIntegral)+  ps <- nameParts (Range.linear 0 psize)+  us <- underscores (Range.linear 0 usize)++  let nameOcc = nm ++ concatMap fst ps ++ us+  let nameRes = upperFirst nm ++ concatMap snd ps ++ us+  pure GenName {nameOcc, nameRes}+  where+    ident :: Range Int -> m String+    ident = liftA2 (:) Gen.alpha . alphaNum++    nameParts :: Range Int -> m [(String, String)]+    nameParts rng = Gen.list len do+      n <- Gen.sized (Gen.int . Range.linear 1 . fromIntegral)+      nm <- ident rng+      us <- underscores (Range.linear 1 (fromIntegral n))+      pure (us ++ nm, drop 1 us ++ upperFirst nm)++    upperFirst :: String -> String+    upperFirst (c : cs) = Char.toUpper c : cs+    upperFirst "" = ""++-- -----------------------------------------------------------------------------+--+-- Primitive Name Generation Combinators+--++-- | Generate a string made up of underscores.+underscores :: MonadGen m => Range Int -> m String+underscores rng = Gen.list rng (pure '_')++-- | Generate a name containing alphabetical and numeric characters+-- @'a' .. 'z'@, @'A' .. 'Z'@, and @'0' .. '1'@.+alphaNum :: MonadGen m => Range Int -> m String+alphaNum rng = Gen.list rng Gen.alphaNum

@@ -13,7 +13,6 @@ import qualified Data.Aeson import qualified Data.ByteString.Lazy           as LBS import qualified Data.ByteString.Lazy.Char8     as LBS8-import           Data.Monoid                    ((<>)) import           Data.Proxy                     (Proxy(..)) import           Data.String                    (IsString) import           Data.Swagger                   (ToSchema)@@ -35,15 +34,12 @@  codeGenTests :: TestTree codeGenTests = testGroup "Code generator unit tests"-  [ camelCaseMessageNames+  [ pascalCaseMessageNames   , camelCaseMessageFieldNames   , don'tAlterEnumFieldNames   , knownTypeMessages-  {--   - These tests have been temporarily removed to pass CI.   , simpleEncodeDotProto   , simpleDecodeDotProto-  -}   ]  knownTypeMessages :: TestTree@@ -56,8 +52,8 @@         $ eitherDecode "\"1970-01-01T00:00:00Z\"" @?= Right (Timestamp 0 0)     ] -camelCaseMessageNames :: TestTree-camelCaseMessageNames = testGroup "CamelCasing of message names"+pascalCaseMessageNames :: TestTree+pascalCaseMessageNames = testGroup "PascalCasing of message names"   [ testCase "Capitalizes letters after underscores"       $ typeLikeName "protocol_analysis" @?= Right "ProtocolAnalysis" @@ -103,8 +99,8 @@         prefixedEnumFieldName enumName fieldName @?= (enumName <> fieldName)  setPythonPath :: IO ()-setPythonPath = Turtle.export "PYTHONPATH" =<<-  maybe pyTmpDir (\p -> pyTmpDir <> ":" <> p) <$> Turtle.need "PYTHONPATH"+setPythonPath = Turtle.export "PYTHONPATH" .+  maybe pyTmpDir (\p -> pyTmpDir <> ":" <> p) =<< Turtle.need "PYTHONPATH"  simpleEncodeDotProto :: TestTree simpleEncodeDotProto =@@ -144,10 +140,9 @@  -- E.g. dumpAST ["test-files"] "test_proto.proto" dumpAST :: [FilePath] -> FilePath -> IO ()-dumpAST incs fp = (either (error . show) putStrLn <=< runExceptT) $ do+dumpAST incs fp = either (error . show) putStrLn <=< runExceptT $ do   (dp, tc) <- readDotProtoWithContext incs fp-  src <- renderHsModuleForDotProto mempty dp tc-  pure src+  renderHsModuleForDotProto mempty dp tc  hsTmpDir, pyTmpDir :: IsString a => a hsTmpDir = "test-files/hs-tmp"@@ -162,6 +157,11 @@         , "test_proto_import.proto"         , "test_proto_oneof.proto"         , "test_proto_oneof_import.proto"+        {- These tests have been temporarily removed to pass CI.+        , "test_proto_leading_dot.proto"+        , "test_proto_protoc_plugin.proto"+        -}+        , "test_proto_nested_message.proto"         ]    forM_ protoFiles $ \protoFile -> do

@@ -3,7 +3,6 @@ import           TestProtoOneof import           Test.Tasty import           Test.Tasty.HUnit               (testCase, (@?=))- import qualified Dhall import qualified Dhall.Core 

@@ -1,4 +1,3 @@-#!/usr/bin/env bash set -eu hsTmpDir=$1 @@ -13,3 +12,7 @@     $hsTmpDir/TestProtoOneofImport.hs       \     tests/SimpleDecodeDotProto.hs           \     >/dev/null++# These tests have been temporarily removed to pass CI.+#    $hsTmpDir/TestProtoLeadingDot.hs        \+#    $hsTmpDir/TestProtoProtocPlugin.hs      \

@@ -1,4 +1,3 @@-#!/usr/bin/env bash set -eu hsTmpDir=$1 @@ -13,3 +12,7 @@     $hsTmpDir/TestProtoOneofImport.hs       \     tests/SimpleEncodeDotProto.hs           \     >/dev/null++# These tests have been temporarily removed to pass CI.+#    $hsTmpDir/TestProtoLeadingDot.hs        \+#    $hsTmpDir/TestProtoProtocPlugin.hs      \

@@ -40,6 +40,12 @@     Left err      -> fail (show err)     Right (dp, _) -> putStr (toProtoFile defRenderingOptions (canonicalize dp)) +data PartRank+    = PartRankOption DotProtoOption+    | PartRankDefinition (Int, DotProtoIdentifier)+    | PartRankReserved+    | PartRankField (Maybe FieldNumber) deriving (Eq, Ord)+ class Canonicalize a where   canonicalize :: a -> a @@ -116,16 +122,15 @@         FieldRange _ _ -> False         ReservedIdentifier _ -> True -instance CanonicalRank DotProtoMessagePart-         (Either (Either (Int, DotProtoIdentifier) ())-                 (Maybe FieldNumber)) where+instance CanonicalRank DotProtoMessagePart PartRank where   canonicalRank = \case-    DotProtoMessageField f -> Right (canonicalRank f)-    DotProtoMessageOneOf _ fs -> Right (canonicalRank fs)-    DotProtoMessageDefinition d -> Left (Left (canonicalRank d))-    DotProtoMessageReserved _fs -> Left (Right ())-      -- We use '()' here because 'Canonicalize [DotProtoMessagePart]'+    DotProtoMessageOption x -> PartRankOption x+    DotProtoMessageDefinition d -> PartRankDefinition (canonicalRank d)+    DotProtoMessageReserved _fs -> PartRankReserved+      -- We don't use '_fs' here because 'Canonicalize [DotProtoMessagePart]'       -- collapses all of the 'DotProtoMessageReserved's into just one.+    DotProtoMessageField f -> PartRankField (canonicalRank f)+    DotProtoMessageOneOf _ fs -> PartRankField (canonicalRank fs)  instance Canonicalize DotProtoMessagePart where   canonicalize = \case@@ -137,6 +142,8 @@       DotProtoMessageDefinition (canonicalize d)     DotProtoMessageReserved fs ->       DotProtoMessageReserved (canonicalize fs)+    DotProtoMessageOption option ->+      DotProtoMessageOption (canonicalize option)  instance CanonicalRank [DotProtoField] (Maybe FieldNumber) where   canonicalRank =

@@ -8,7 +8,6 @@ {-# LANGUAGE StandaloneDeriving  #-} {-# LANGUAGE TypeOperators       #-} -import           Data.Semigroup                 ((<>)) import           Options.Applicative import           Prelude                        hiding (FilePath) import           Proto3.Suite.DotProto.Generate