proto3-suite 0.3.0.0 → 0.4.0.0

raw patch · 23 files changed

+3472/−2952 lines, 23 filesdep +generic-arbitrarydep +optparse-applicativedep ~QuickCheckdep ~proto3-wiredep ~swagger2PVP ok

version bump matches the API change (PVP)

Dependencies added: generic-arbitrary, optparse-applicative

Dependency ranges changed: QuickCheck, proto3-wire, swagger2

API changes (from Hackage documentation)

Files

• gen/TestProto.hs +565/−335
• gen/TestProtoImport.hs +36/−26
• gen/TestProtoOneof.hs +87/−86
• gen/TestProtoOneofImport.hs +117/−25
• proto3-suite.cabal +13/−8
• src/Proto3/Suite/Class.hs +85/−74
• src/Proto3/Suite/DhallPB.hs +2/−2
• src/Proto3/Suite/DotProto.hs +2/−0
• src/Proto3/Suite/DotProto/AST.hs +52/−43
• src/Proto3/Suite/DotProto/AST/Lens.hs +9/−0
• src/Proto3/Suite/DotProto/Generate.hs +1815/−2147
• src/Proto3/Suite/DotProto/Generate/Swagger.hs +14/−1
• src/Proto3/Suite/DotProto/Internal.hs +449/−62
• src/Proto3/Suite/DotProto/Parsing.hs +32/−25
• src/Proto3/Suite/DotProto/Rendering.hs +31/−21
• src/Proto3/Suite/JSONPB/Class.hs +9/−2
• src/Proto3/Suite/Tutorial.hs +9/−8
• src/Proto3/Suite/Types.hs +5/−5
• tests/ArbitraryGeneratedTestTypes.hs +5/−5
• tests/Main.hs +13/−10
• tests/TestCodeGen.hs +69/−35
• tools/canonicalize-proto-file/Main.hs +25/−19
• tools/compile-proto-file/Main.hs +28/−13

@@ -1,6 +1,8 @@ {-# LANGUAGE DeriveGeneric     #-}+{-# LANGUAGE DeriveAnyClass    #-} {-# LANGUAGE DataKinds         #-} {-# LANGUAGE GADTs             #-}+{-# LANGUAGE TypeApplications  #-} {-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-unused-imports #-} {-# OPTIONS_GHC -fno-warn-name-shadowing #-}@@ -9,33 +11,39 @@ -- | Generated by Haskell protocol buffer compiler. DO NOT EDIT! module TestProto where import qualified Prelude as Hs-import qualified Proto3.Suite.DhallPB as HsDhallPb-import qualified Proto3.Suite.DotProto as HsProtobuf-import qualified Proto3.Suite.Types as HsProtobuf 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 Control.Applicative ((<*>), (<|>), (<$>)) import qualified Control.Applicative as Hs+import Control.Applicative ((<*>), (<|>), (<$>))+import qualified Control.DeepSeq as Hs import qualified Control.Monad as Hs-import qualified Data.Text.Lazy as Hs (Text) 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.Int as Hs (Int16, Int32, Int64) import qualified Data.Word as Hs (Word16, Word32, Word64)-import qualified Data.Proxy as Proxy-import qualified GHC.Generics as Hs import qualified GHC.Enum as Hs+import qualified GHC.Generics as Hs+import qualified Unsafe.Coerce as Hs import qualified TestProtoImport   data Trivial = Trivial{trivialTrivialField :: Hs.Int32}-             deriving (Hs.Show, Hs.Eq, Hs.Ord, Hs.Generic)+             deriving (Hs.Show, Hs.Eq, Hs.Ord, Hs.Generic, Hs.NFData)   instance HsProtobuf.Named Trivial where         nameOf _ = (Hs.fromString "Trivial")  +instance HsProtobuf.HasDefault Trivial+  instance HsProtobuf.Message Trivial where         encodeMessage _ Trivial{trivialTrivialField = trivialTrivialField}           = (Hs.mconcat@@ -50,7 +58,7 @@                 (HsProtobuf.Prim HsProtobuf.Int32)                 (HsProtobuf.Single "trivialField")                 []-                Hs.Nothing)]+                "")]   instance HsJSONPB.ToJSONPB Trivial where         toJSONPB (Trivial f1) = (HsJSONPB.object ["trivialField" .= f1])@@ -84,10 +92,6 @@                                                      HsJSONPB.insOrdFromList                                                        [("trivialField", trivialTrivialField)]}})  -instance HsDhallPb.Interpret Trivial- -instance HsDhallPb.Inject Trivial-  data MultipleFields = MultipleFields{multipleFieldsMultiFieldDouble                                      :: Hs.Double,                                      multipleFieldsMultiFieldFloat :: Hs.Float,@@ -95,11 +99,13 @@                                      multipleFieldsMultiFieldInt64 :: Hs.Int64,                                      multipleFieldsMultiFieldString :: Hs.Text,                                      multipleFieldsMultiFieldBool :: Hs.Bool}-                    deriving (Hs.Show, Hs.Eq, Hs.Ord, Hs.Generic)+                    deriving (Hs.Show, Hs.Eq, Hs.Ord, Hs.Generic, Hs.NFData)   instance HsProtobuf.Named MultipleFields where         nameOf _ = (Hs.fromString "MultipleFields")  +instance HsProtobuf.HasDefault MultipleFields+  instance HsProtobuf.Message MultipleFields where         encodeMessage _           MultipleFields{multipleFieldsMultiFieldDouble =@@ -146,32 +152,32 @@                 (HsProtobuf.Prim HsProtobuf.Double)                 (HsProtobuf.Single "multiFieldDouble")                 []-                Hs.Nothing),+                ""),              (HsProtobuf.DotProtoField (HsProtobuf.FieldNumber 2)                 (HsProtobuf.Prim HsProtobuf.Float)                 (HsProtobuf.Single "multiFieldFloat")                 []-                Hs.Nothing),+                ""),              (HsProtobuf.DotProtoField (HsProtobuf.FieldNumber 3)                 (HsProtobuf.Prim HsProtobuf.Int32)                 (HsProtobuf.Single "multiFieldInt32")                 []-                Hs.Nothing),+                ""),              (HsProtobuf.DotProtoField (HsProtobuf.FieldNumber 4)                 (HsProtobuf.Prim HsProtobuf.Int64)                 (HsProtobuf.Single "multiFieldInt64")                 []-                Hs.Nothing),+                ""),              (HsProtobuf.DotProtoField (HsProtobuf.FieldNumber 5)                 (HsProtobuf.Prim HsProtobuf.String)                 (HsProtobuf.Single "multiFieldString")                 []-                Hs.Nothing),+                ""),              (HsProtobuf.DotProtoField (HsProtobuf.FieldNumber 6)                 (HsProtobuf.Prim HsProtobuf.Bool)                 (HsProtobuf.Single "multiFieldBool")                 []-                Hs.Nothing)]+                "")]   instance HsJSONPB.ToJSONPB MultipleFields where         toJSONPB (MultipleFields f1 f2 f3 f4 f5 f6)@@ -251,33 +257,33 @@                                                         ("multiFieldBool",                                                          multipleFieldsMultiFieldBool)]}})  -instance HsDhallPb.Interpret MultipleFields- -instance HsDhallPb.Inject MultipleFields-  data SignedInts = SignedInts{signedIntsSigned32 :: Hs.Int32,                              signedIntsSigned64 :: Hs.Int64}-                deriving (Hs.Show, Hs.Eq, Hs.Ord, Hs.Generic)+                deriving (Hs.Show, Hs.Eq, Hs.Ord, Hs.Generic, Hs.NFData)   instance HsProtobuf.Named SignedInts where         nameOf _ = (Hs.fromString "SignedInts")  +instance HsProtobuf.HasDefault SignedInts+  instance HsProtobuf.Message SignedInts where         encodeMessage _           SignedInts{signedIntsSigned32 = signedIntsSigned32,                      signedIntsSigned64 = signedIntsSigned64}           = (Hs.mconcat                [(HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 1)-                   (HsProtobuf.Signed signedIntsSigned32)),+                   (Hs.coerce @(Hs.Int32) @(HsProtobuf.Signed Hs.Int32)+                      signedIntsSigned32)),                 (HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 2)-                   (HsProtobuf.Signed signedIntsSigned64))])+                   (Hs.coerce @(Hs.Int64) @(HsProtobuf.Signed Hs.Int64)+                      signedIntsSigned64))])         decodeMessage _           = (Hs.pure SignedInts) <*>-              ((Hs.pure HsProtobuf.signed) <*>+              (Hs.coerce @(_ (HsProtobuf.Signed Hs.Int32)) @(_ Hs.Int32)                  (HsProtobuf.at HsProtobuf.decodeMessageField                     (HsProtobuf.FieldNumber 1)))               <*>-              ((Hs.pure HsProtobuf.signed) <*>+              (Hs.coerce @(_ (HsProtobuf.Signed Hs.Int64)) @(_ Hs.Int64)                  (HsProtobuf.at HsProtobuf.decodeMessageField                     (HsProtobuf.FieldNumber 2)))         dotProto _@@ -285,12 +291,12 @@                 (HsProtobuf.Prim HsProtobuf.SInt32)                 (HsProtobuf.Single "signed32")                 []-                Hs.Nothing),+                ""),              (HsProtobuf.DotProtoField (HsProtobuf.FieldNumber 2)                 (HsProtobuf.Prim HsProtobuf.SInt64)                 (HsProtobuf.Single "signed64")                 []-                Hs.Nothing)]+                "")]   instance HsJSONPB.ToJSONPB SignedInts where         toJSONPB (SignedInts f1 f2)@@ -331,17 +337,15 @@                                                        [("signed32", signedIntsSigned32),                                                         ("signed64", signedIntsSigned64)]}})  -instance HsDhallPb.Interpret SignedInts- -instance HsDhallPb.Inject SignedInts-  data WithEnum = WithEnum{withEnumEnumField ::                          HsProtobuf.Enumerated TestProto.WithEnum_TestEnum}-              deriving (Hs.Show, Hs.Eq, Hs.Ord, Hs.Generic)+              deriving (Hs.Show, Hs.Eq, Hs.Ord, Hs.Generic, Hs.NFData)   instance HsProtobuf.Named WithEnum where         nameOf _ = (Hs.fromString "WithEnum")  +instance HsProtobuf.HasDefault WithEnum+  instance HsProtobuf.Message WithEnum where         encodeMessage _ WithEnum{withEnumEnumField = withEnumEnumField}           = (Hs.mconcat@@ -356,7 +360,7 @@                 (HsProtobuf.Prim (HsProtobuf.Named (HsProtobuf.Single "TestEnum")))                 (HsProtobuf.Single "enumField")                 []-                Hs.Nothing)]+                "")]   instance HsJSONPB.ToJSONPB WithEnum where         toJSONPB (WithEnum f1) = (HsJSONPB.object ["enumField" .= f1])@@ -390,33 +394,34 @@                                                      HsJSONPB.insOrdFromList                                                        [("enumField", withEnumEnumField)]}})  -instance HsDhallPb.Interpret WithEnum- -instance HsDhallPb.Inject WithEnum-  data WithEnum_TestEnum = WithEnum_TestEnumENUM1                        | WithEnum_TestEnumENUM2                        | WithEnum_TestEnumENUM3-                       deriving (Hs.Show, Hs.Bounded, Hs.Eq, Hs.Ord, Hs.Generic)+                       deriving (Hs.Show, Hs.Eq, Hs.Generic, Hs.NFData)   instance HsProtobuf.Named WithEnum_TestEnum where         nameOf _ = (Hs.fromString "WithEnum_TestEnum")  -instance Hs.Enum WithEnum_TestEnum where-        toEnum 0 = WithEnum_TestEnumENUM1-        toEnum 1 = WithEnum_TestEnumENUM2-        toEnum 2 = WithEnum_TestEnumENUM3-        toEnum i = (Hs.toEnumError "WithEnum_TestEnum" i (0 :: Hs.Int, 2))-        fromEnum (WithEnum_TestEnumENUM1) = 0-        fromEnum (WithEnum_TestEnumENUM2) = 1-        fromEnum (WithEnum_TestEnumENUM3) = 2-        succ (WithEnum_TestEnumENUM1) = WithEnum_TestEnumENUM2-        succ (WithEnum_TestEnumENUM2) = WithEnum_TestEnumENUM3-        succ _ = Hs.succError "WithEnum_TestEnum"-        pred (WithEnum_TestEnumENUM2) = WithEnum_TestEnumENUM1-        pred (WithEnum_TestEnumENUM3) = WithEnum_TestEnumENUM2-        pred _ = Hs.predError "WithEnum_TestEnum"+instance HsProtobuf.HasDefault WithEnum_TestEnum  +instance Hs.Bounded WithEnum_TestEnum where+        minBound = WithEnum_TestEnumENUM1+        maxBound = WithEnum_TestEnumENUM3+ +instance Hs.Ord WithEnum_TestEnum where+        compare x y+          = Hs.compare (HsProtobuf.fromProtoEnum x)+              (HsProtobuf.fromProtoEnum y)+ +instance HsProtobuf.ProtoEnum WithEnum_TestEnum where+        toProtoEnumMay 0 = Hs.Just WithEnum_TestEnumENUM1+        toProtoEnumMay 1 = Hs.Just WithEnum_TestEnumENUM2+        toProtoEnumMay 2 = Hs.Just WithEnum_TestEnumENUM3+        toProtoEnumMay _ = Hs.Nothing+        fromProtoEnum (WithEnum_TestEnumENUM1) = 0+        fromProtoEnum (WithEnum_TestEnumENUM2) = 1+        fromProtoEnum (WithEnum_TestEnumENUM3) = 2+  instance HsJSONPB.ToJSONPB WithEnum_TestEnum where         toJSONPB x _ = HsJSONPB.enumFieldString x         toEncodingPB x _ = HsJSONPB.enumFieldEncoding x@@ -437,28 +442,29 @@ instance HsJSONPB.FromJSON WithEnum_TestEnum where         parseJSON = HsJSONPB.parseJSONPB  -instance HsDhallPb.Interpret WithEnum_TestEnum- -instance HsDhallPb.Inject WithEnum_TestEnum-  instance HsProtobuf.Finite WithEnum_TestEnum   data WithNesting = WithNesting{withNestingNestedMessage ::                                Hs.Maybe TestProto.WithNesting_Nested}-                 deriving (Hs.Show, Hs.Eq, Hs.Ord, Hs.Generic)+                 deriving (Hs.Show, Hs.Eq, Hs.Ord, Hs.Generic, Hs.NFData)   instance HsProtobuf.Named WithNesting where         nameOf _ = (Hs.fromString "WithNesting")  +instance HsProtobuf.HasDefault WithNesting+  instance HsProtobuf.Message WithNesting where         encodeMessage _           WithNesting{withNestingNestedMessage = withNestingNestedMessage}           = (Hs.mconcat                [(HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 1)-                   (HsProtobuf.Nested withNestingNestedMessage))])+                   (Hs.coerce @(Hs.Maybe TestProto.WithNesting_Nested)+                      @(HsProtobuf.Nested TestProto.WithNesting_Nested)+                      withNestingNestedMessage))])         decodeMessage _           = (Hs.pure WithNesting) <*>-              ((Hs.pure HsProtobuf.nested) <*>+              (Hs.coerce @(_ (HsProtobuf.Nested TestProto.WithNesting_Nested))+                 @(_ (Hs.Maybe TestProto.WithNesting_Nested))                  (HsProtobuf.at HsProtobuf.decodeMessageField                     (HsProtobuf.FieldNumber 1)))         dotProto _@@ -466,7 +472,7 @@                 (HsProtobuf.Prim (HsProtobuf.Named (HsProtobuf.Single "Nested")))                 (HsProtobuf.Single "nestedMessage")                 []-                Hs.Nothing)]+                "")]   instance HsJSONPB.ToJSONPB WithNesting where         toJSONPB (WithNesting f1)@@ -504,20 +510,18 @@                                                        [("nestedMessage",                                                          withNestingNestedMessage)]}})  -instance HsDhallPb.Interpret WithNesting- -instance HsDhallPb.Inject WithNesting-  data WithNesting_Nested = WithNesting_Nested{withNesting_NestedNestedField1                                              :: Hs.Text,                                              withNesting_NestedNestedField2 :: Hs.Int32,                                              withNesting_NestedNestedPacked :: Hs.Vector Hs.Int32,                                              withNesting_NestedNestedUnpacked :: Hs.Vector Hs.Int32}-                        deriving (Hs.Show, Hs.Eq, Hs.Ord, Hs.Generic)+                        deriving (Hs.Show, Hs.Eq, Hs.Ord, Hs.Generic, Hs.NFData)   instance HsProtobuf.Named WithNesting_Nested where         nameOf _ = (Hs.fromString "WithNesting_Nested")  +instance HsProtobuf.HasDefault WithNesting_Nested+  instance HsProtobuf.Message WithNesting_Nested where         encodeMessage _           WithNesting_Nested{withNesting_NestedNestedField1 =@@ -532,9 +536,11 @@                 (HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 2)                    withNesting_NestedNestedField2),                 (HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 3)-                   (HsProtobuf.PackedVec withNesting_NestedNestedPacked)),+                   (Hs.coerce @(Hs.Vector Hs.Int32) @(HsProtobuf.PackedVec Hs.Int32)+                      withNesting_NestedNestedPacked)),                 (HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 4)-                   (HsProtobuf.UnpackedVec withNesting_NestedNestedUnpacked))])+                   (Hs.coerce @(Hs.Vector Hs.Int32) @(HsProtobuf.UnpackedVec Hs.Int32)+                      withNesting_NestedNestedUnpacked))])         decodeMessage _           = (Hs.pure WithNesting_Nested) <*>               (HsProtobuf.at HsProtobuf.decodeMessageField@@ -543,11 +549,13 @@               (HsProtobuf.at HsProtobuf.decodeMessageField                  (HsProtobuf.FieldNumber 2))               <*>-              ((Hs.pure HsProtobuf.packedvec) <*>+              (Hs.coerce @(_ (HsProtobuf.PackedVec Hs.Int32))+                 @(_ (Hs.Vector Hs.Int32))                  (HsProtobuf.at HsProtobuf.decodeMessageField                     (HsProtobuf.FieldNumber 3)))               <*>-              ((Hs.pure HsProtobuf.unpackedvec) <*>+              (Hs.coerce @(_ (HsProtobuf.UnpackedVec Hs.Int32))+                 @(_ (Hs.Vector Hs.Int32))                  (HsProtobuf.at HsProtobuf.decodeMessageField                     (HsProtobuf.FieldNumber 4)))         dotProto _@@ -555,24 +563,24 @@                 (HsProtobuf.Prim HsProtobuf.String)                 (HsProtobuf.Single "nestedField1")                 []-                Hs.Nothing),+                ""),              (HsProtobuf.DotProtoField (HsProtobuf.FieldNumber 2)                 (HsProtobuf.Prim HsProtobuf.Int32)                 (HsProtobuf.Single "nestedField2")                 []-                Hs.Nothing),+                ""),              (HsProtobuf.DotProtoField (HsProtobuf.FieldNumber 3)                 (HsProtobuf.Repeated HsProtobuf.Int32)                 (HsProtobuf.Single "nestedPacked")                 [(HsProtobuf.DotProtoOption (HsProtobuf.Single "packed")                     (HsProtobuf.BoolLit Hs.True))]-                Hs.Nothing),+                ""),              (HsProtobuf.DotProtoField (HsProtobuf.FieldNumber 4)                 (HsProtobuf.Repeated HsProtobuf.Int32)                 (HsProtobuf.Single "nestedUnpacked")                 [(HsProtobuf.DotProtoOption (HsProtobuf.Single "packed")                     (HsProtobuf.BoolLit Hs.False))]-                Hs.Nothing)]+                "")]   instance HsJSONPB.ToJSONPB WithNesting_Nested where         toJSONPB (WithNesting_Nested f1 f2 f3 f4)@@ -634,27 +642,29 @@                                                         ("nestedUnpacked",                                                          withNesting_NestedNestedUnpacked)]}})  -instance HsDhallPb.Interpret WithNesting_Nested- -instance HsDhallPb.Inject WithNesting_Nested-  data WithNestingRepeated = WithNestingRepeated{withNestingRepeatedNestedMessages                                                :: Hs.Vector TestProto.WithNestingRepeated_Nested}-                         deriving (Hs.Show, Hs.Eq, Hs.Ord, Hs.Generic)+                         deriving (Hs.Show, Hs.Eq, Hs.Ord, Hs.Generic, Hs.NFData)   instance HsProtobuf.Named WithNestingRepeated where         nameOf _ = (Hs.fromString "WithNestingRepeated")  +instance HsProtobuf.HasDefault WithNestingRepeated+  instance HsProtobuf.Message WithNestingRepeated where         encodeMessage _           WithNestingRepeated{withNestingRepeatedNestedMessages =                                 withNestingRepeatedNestedMessages}           = (Hs.mconcat                [(HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 1)-                   (HsProtobuf.NestedVec withNestingRepeatedNestedMessages))])+                   (Hs.coerce @(Hs.Vector TestProto.WithNestingRepeated_Nested)+                      @(HsProtobuf.NestedVec TestProto.WithNestingRepeated_Nested)+                      withNestingRepeatedNestedMessages))])         decodeMessage _           = (Hs.pure WithNestingRepeated) <*>-              ((Hs.pure HsProtobuf.nestedvec) <*>+              (Hs.coerce+                 @(_ (HsProtobuf.NestedVec TestProto.WithNestingRepeated_Nested))+                 @(_ (Hs.Vector TestProto.WithNestingRepeated_Nested))                  (HsProtobuf.at HsProtobuf.decodeMessageField                     (HsProtobuf.FieldNumber 1)))         dotProto _@@ -663,7 +673,7 @@                    (HsProtobuf.Named (HsProtobuf.Single "Nested")))                 (HsProtobuf.Single "nestedMessages")                 []-                Hs.Nothing)]+                "")]   instance HsJSONPB.ToJSONPB WithNestingRepeated where         toJSONPB (WithNestingRepeated f1)@@ -703,10 +713,6 @@                                                        [("nestedMessages",                                                          withNestingRepeatedNestedMessages)]}})  -instance HsDhallPb.Interpret WithNestingRepeated- -instance HsDhallPb.Inject WithNestingRepeated-  data WithNestingRepeated_Nested = WithNestingRepeated_Nested{withNestingRepeated_NestedNestedField1                                                              :: Hs.Text,                                                              withNestingRepeated_NestedNestedField2@@ -715,11 +721,13 @@                                                              :: Hs.Vector Hs.Int32,                                                              withNestingRepeated_NestedNestedUnpacked                                                              :: Hs.Vector Hs.Int32}-                                deriving (Hs.Show, Hs.Eq, Hs.Ord, Hs.Generic)+                                deriving (Hs.Show, Hs.Eq, Hs.Ord, Hs.Generic, Hs.NFData)   instance HsProtobuf.Named WithNestingRepeated_Nested where         nameOf _ = (Hs.fromString "WithNestingRepeated_Nested")  +instance HsProtobuf.HasDefault WithNestingRepeated_Nested+  instance HsProtobuf.Message WithNestingRepeated_Nested where         encodeMessage _           WithNestingRepeated_Nested{withNestingRepeated_NestedNestedField1 =@@ -736,9 +744,10 @@                 (HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 2)                    withNestingRepeated_NestedNestedField2),                 (HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 3)-                   (HsProtobuf.PackedVec withNestingRepeated_NestedNestedPacked)),+                   (Hs.coerce @(Hs.Vector Hs.Int32) @(HsProtobuf.PackedVec Hs.Int32)+                      withNestingRepeated_NestedNestedPacked)),                 (HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 4)-                   (HsProtobuf.UnpackedVec+                   (Hs.coerce @(Hs.Vector Hs.Int32) @(HsProtobuf.UnpackedVec Hs.Int32)                       withNestingRepeated_NestedNestedUnpacked))])         decodeMessage _           = (Hs.pure WithNestingRepeated_Nested) <*>@@ -748,11 +757,13 @@               (HsProtobuf.at HsProtobuf.decodeMessageField                  (HsProtobuf.FieldNumber 2))               <*>-              ((Hs.pure HsProtobuf.packedvec) <*>+              (Hs.coerce @(_ (HsProtobuf.PackedVec Hs.Int32))+                 @(_ (Hs.Vector Hs.Int32))                  (HsProtobuf.at HsProtobuf.decodeMessageField                     (HsProtobuf.FieldNumber 3)))               <*>-              ((Hs.pure HsProtobuf.unpackedvec) <*>+              (Hs.coerce @(_ (HsProtobuf.UnpackedVec Hs.Int32))+                 @(_ (Hs.Vector Hs.Int32))                  (HsProtobuf.at HsProtobuf.decodeMessageField                     (HsProtobuf.FieldNumber 4)))         dotProto _@@ -760,24 +771,24 @@                 (HsProtobuf.Prim HsProtobuf.String)                 (HsProtobuf.Single "nestedField1")                 []-                Hs.Nothing),+                ""),              (HsProtobuf.DotProtoField (HsProtobuf.FieldNumber 2)                 (HsProtobuf.Prim HsProtobuf.Int32)                 (HsProtobuf.Single "nestedField2")                 []-                Hs.Nothing),+                ""),              (HsProtobuf.DotProtoField (HsProtobuf.FieldNumber 3)                 (HsProtobuf.Repeated HsProtobuf.Int32)                 (HsProtobuf.Single "nestedPacked")                 [(HsProtobuf.DotProtoOption (HsProtobuf.Single "packed")                     (HsProtobuf.BoolLit Hs.True))]-                Hs.Nothing),+                ""),              (HsProtobuf.DotProtoField (HsProtobuf.FieldNumber 4)                 (HsProtobuf.Repeated HsProtobuf.Int32)                 (HsProtobuf.Single "nestedUnpacked")                 [(HsProtobuf.DotProtoOption (HsProtobuf.Single "packed")                     (HsProtobuf.BoolLit Hs.False))]-                Hs.Nothing)]+                "")]   instance HsJSONPB.ToJSONPB WithNestingRepeated_Nested where         toJSONPB (WithNestingRepeated_Nested f1 f2 f3 f4)@@ -842,17 +853,15 @@                                                         ("nestedUnpacked",                                                          withNestingRepeated_NestedNestedUnpacked)]}})  -instance HsDhallPb.Interpret WithNestingRepeated_Nested- -instance HsDhallPb.Inject WithNestingRepeated_Nested-  data NestedInts = NestedInts{nestedIntsNestedInt1 :: Hs.Int32,                              nestedIntsNestedInt2 :: Hs.Int32}-                deriving (Hs.Show, Hs.Eq, Hs.Ord, Hs.Generic)+                deriving (Hs.Show, Hs.Eq, Hs.Ord, Hs.Generic, Hs.NFData)   instance HsProtobuf.Named NestedInts where         nameOf _ = (Hs.fromString "NestedInts")  +instance HsProtobuf.HasDefault NestedInts+  instance HsProtobuf.Message NestedInts where         encodeMessage _           NestedInts{nestedIntsNestedInt1 = nestedIntsNestedInt1,@@ -874,12 +883,12 @@                 (HsProtobuf.Prim HsProtobuf.Int32)                 (HsProtobuf.Single "nestedInt1")                 []-                Hs.Nothing),+                ""),              (HsProtobuf.DotProtoField (HsProtobuf.FieldNumber 2)                 (HsProtobuf.Prim HsProtobuf.Int32)                 (HsProtobuf.Single "nestedInt2")                 []-                Hs.Nothing)]+                "")]   instance HsJSONPB.ToJSONPB NestedInts where         toJSONPB (NestedInts f1 f2)@@ -921,27 +930,28 @@                                                        [("nestedInt1", nestedIntsNestedInt1),                                                         ("nestedInt2", nestedIntsNestedInt2)]}})  -instance HsDhallPb.Interpret NestedInts- -instance HsDhallPb.Inject NestedInts-  data WithNestingRepeatedInts = WithNestingRepeatedInts{withNestingRepeatedIntsNestedInts                                                        :: Hs.Vector TestProto.NestedInts}-                             deriving (Hs.Show, Hs.Eq, Hs.Ord, Hs.Generic)+                             deriving (Hs.Show, Hs.Eq, Hs.Ord, Hs.Generic, Hs.NFData)   instance HsProtobuf.Named WithNestingRepeatedInts where         nameOf _ = (Hs.fromString "WithNestingRepeatedInts")  +instance HsProtobuf.HasDefault WithNestingRepeatedInts+  instance HsProtobuf.Message WithNestingRepeatedInts where         encodeMessage _           WithNestingRepeatedInts{withNestingRepeatedIntsNestedInts =                                     withNestingRepeatedIntsNestedInts}           = (Hs.mconcat                [(HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 1)-                   (HsProtobuf.NestedVec withNestingRepeatedIntsNestedInts))])+                   (Hs.coerce @(Hs.Vector TestProto.NestedInts)+                      @(HsProtobuf.NestedVec TestProto.NestedInts)+                      withNestingRepeatedIntsNestedInts))])         decodeMessage _           = (Hs.pure WithNestingRepeatedInts) <*>-              ((Hs.pure HsProtobuf.nestedvec) <*>+              (Hs.coerce @(_ (HsProtobuf.NestedVec TestProto.NestedInts))+                 @(_ (Hs.Vector TestProto.NestedInts))                  (HsProtobuf.at HsProtobuf.decodeMessageField                     (HsProtobuf.FieldNumber 1)))         dotProto _@@ -950,7 +960,7 @@                    (HsProtobuf.Named (HsProtobuf.Single "NestedInts")))                 (HsProtobuf.Single "nestedInts")                 []-                Hs.Nothing)]+                "")]   instance HsJSONPB.ToJSONPB WithNestingRepeatedInts where         toJSONPB (WithNestingRepeatedInts f1)@@ -989,27 +999,28 @@                                                        [("nestedInts",                                                          withNestingRepeatedIntsNestedInts)]}})  -instance HsDhallPb.Interpret WithNestingRepeatedInts- -instance HsDhallPb.Inject WithNestingRepeatedInts-  data WithNestingInts = WithNestingInts{withNestingIntsNestedInts ::                                        Hs.Maybe TestProto.NestedInts}-                     deriving (Hs.Show, Hs.Eq, Hs.Ord, Hs.Generic)+                     deriving (Hs.Show, Hs.Eq, Hs.Ord, Hs.Generic, Hs.NFData)   instance HsProtobuf.Named WithNestingInts where         nameOf _ = (Hs.fromString "WithNestingInts")  +instance HsProtobuf.HasDefault WithNestingInts+  instance HsProtobuf.Message WithNestingInts where         encodeMessage _           WithNestingInts{withNestingIntsNestedInts =                             withNestingIntsNestedInts}           = (Hs.mconcat                [(HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 1)-                   (HsProtobuf.Nested withNestingIntsNestedInts))])+                   (Hs.coerce @(Hs.Maybe TestProto.NestedInts)+                      @(HsProtobuf.Nested TestProto.NestedInts)+                      withNestingIntsNestedInts))])         decodeMessage _           = (Hs.pure WithNestingInts) <*>-              ((Hs.pure HsProtobuf.nested) <*>+              (Hs.coerce @(_ (HsProtobuf.Nested TestProto.NestedInts))+                 @(_ (Hs.Maybe TestProto.NestedInts))                  (HsProtobuf.at HsProtobuf.decodeMessageField                     (HsProtobuf.FieldNumber 1)))         dotProto _@@ -1018,7 +1029,7 @@                    (HsProtobuf.Named (HsProtobuf.Single "NestedInts")))                 (HsProtobuf.Single "nestedInts")                 []-                Hs.Nothing)]+                "")]   instance HsJSONPB.ToJSONPB WithNestingInts where         toJSONPB (WithNestingInts f1)@@ -1056,27 +1067,27 @@                                                        [("nestedInts",                                                          withNestingIntsNestedInts)]}})  -instance HsDhallPb.Interpret WithNestingInts- -instance HsDhallPb.Inject WithNestingInts-  data WithRepetition = WithRepetition{withRepetitionRepeatedField1                                      :: Hs.Vector Hs.Int32}-                    deriving (Hs.Show, Hs.Eq, Hs.Ord, Hs.Generic)+                    deriving (Hs.Show, Hs.Eq, Hs.Ord, Hs.Generic, Hs.NFData)   instance HsProtobuf.Named WithRepetition where         nameOf _ = (Hs.fromString "WithRepetition")  +instance HsProtobuf.HasDefault WithRepetition+  instance HsProtobuf.Message WithRepetition where         encodeMessage _           WithRepetition{withRepetitionRepeatedField1 =                            withRepetitionRepeatedField1}           = (Hs.mconcat                [(HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 1)-                   (HsProtobuf.PackedVec withRepetitionRepeatedField1))])+                   (Hs.coerce @(Hs.Vector Hs.Int32) @(HsProtobuf.PackedVec Hs.Int32)+                      withRepetitionRepeatedField1))])         decodeMessage _           = (Hs.pure WithRepetition) <*>-              ((Hs.pure HsProtobuf.packedvec) <*>+              (Hs.coerce @(_ (HsProtobuf.PackedVec Hs.Int32))+                 @(_ (Hs.Vector Hs.Int32))                  (HsProtobuf.at HsProtobuf.decodeMessageField                     (HsProtobuf.FieldNumber 1)))         dotProto _@@ -1084,7 +1095,7 @@                 (HsProtobuf.Repeated HsProtobuf.Int32)                 (HsProtobuf.Single "repeatedField1")                 []-                Hs.Nothing)]+                "")]   instance HsJSONPB.ToJSONPB WithRepetition where         toJSONPB (WithRepetition f1)@@ -1122,20 +1133,16 @@                                                        [("repeatedField1",                                                          withRepetitionRepeatedField1)]}})  -instance HsDhallPb.Interpret WithRepetition- -instance HsDhallPb.Inject WithRepetition- -data WithFixed = WithFixed{withFixedFixed1 ::-                           HsProtobuf.Fixed Hs.Word32,-                           withFixedFixed2 :: HsProtobuf.Fixed Hs.Int32,-                           withFixedFixed3 :: HsProtobuf.Fixed Hs.Word64,-                           withFixedFixed4 :: HsProtobuf.Fixed Hs.Int64}-               deriving (Hs.Show, Hs.Eq, Hs.Ord, Hs.Generic)+data WithFixed = WithFixed{withFixedFixed1 :: Hs.Word32,+                           withFixedFixed2 :: Hs.Int32, withFixedFixed3 :: Hs.Word64,+                           withFixedFixed4 :: Hs.Int64}+               deriving (Hs.Show, Hs.Eq, Hs.Ord, Hs.Generic, Hs.NFData)   instance HsProtobuf.Named WithFixed where         nameOf _ = (Hs.fromString "WithFixed")  +instance HsProtobuf.HasDefault WithFixed+  instance HsProtobuf.Message WithFixed where         encodeMessage _           WithFixed{withFixedFixed1 = withFixedFixed1,@@ -1144,26 +1151,36 @@                     withFixedFixed4 = withFixedFixed4}           = (Hs.mconcat                [(HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 1)-                   withFixedFixed1),+                   (Hs.coerce @(Hs.Word32) @(HsProtobuf.Fixed Hs.Word32)+                      withFixedFixed1)),                 (HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 2)-                   (HsProtobuf.Signed withFixedFixed2)),+                   (Hs.coerce @(Hs.Int32)+                      @(HsProtobuf.Signed (HsProtobuf.Fixed Hs.Int32))+                      withFixedFixed2)),                 (HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 3)-                   withFixedFixed3),+                   (Hs.coerce @(Hs.Word64) @(HsProtobuf.Fixed Hs.Word64)+                      withFixedFixed3)),                 (HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 4)-                   (HsProtobuf.Signed withFixedFixed4))])+                   (Hs.coerce @(Hs.Int64)+                      @(HsProtobuf.Signed (HsProtobuf.Fixed Hs.Int64))+                      withFixedFixed4))])         decodeMessage _           = (Hs.pure WithFixed) <*>-              (HsProtobuf.at HsProtobuf.decodeMessageField-                 (HsProtobuf.FieldNumber 1))+              (Hs.coerce @(_ (HsProtobuf.Fixed Hs.Word32)) @(_ Hs.Word32)+                 (HsProtobuf.at HsProtobuf.decodeMessageField+                    (HsProtobuf.FieldNumber 1)))               <*>-              ((Hs.pure HsProtobuf.signed) <*>+              (Hs.coerce @(_ (HsProtobuf.Signed (HsProtobuf.Fixed Hs.Int32)))+                 @(_ Hs.Int32)                  (HsProtobuf.at HsProtobuf.decodeMessageField                     (HsProtobuf.FieldNumber 2)))               <*>-              (HsProtobuf.at HsProtobuf.decodeMessageField-                 (HsProtobuf.FieldNumber 3))+              (Hs.coerce @(_ (HsProtobuf.Fixed Hs.Word64)) @(_ Hs.Word64)+                 (HsProtobuf.at HsProtobuf.decodeMessageField+                    (HsProtobuf.FieldNumber 3)))               <*>-              ((Hs.pure HsProtobuf.signed) <*>+              (Hs.coerce @(_ (HsProtobuf.Signed (HsProtobuf.Fixed Hs.Int64)))+                 @(_ Hs.Int64)                  (HsProtobuf.at HsProtobuf.decodeMessageField                     (HsProtobuf.FieldNumber 4)))         dotProto _@@ -1171,22 +1188,22 @@                 (HsProtobuf.Prim HsProtobuf.Fixed32)                 (HsProtobuf.Single "fixed1")                 []-                Hs.Nothing),+                ""),              (HsProtobuf.DotProtoField (HsProtobuf.FieldNumber 2)                 (HsProtobuf.Prim HsProtobuf.SFixed32)                 (HsProtobuf.Single "fixed2")                 []-                Hs.Nothing),+                ""),              (HsProtobuf.DotProtoField (HsProtobuf.FieldNumber 3)                 (HsProtobuf.Prim HsProtobuf.Fixed64)                 (HsProtobuf.Single "fixed3")                 []-                Hs.Nothing),+                ""),              (HsProtobuf.DotProtoField (HsProtobuf.FieldNumber 4)                 (HsProtobuf.Prim HsProtobuf.SFixed64)                 (HsProtobuf.Single "fixed4")                 []-                Hs.Nothing)]+                "")]   instance HsJSONPB.ToJSONPB WithFixed where         toJSONPB (WithFixed f1 f2 f3 f4)@@ -1239,17 +1256,15 @@                                                         ("fixed3", withFixedFixed3),                                                         ("fixed4", withFixedFixed4)]}})  -instance HsDhallPb.Interpret WithFixed- -instance HsDhallPb.Inject WithFixed-  data WithBytes = WithBytes{withBytesBytes1 :: Hs.ByteString,                            withBytesBytes2 :: Hs.Vector Hs.ByteString}-               deriving (Hs.Show, Hs.Eq, Hs.Ord, Hs.Generic)+               deriving (Hs.Show, Hs.Eq, Hs.Ord, Hs.Generic, Hs.NFData)   instance HsProtobuf.Named WithBytes where         nameOf _ = (Hs.fromString "WithBytes")  +instance HsProtobuf.HasDefault WithBytes+  instance HsProtobuf.Message WithBytes where         encodeMessage _           WithBytes{withBytesBytes1 = withBytesBytes1,@@ -1258,13 +1273,16 @@                [(HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 1)                    withBytesBytes1),                 (HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 2)-                   (HsProtobuf.UnpackedVec withBytesBytes2))])+                   (Hs.coerce @(Hs.Vector Hs.ByteString)+                      @(HsProtobuf.UnpackedVec Hs.ByteString)+                      withBytesBytes2))])         decodeMessage _           = (Hs.pure WithBytes) <*>               (HsProtobuf.at HsProtobuf.decodeMessageField                  (HsProtobuf.FieldNumber 1))               <*>-              ((Hs.pure HsProtobuf.unpackedvec) <*>+              (Hs.coerce @(_ (HsProtobuf.UnpackedVec Hs.ByteString))+                 @(_ (Hs.Vector Hs.ByteString))                  (HsProtobuf.at HsProtobuf.decodeMessageField                     (HsProtobuf.FieldNumber 2)))         dotProto _@@ -1272,12 +1290,12 @@                 (HsProtobuf.Prim HsProtobuf.Bytes)                 (HsProtobuf.Single "bytes1")                 []-                Hs.Nothing),+                ""),              (HsProtobuf.DotProtoField (HsProtobuf.FieldNumber 2)                 (HsProtobuf.Repeated HsProtobuf.Bytes)                 (HsProtobuf.Single "bytes2")                 []-                Hs.Nothing)]+                "")]   instance HsJSONPB.ToJSONPB WithBytes where         toJSONPB (WithBytes f1 f2)@@ -1318,34 +1336,36 @@                                                        [("bytes1", withBytesBytes1),                                                         ("bytes2", withBytesBytes2)]}})  -instance HsDhallPb.Interpret WithBytes- -instance HsDhallPb.Inject WithBytes-  data WithPacking = WithPacking{withPackingPacking1 ::                                Hs.Vector Hs.Int32,                                withPackingPacking2 :: Hs.Vector Hs.Int32}-                 deriving (Hs.Show, Hs.Eq, Hs.Ord, Hs.Generic)+                 deriving (Hs.Show, Hs.Eq, Hs.Ord, Hs.Generic, Hs.NFData)   instance HsProtobuf.Named WithPacking where         nameOf _ = (Hs.fromString "WithPacking")  +instance HsProtobuf.HasDefault WithPacking+  instance HsProtobuf.Message WithPacking where         encodeMessage _           WithPacking{withPackingPacking1 = withPackingPacking1,                       withPackingPacking2 = withPackingPacking2}           = (Hs.mconcat                [(HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 1)-                   (HsProtobuf.UnpackedVec withPackingPacking1)),+                   (Hs.coerce @(Hs.Vector Hs.Int32) @(HsProtobuf.UnpackedVec Hs.Int32)+                      withPackingPacking1)),                 (HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 2)-                   (HsProtobuf.PackedVec withPackingPacking2))])+                   (Hs.coerce @(Hs.Vector Hs.Int32) @(HsProtobuf.PackedVec Hs.Int32)+                      withPackingPacking2))])         decodeMessage _           = (Hs.pure WithPacking) <*>-              ((Hs.pure HsProtobuf.unpackedvec) <*>+              (Hs.coerce @(_ (HsProtobuf.UnpackedVec Hs.Int32))+                 @(_ (Hs.Vector Hs.Int32))                  (HsProtobuf.at HsProtobuf.decodeMessageField                     (HsProtobuf.FieldNumber 1)))               <*>-              ((Hs.pure HsProtobuf.packedvec) <*>+              (Hs.coerce @(_ (HsProtobuf.PackedVec Hs.Int32))+                 @(_ (Hs.Vector Hs.Int32))                  (HsProtobuf.at HsProtobuf.decodeMessageField                     (HsProtobuf.FieldNumber 2)))         dotProto _@@ -1354,13 +1374,13 @@                 (HsProtobuf.Single "packing1")                 [(HsProtobuf.DotProtoOption (HsProtobuf.Single "packed")                     (HsProtobuf.BoolLit Hs.False))]-                Hs.Nothing),+                ""),              (HsProtobuf.DotProtoField (HsProtobuf.FieldNumber 2)                 (HsProtobuf.Repeated HsProtobuf.Int32)                 (HsProtobuf.Single "packing2")                 [(HsProtobuf.DotProtoOption (HsProtobuf.Single "packed")                     (HsProtobuf.BoolLit Hs.True))]-                Hs.Nothing)]+                "")]   instance HsJSONPB.ToJSONPB WithPacking where         toJSONPB (WithPacking f1 f2)@@ -1401,28 +1421,31 @@                                                        [("packing1", withPackingPacking1),                                                         ("packing2", withPackingPacking2)]}})  -instance HsDhallPb.Interpret WithPacking- -instance HsDhallPb.Inject WithPacking-  data E = EFLD0        | EFLD1-       deriving (Hs.Show, Hs.Bounded, Hs.Eq, Hs.Ord, Hs.Generic)+       deriving (Hs.Show, Hs.Eq, Hs.Generic, Hs.NFData)   instance HsProtobuf.Named E where         nameOf _ = (Hs.fromString "E")  -instance Hs.Enum E where-        toEnum 0 = EFLD0-        toEnum 1 = EFLD1-        toEnum i = (Hs.toEnumError "E" i (0 :: Hs.Int, 1))-        fromEnum (EFLD0) = 0-        fromEnum (EFLD1) = 1-        succ (EFLD0) = EFLD1-        succ _ = Hs.succError "E"-        pred (EFLD1) = EFLD0-        pred _ = Hs.predError "E"+instance HsProtobuf.HasDefault E  +instance Hs.Bounded E where+        minBound = EFLD0+        maxBound = EFLD1+ +instance Hs.Ord E where+        compare x y+          = Hs.compare (HsProtobuf.fromProtoEnum x)+              (HsProtobuf.fromProtoEnum y)+ +instance HsProtobuf.ProtoEnum E where+        toProtoEnumMay 0 = Hs.Just EFLD0+        toProtoEnumMay 1 = Hs.Just EFLD1+        toProtoEnumMay _ = Hs.Nothing+        fromProtoEnum (EFLD0) = 0+        fromProtoEnum (EFLD1) = 1+  instance HsJSONPB.ToJSONPB E where         toJSONPB x _ = HsJSONPB.enumFieldString x         toEncodingPB x _ = HsJSONPB.enumFieldEncoding x@@ -1439,10 +1462,6 @@ instance HsJSONPB.FromJSON E where         parseJSON = HsJSONPB.parseJSONPB  -instance HsDhallPb.Interpret E- -instance HsDhallPb.Inject E-  instance HsProtobuf.Finite E   data AllPackedTypes = AllPackedTypes{allPackedTypesPackedWord32 ::@@ -1450,26 +1469,24 @@                                      allPackedTypesPackedWord64 :: Hs.Vector Hs.Word64,                                      allPackedTypesPackedInt32 :: Hs.Vector Hs.Int32,                                      allPackedTypesPackedInt64 :: Hs.Vector Hs.Int64,-                                     allPackedTypesPackedFixed32 ::-                                     Hs.Vector (HsProtobuf.Fixed Hs.Word32),-                                     allPackedTypesPackedFixed64 ::-                                     Hs.Vector (HsProtobuf.Fixed Hs.Word64),+                                     allPackedTypesPackedFixed32 :: Hs.Vector Hs.Word32,+                                     allPackedTypesPackedFixed64 :: Hs.Vector Hs.Word64,                                      allPackedTypesPackedFloat :: Hs.Vector Hs.Float,                                      allPackedTypesPackedDouble :: Hs.Vector Hs.Double,-                                     allPackedTypesPackedSFixed32 ::-                                     Hs.Vector (HsProtobuf.Fixed Hs.Int32),-                                     allPackedTypesPackedSFixed64 ::-                                     Hs.Vector (HsProtobuf.Fixed Hs.Int64),+                                     allPackedTypesPackedSFixed32 :: Hs.Vector Hs.Int32,+                                     allPackedTypesPackedSFixed64 :: Hs.Vector Hs.Int64,                                      allPackedTypesPackedBool :: Hs.Vector Hs.Bool,                                      allPackedTypesPackedEnum ::                                      Hs.Vector (HsProtobuf.Enumerated TestProto.E),                                      allPackedTypesUnpackedEnum ::                                      Hs.Vector (HsProtobuf.Enumerated TestProto.E)}-                    deriving (Hs.Show, Hs.Eq, Hs.Ord, Hs.Generic)+                    deriving (Hs.Show, Hs.Eq, Hs.Ord, Hs.Generic, Hs.NFData)   instance HsProtobuf.Named AllPackedTypes where         nameOf _ = (Hs.fromString "AllPackedTypes")  +instance HsProtobuf.HasDefault AllPackedTypes+  instance HsProtobuf.Message AllPackedTypes where         encodeMessage _           AllPackedTypes{allPackedTypesPackedWord32 =@@ -1488,86 +1505,118 @@                          allPackedTypesUnpackedEnum = allPackedTypesUnpackedEnum}           = (Hs.mconcat                [(HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 1)-                   (HsProtobuf.PackedVec allPackedTypesPackedWord32)),+                   (Hs.coerce @(Hs.Vector Hs.Word32) @(HsProtobuf.PackedVec Hs.Word32)+                      allPackedTypesPackedWord32)),                 (HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 2)-                   (HsProtobuf.PackedVec allPackedTypesPackedWord64)),+                   (Hs.coerce @(Hs.Vector Hs.Word64) @(HsProtobuf.PackedVec Hs.Word64)+                      allPackedTypesPackedWord64)),                 (HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 3)-                   (HsProtobuf.PackedVec allPackedTypesPackedInt32)),+                   (Hs.coerce @(Hs.Vector Hs.Int32) @(HsProtobuf.PackedVec Hs.Int32)+                      allPackedTypesPackedInt32)),                 (HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 4)-                   (HsProtobuf.PackedVec allPackedTypesPackedInt64)),+                   (Hs.coerce @(Hs.Vector Hs.Int64) @(HsProtobuf.PackedVec Hs.Int64)+                      allPackedTypesPackedInt64)),                 (HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 5)-                   (HsProtobuf.PackedVec allPackedTypesPackedFixed32)),+                   (Hs.coerce @(Hs.Vector Hs.Word32)+                      @(HsProtobuf.PackedVec (HsProtobuf.Fixed Hs.Word32))+                      allPackedTypesPackedFixed32)),                 (HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 6)-                   (HsProtobuf.PackedVec allPackedTypesPackedFixed64)),+                   (Hs.coerce @(Hs.Vector Hs.Word64)+                      @(HsProtobuf.PackedVec (HsProtobuf.Fixed Hs.Word64))+                      allPackedTypesPackedFixed64)),                 (HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 7)-                   (HsProtobuf.PackedVec allPackedTypesPackedFloat)),+                   (Hs.coerce @(Hs.Vector Hs.Float) @(HsProtobuf.PackedVec Hs.Float)+                      allPackedTypesPackedFloat)),                 (HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 8)-                   (HsProtobuf.PackedVec allPackedTypesPackedDouble)),+                   (Hs.coerce @(Hs.Vector Hs.Double) @(HsProtobuf.PackedVec Hs.Double)+                      allPackedTypesPackedDouble)),                 (HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 9)-                   (HsProtobuf.PackedVec-                      (Hs.fmap HsProtobuf.Signed allPackedTypesPackedSFixed32))),+                   (Hs.coerce @(Hs.Vector Hs.Int32)+                      @(HsProtobuf.PackedVec (HsProtobuf.Signed (HsProtobuf.Fixed Hs.Int32)))+                      allPackedTypesPackedSFixed32)),                 (HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 10)-                   (HsProtobuf.PackedVec-                      (Hs.fmap HsProtobuf.Signed allPackedTypesPackedSFixed64))),+                   (Hs.coerce @(Hs.Vector Hs.Int64)+                      @(HsProtobuf.PackedVec (HsProtobuf.Signed (HsProtobuf.Fixed Hs.Int64)))+                      allPackedTypesPackedSFixed64)),                 (HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 11)-                   (HsProtobuf.PackedVec allPackedTypesPackedBool)),+                   (Hs.coerce @(Hs.Vector Hs.Bool) @(HsProtobuf.PackedVec Hs.Bool)+                      allPackedTypesPackedBool)),                 (HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 12)-                   (HsProtobuf.PackedVec allPackedTypesPackedEnum)),+                   (Hs.coerce @(Hs.Vector (HsProtobuf.Enumerated TestProto.E))+                      @(HsProtobuf.PackedVec (HsProtobuf.Enumerated TestProto.E))+                      allPackedTypesPackedEnum)),                 (HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 13)-                   (HsProtobuf.UnpackedVec allPackedTypesUnpackedEnum))])+                   (Hs.coerce @(Hs.Vector (HsProtobuf.Enumerated TestProto.E))+                      @(HsProtobuf.UnpackedVec (HsProtobuf.Enumerated TestProto.E))+                      allPackedTypesUnpackedEnum))])         decodeMessage _           = (Hs.pure AllPackedTypes) <*>-              ((Hs.pure HsProtobuf.packedvec) <*>+              (Hs.coerce @(_ (HsProtobuf.PackedVec Hs.Word32))+                 @(_ (Hs.Vector Hs.Word32))                  (HsProtobuf.at HsProtobuf.decodeMessageField                     (HsProtobuf.FieldNumber 1)))               <*>-              ((Hs.pure HsProtobuf.packedvec) <*>+              (Hs.coerce @(_ (HsProtobuf.PackedVec Hs.Word64))+                 @(_ (Hs.Vector Hs.Word64))                  (HsProtobuf.at HsProtobuf.decodeMessageField                     (HsProtobuf.FieldNumber 2)))               <*>-              ((Hs.pure HsProtobuf.packedvec) <*>+              (Hs.coerce @(_ (HsProtobuf.PackedVec Hs.Int32))+                 @(_ (Hs.Vector Hs.Int32))                  (HsProtobuf.at HsProtobuf.decodeMessageField                     (HsProtobuf.FieldNumber 3)))               <*>-              ((Hs.pure HsProtobuf.packedvec) <*>+              (Hs.coerce @(_ (HsProtobuf.PackedVec Hs.Int64))+                 @(_ (Hs.Vector Hs.Int64))                  (HsProtobuf.at HsProtobuf.decodeMessageField                     (HsProtobuf.FieldNumber 4)))               <*>-              ((Hs.pure HsProtobuf.packedvec) <*>+              (Hs.coerce @(_ (HsProtobuf.PackedVec (HsProtobuf.Fixed Hs.Word32)))+                 @(_ (Hs.Vector Hs.Word32))                  (HsProtobuf.at HsProtobuf.decodeMessageField                     (HsProtobuf.FieldNumber 5)))               <*>-              ((Hs.pure HsProtobuf.packedvec) <*>+              (Hs.coerce @(_ (HsProtobuf.PackedVec (HsProtobuf.Fixed Hs.Word64)))+                 @(_ (Hs.Vector Hs.Word64))                  (HsProtobuf.at HsProtobuf.decodeMessageField                     (HsProtobuf.FieldNumber 6)))               <*>-              ((Hs.pure HsProtobuf.packedvec) <*>+              (Hs.coerce @(_ (HsProtobuf.PackedVec Hs.Float))+                 @(_ (Hs.Vector Hs.Float))                  (HsProtobuf.at HsProtobuf.decodeMessageField                     (HsProtobuf.FieldNumber 7)))               <*>-              ((Hs.pure HsProtobuf.packedvec) <*>+              (Hs.coerce @(_ (HsProtobuf.PackedVec Hs.Double))+                 @(_ (Hs.Vector Hs.Double))                  (HsProtobuf.at HsProtobuf.decodeMessageField                     (HsProtobuf.FieldNumber 8)))               <*>-              ((Hs.pure (Hs.fmap HsProtobuf.signed)) <*>-                 ((Hs.pure HsProtobuf.packedvec) <*>-                    (HsProtobuf.at HsProtobuf.decodeMessageField-                       (HsProtobuf.FieldNumber 9))))+              (Hs.coerce+                 @(_ (HsProtobuf.PackedVec (HsProtobuf.Signed (HsProtobuf.Fixed Hs.Int32))))+                 @(_ (Hs.Vector Hs.Int32))+                 (HsProtobuf.at HsProtobuf.decodeMessageField+                    (HsProtobuf.FieldNumber 9)))               <*>-              ((Hs.pure (Hs.fmap HsProtobuf.signed)) <*>-                 ((Hs.pure HsProtobuf.packedvec) <*>-                    (HsProtobuf.at HsProtobuf.decodeMessageField-                       (HsProtobuf.FieldNumber 10))))+              (Hs.coerce+                 @(_ (HsProtobuf.PackedVec (HsProtobuf.Signed (HsProtobuf.Fixed Hs.Int64))))+                 @(_ (Hs.Vector Hs.Int64))+                 (HsProtobuf.at HsProtobuf.decodeMessageField+                    (HsProtobuf.FieldNumber 10)))               <*>-              ((Hs.pure HsProtobuf.packedvec) <*>+              (Hs.coerce @(_ (HsProtobuf.PackedVec Hs.Bool))+                 @(_ (Hs.Vector Hs.Bool))                  (HsProtobuf.at HsProtobuf.decodeMessageField                     (HsProtobuf.FieldNumber 11)))               <*>-              ((Hs.pure HsProtobuf.packedvec) <*>+              (Hs.coerce+                 @(_ (HsProtobuf.PackedVec (HsProtobuf.Enumerated TestProto.E)))+                 @(_ (Hs.Vector (HsProtobuf.Enumerated TestProto.E)))                  (HsProtobuf.at HsProtobuf.decodeMessageField                     (HsProtobuf.FieldNumber 12)))               <*>-              ((Hs.pure HsProtobuf.unpackedvec) <*>+              (Hs.coerce+                 @(_ (HsProtobuf.UnpackedVec (HsProtobuf.Enumerated TestProto.E)))+                 @(_ (Hs.Vector (HsProtobuf.Enumerated TestProto.E)))                  (HsProtobuf.at HsProtobuf.decodeMessageField                     (HsProtobuf.FieldNumber 13)))         dotProto _@@ -1576,79 +1625,79 @@                 (HsProtobuf.Single "packedWord32")                 [(HsProtobuf.DotProtoOption (HsProtobuf.Single "packed")                     (HsProtobuf.BoolLit Hs.True))]-                Hs.Nothing),+                ""),              (HsProtobuf.DotProtoField (HsProtobuf.FieldNumber 2)                 (HsProtobuf.Repeated HsProtobuf.UInt64)                 (HsProtobuf.Single "packedWord64")                 [(HsProtobuf.DotProtoOption (HsProtobuf.Single "packed")                     (HsProtobuf.BoolLit Hs.True))]-                Hs.Nothing),+                ""),              (HsProtobuf.DotProtoField (HsProtobuf.FieldNumber 3)                 (HsProtobuf.Repeated HsProtobuf.Int32)                 (HsProtobuf.Single "packedInt32")                 [(HsProtobuf.DotProtoOption (HsProtobuf.Single "packed")                     (HsProtobuf.BoolLit Hs.True))]-                Hs.Nothing),+                ""),              (HsProtobuf.DotProtoField (HsProtobuf.FieldNumber 4)                 (HsProtobuf.Repeated HsProtobuf.Int64)                 (HsProtobuf.Single "packedInt64")                 [(HsProtobuf.DotProtoOption (HsProtobuf.Single "packed")                     (HsProtobuf.BoolLit Hs.True))]-                Hs.Nothing),+                ""),              (HsProtobuf.DotProtoField (HsProtobuf.FieldNumber 5)                 (HsProtobuf.Repeated HsProtobuf.Fixed32)                 (HsProtobuf.Single "packedFixed32")                 [(HsProtobuf.DotProtoOption (HsProtobuf.Single "packed")                     (HsProtobuf.BoolLit Hs.True))]-                Hs.Nothing),+                ""),              (HsProtobuf.DotProtoField (HsProtobuf.FieldNumber 6)                 (HsProtobuf.Repeated HsProtobuf.Fixed64)                 (HsProtobuf.Single "packedFixed64")                 [(HsProtobuf.DotProtoOption (HsProtobuf.Single "packed")                     (HsProtobuf.BoolLit Hs.True))]-                Hs.Nothing),+                ""),              (HsProtobuf.DotProtoField (HsProtobuf.FieldNumber 7)                 (HsProtobuf.Repeated HsProtobuf.Float)                 (HsProtobuf.Single "packedFloat")                 [(HsProtobuf.DotProtoOption (HsProtobuf.Single "packed")                     (HsProtobuf.BoolLit Hs.True))]-                Hs.Nothing),+                ""),              (HsProtobuf.DotProtoField (HsProtobuf.FieldNumber 8)                 (HsProtobuf.Repeated HsProtobuf.Double)                 (HsProtobuf.Single "packedDouble")                 [(HsProtobuf.DotProtoOption (HsProtobuf.Single "packed")                     (HsProtobuf.BoolLit Hs.True))]-                Hs.Nothing),+                ""),              (HsProtobuf.DotProtoField (HsProtobuf.FieldNumber 9)                 (HsProtobuf.Repeated HsProtobuf.SFixed32)                 (HsProtobuf.Single "packedSFixed32")                 [(HsProtobuf.DotProtoOption (HsProtobuf.Single "packed")                     (HsProtobuf.BoolLit Hs.True))]-                Hs.Nothing),+                ""),              (HsProtobuf.DotProtoField (HsProtobuf.FieldNumber 10)                 (HsProtobuf.Repeated HsProtobuf.SFixed64)                 (HsProtobuf.Single "packedSFixed64")                 [(HsProtobuf.DotProtoOption (HsProtobuf.Single "packed")                     (HsProtobuf.BoolLit Hs.True))]-                Hs.Nothing),+                ""),              (HsProtobuf.DotProtoField (HsProtobuf.FieldNumber 11)                 (HsProtobuf.Repeated HsProtobuf.Bool)                 (HsProtobuf.Single "packedBool")                 [(HsProtobuf.DotProtoOption (HsProtobuf.Single "packed")                     (HsProtobuf.BoolLit Hs.True))]-                Hs.Nothing),+                ""),              (HsProtobuf.DotProtoField (HsProtobuf.FieldNumber 12)                 (HsProtobuf.Repeated (HsProtobuf.Named (HsProtobuf.Single "E")))                 (HsProtobuf.Single "packedEnum")                 [(HsProtobuf.DotProtoOption (HsProtobuf.Single "packed")                     (HsProtobuf.BoolLit Hs.True))]-                Hs.Nothing),+                ""),              (HsProtobuf.DotProtoField (HsProtobuf.FieldNumber 13)                 (HsProtobuf.Repeated (HsProtobuf.Named (HsProtobuf.Single "E")))                 (HsProtobuf.Single "unpackedEnum")                 [(HsProtobuf.DotProtoOption (HsProtobuf.Single "packed")                     (HsProtobuf.BoolLit Hs.False))]-                Hs.Nothing)]+                "")]   instance HsJSONPB.ToJSONPB AllPackedTypes where         toJSONPB@@ -1766,20 +1815,18 @@                                                         ("unpackedEnum",                                                          allPackedTypesUnpackedEnum)]}})  -instance HsDhallPb.Interpret AllPackedTypes- -instance HsDhallPb.Inject AllPackedTypes-  data OutOfOrderFields = OutOfOrderFields{outOfOrderFieldsField1 ::                                          Hs.Vector Hs.Word32,                                          outOfOrderFieldsField2 :: Hs.Text,                                          outOfOrderFieldsField3 :: Hs.Int64,                                          outOfOrderFieldsField4 :: Hs.Vector Hs.Text}-                      deriving (Hs.Show, Hs.Eq, Hs.Ord, Hs.Generic)+                      deriving (Hs.Show, Hs.Eq, Hs.Ord, Hs.Generic, Hs.NFData)   instance HsProtobuf.Named OutOfOrderFields where         nameOf _ = (Hs.fromString "OutOfOrderFields")  +instance HsProtobuf.HasDefault OutOfOrderFields+  instance HsProtobuf.Message OutOfOrderFields where         encodeMessage _           OutOfOrderFields{outOfOrderFieldsField1 = outOfOrderFieldsField1,@@ -1788,16 +1835,19 @@                            outOfOrderFieldsField4 = outOfOrderFieldsField4}           = (Hs.mconcat                [(HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 2001)-                   (HsProtobuf.PackedVec outOfOrderFieldsField1)),+                   (Hs.coerce @(Hs.Vector Hs.Word32) @(HsProtobuf.PackedVec Hs.Word32)+                      outOfOrderFieldsField1)),                 (HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 101)                    outOfOrderFieldsField2),                 (HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 30)                    outOfOrderFieldsField3),                 (HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 1002)-                   (HsProtobuf.UnpackedVec outOfOrderFieldsField4))])+                   (Hs.coerce @(Hs.Vector Hs.Text) @(HsProtobuf.UnpackedVec Hs.Text)+                      outOfOrderFieldsField4))])         decodeMessage _           = (Hs.pure OutOfOrderFields) <*>-              ((Hs.pure HsProtobuf.packedvec) <*>+              (Hs.coerce @(_ (HsProtobuf.PackedVec Hs.Word32))+                 @(_ (Hs.Vector Hs.Word32))                  (HsProtobuf.at HsProtobuf.decodeMessageField                     (HsProtobuf.FieldNumber 2001)))               <*>@@ -1807,7 +1857,8 @@               (HsProtobuf.at HsProtobuf.decodeMessageField                  (HsProtobuf.FieldNumber 30))               <*>-              ((Hs.pure HsProtobuf.unpackedvec) <*>+              (Hs.coerce @(_ (HsProtobuf.UnpackedVec Hs.Text))+                 @(_ (Hs.Vector Hs.Text))                  (HsProtobuf.at HsProtobuf.decodeMessageField                     (HsProtobuf.FieldNumber 1002)))         dotProto _@@ -1816,22 +1867,22 @@                 (HsProtobuf.Single "field1")                 [(HsProtobuf.DotProtoOption (HsProtobuf.Single "packed")                     (HsProtobuf.BoolLit Hs.True))]-                Hs.Nothing),+                ""),              (HsProtobuf.DotProtoField (HsProtobuf.FieldNumber 101)                 (HsProtobuf.Prim HsProtobuf.String)                 (HsProtobuf.Single "field2")                 []-                Hs.Nothing),+                ""),              (HsProtobuf.DotProtoField (HsProtobuf.FieldNumber 30)                 (HsProtobuf.Prim HsProtobuf.Int64)                 (HsProtobuf.Single "field3")                 []-                Hs.Nothing),+                ""),              (HsProtobuf.DotProtoField (HsProtobuf.FieldNumber 1002)                 (HsProtobuf.Repeated HsProtobuf.String)                 (HsProtobuf.Single "field4")                 []-                Hs.Nothing)]+                "")]   instance HsJSONPB.ToJSONPB OutOfOrderFields where         toJSONPB (OutOfOrderFields f2001 f101 f30 f1002)@@ -1887,18 +1938,16 @@                                                         ("field3", outOfOrderFieldsField3),                                                         ("field4", outOfOrderFieldsField4)]}})  -instance HsDhallPb.Interpret OutOfOrderFields- -instance HsDhallPb.Inject OutOfOrderFields-  data ShadowedMessage = ShadowedMessage{shadowedMessageName ::                                        Hs.Text,                                        shadowedMessageValue :: Hs.Int32}-                     deriving (Hs.Show, Hs.Eq, Hs.Ord, Hs.Generic)+                     deriving (Hs.Show, Hs.Eq, Hs.Ord, Hs.Generic, Hs.NFData)   instance HsProtobuf.Named ShadowedMessage where         nameOf _ = (Hs.fromString "ShadowedMessage")  +instance HsProtobuf.HasDefault ShadowedMessage+  instance HsProtobuf.Message ShadowedMessage where         encodeMessage _           ShadowedMessage{shadowedMessageName = shadowedMessageName,@@ -1920,12 +1969,12 @@                 (HsProtobuf.Prim HsProtobuf.String)                 (HsProtobuf.Single "name")                 []-                Hs.Nothing),+                ""),              (HsProtobuf.DotProtoField (HsProtobuf.FieldNumber 1)                 (HsProtobuf.Prim HsProtobuf.Int32)                 (HsProtobuf.Single "value")                 []-                Hs.Nothing)]+                "")]   instance HsJSONPB.ToJSONPB ShadowedMessage where         toJSONPB (ShadowedMessage f2 f1)@@ -1966,18 +2015,16 @@                                                        [("name", shadowedMessageName),                                                         ("value", shadowedMessageValue)]}})  -instance HsDhallPb.Interpret ShadowedMessage- -instance HsDhallPb.Inject ShadowedMessage-  data MessageShadower = MessageShadower{messageShadowerShadowedMessage                                        :: Hs.Maybe TestProto.MessageShadower_ShadowedMessage,                                        messageShadowerName :: Hs.Text}-                     deriving (Hs.Show, Hs.Eq, Hs.Ord, Hs.Generic)+                     deriving (Hs.Show, Hs.Eq, Hs.Ord, Hs.Generic, Hs.NFData)   instance HsProtobuf.Named MessageShadower where         nameOf _ = (Hs.fromString "MessageShadower")  +instance HsProtobuf.HasDefault MessageShadower+  instance HsProtobuf.Message MessageShadower where         encodeMessage _           MessageShadower{messageShadowerShadowedMessage =@@ -1985,12 +2032,16 @@                           messageShadowerName = messageShadowerName}           = (Hs.mconcat                [(HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 1)-                   (HsProtobuf.Nested messageShadowerShadowedMessage)),+                   (Hs.coerce @(Hs.Maybe TestProto.MessageShadower_ShadowedMessage)+                      @(HsProtobuf.Nested TestProto.MessageShadower_ShadowedMessage)+                      messageShadowerShadowedMessage)),                 (HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 2)                    messageShadowerName)])         decodeMessage _           = (Hs.pure MessageShadower) <*>-              ((Hs.pure HsProtobuf.nested) <*>+              (Hs.coerce+                 @(_ (HsProtobuf.Nested TestProto.MessageShadower_ShadowedMessage))+                 @(_ (Hs.Maybe TestProto.MessageShadower_ShadowedMessage))                  (HsProtobuf.at HsProtobuf.decodeMessageField                     (HsProtobuf.FieldNumber 1)))               <*>@@ -2002,12 +2053,12 @@                    (HsProtobuf.Named (HsProtobuf.Single "ShadowedMessage")))                 (HsProtobuf.Single "shadowed_message")                 []-                Hs.Nothing),+                ""),              (HsProtobuf.DotProtoField (HsProtobuf.FieldNumber 2)                 (HsProtobuf.Prim HsProtobuf.String)                 (HsProtobuf.Single "name")                 []-                Hs.Nothing)]+                "")]   instance HsJSONPB.ToJSONPB MessageShadower where         toJSONPB (MessageShadower f1 f2)@@ -2052,19 +2103,17 @@                                                          messageShadowerShadowedMessage),                                                         ("name", messageShadowerName)]}})  -instance HsDhallPb.Interpret MessageShadower- -instance HsDhallPb.Inject MessageShadower-  data MessageShadower_ShadowedMessage = MessageShadower_ShadowedMessage{messageShadower_ShadowedMessageName                                                                        :: Hs.Text,                                                                        messageShadower_ShadowedMessageValue                                                                        :: Hs.Text}-                                     deriving (Hs.Show, Hs.Eq, Hs.Ord, Hs.Generic)+                                     deriving (Hs.Show, Hs.Eq, Hs.Ord, Hs.Generic, Hs.NFData)   instance HsProtobuf.Named MessageShadower_ShadowedMessage where         nameOf _ = (Hs.fromString "MessageShadower_ShadowedMessage")  +instance HsProtobuf.HasDefault MessageShadower_ShadowedMessage+  instance HsProtobuf.Message MessageShadower_ShadowedMessage where         encodeMessage _           MessageShadower_ShadowedMessage{messageShadower_ShadowedMessageName@@ -2088,12 +2137,12 @@                 (HsProtobuf.Prim HsProtobuf.String)                 (HsProtobuf.Single "name")                 []-                Hs.Nothing),+                ""),              (HsProtobuf.DotProtoField (HsProtobuf.FieldNumber 2)                 (HsProtobuf.Prim HsProtobuf.String)                 (HsProtobuf.Single "value")                 []-                Hs.Nothing)]+                "")]   instance HsJSONPB.ToJSONPB MessageShadower_ShadowedMessage where         toJSONPB (MessageShadower_ShadowedMessage f1 f2)@@ -2138,19 +2187,17 @@                                                         ("value",                                                          messageShadower_ShadowedMessageValue)]}})  -instance HsDhallPb.Interpret MessageShadower_ShadowedMessage- -instance HsDhallPb.Inject MessageShadower_ShadowedMessage-  data WithQualifiedName = WithQualifiedName{withQualifiedNameQname1                                            :: Hs.Maybe TestProto.ShadowedMessage,                                            withQualifiedNameQname2 ::                                            Hs.Maybe TestProto.MessageShadower_ShadowedMessage}-                       deriving (Hs.Show, Hs.Eq, Hs.Ord, Hs.Generic)+                       deriving (Hs.Show, Hs.Eq, Hs.Ord, Hs.Generic, Hs.NFData)   instance HsProtobuf.Named WithQualifiedName where         nameOf _ = (Hs.fromString "WithQualifiedName")  +instance HsProtobuf.HasDefault WithQualifiedName+  instance HsProtobuf.Message WithQualifiedName where         encodeMessage _           WithQualifiedName{withQualifiedNameQname1 =@@ -2158,16 +2205,23 @@                             withQualifiedNameQname2 = withQualifiedNameQname2}           = (Hs.mconcat                [(HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 100)-                   (HsProtobuf.Nested withQualifiedNameQname1)),+                   (Hs.coerce @(Hs.Maybe TestProto.ShadowedMessage)+                      @(HsProtobuf.Nested TestProto.ShadowedMessage)+                      withQualifiedNameQname1)),                 (HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 200)-                   (HsProtobuf.Nested withQualifiedNameQname2))])+                   (Hs.coerce @(Hs.Maybe TestProto.MessageShadower_ShadowedMessage)+                      @(HsProtobuf.Nested TestProto.MessageShadower_ShadowedMessage)+                      withQualifiedNameQname2))])         decodeMessage _           = (Hs.pure WithQualifiedName) <*>-              ((Hs.pure HsProtobuf.nested) <*>+              (Hs.coerce @(_ (HsProtobuf.Nested TestProto.ShadowedMessage))+                 @(_ (Hs.Maybe TestProto.ShadowedMessage))                  (HsProtobuf.at HsProtobuf.decodeMessageField                     (HsProtobuf.FieldNumber 100)))               <*>-              ((Hs.pure HsProtobuf.nested) <*>+              (Hs.coerce+                 @(_ (HsProtobuf.Nested TestProto.MessageShadower_ShadowedMessage))+                 @(_ (Hs.Maybe TestProto.MessageShadower_ShadowedMessage))                  (HsProtobuf.at HsProtobuf.decodeMessageField                     (HsProtobuf.FieldNumber 200)))         dotProto _@@ -2176,15 +2230,15 @@                    (HsProtobuf.Named (HsProtobuf.Single "ShadowedMessage")))                 (HsProtobuf.Single "qname1")                 []-                Hs.Nothing),+                ""),              (HsProtobuf.DotProtoField (HsProtobuf.FieldNumber 200)                 (HsProtobuf.Prim                    (HsProtobuf.Named                       (HsProtobuf.Dots-                         (HsProtobuf.Path ["MessageShadower", "ShadowedMessage"]))))+                         (HsProtobuf.Path ("MessageShadower" Hs.:| ["ShadowedMessage"])))))                 (HsProtobuf.Single "qname2")                 []-                Hs.Nothing)]+                "")]   instance HsJSONPB.ToJSONPB WithQualifiedName where         toJSONPB (WithQualifiedName f100 f200)@@ -2227,18 +2281,16 @@                                                        [("qname1", withQualifiedNameQname1),                                                         ("qname2", withQualifiedNameQname2)]}})  -instance HsDhallPb.Interpret WithQualifiedName- -instance HsDhallPb.Inject WithQualifiedName-  data UsingImported = UsingImported{usingImportedImportedNesting ::                                    Hs.Maybe TestProtoImport.WithNesting,                                    usingImportedLocalNesting :: Hs.Maybe TestProto.WithNesting}-                   deriving (Hs.Show, Hs.Eq, Hs.Ord, Hs.Generic)+                   deriving (Hs.Show, Hs.Eq, Hs.Ord, Hs.Generic, Hs.NFData)   instance HsProtobuf.Named UsingImported where         nameOf _ = (Hs.fromString "UsingImported")  +instance HsProtobuf.HasDefault UsingImported+  instance HsProtobuf.Message UsingImported where         encodeMessage _           UsingImported{usingImportedImportedNesting =@@ -2246,16 +2298,22 @@                         usingImportedLocalNesting = usingImportedLocalNesting}           = (Hs.mconcat                [(HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 100)-                   (HsProtobuf.Nested usingImportedImportedNesting)),+                   (Hs.coerce @(Hs.Maybe TestProtoImport.WithNesting)+                      @(HsProtobuf.Nested TestProtoImport.WithNesting)+                      usingImportedImportedNesting)),                 (HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 200)-                   (HsProtobuf.Nested usingImportedLocalNesting))])+                   (Hs.coerce @(Hs.Maybe TestProto.WithNesting)+                      @(HsProtobuf.Nested TestProto.WithNesting)+                      usingImportedLocalNesting))])         decodeMessage _           = (Hs.pure UsingImported) <*>-              ((Hs.pure HsProtobuf.nested) <*>+              (Hs.coerce @(_ (HsProtobuf.Nested TestProtoImport.WithNesting))+                 @(_ (Hs.Maybe TestProtoImport.WithNesting))                  (HsProtobuf.at HsProtobuf.decodeMessageField                     (HsProtobuf.FieldNumber 100)))               <*>-              ((Hs.pure HsProtobuf.nested) <*>+              (Hs.coerce @(_ (HsProtobuf.Nested TestProto.WithNesting))+                 @(_ (Hs.Maybe TestProto.WithNesting))                  (HsProtobuf.at HsProtobuf.decodeMessageField                     (HsProtobuf.FieldNumber 200)))         dotProto _@@ -2263,16 +2321,16 @@                 (HsProtobuf.Prim                    (HsProtobuf.Named                       (HsProtobuf.Dots-                         (HsProtobuf.Path ["TestProtoImport", "WithNesting"]))))+                         (HsProtobuf.Path ("TestProtoImport" Hs.:| ["WithNesting"])))))                 (HsProtobuf.Single "importedNesting")                 []-                Hs.Nothing),+                ""),              (HsProtobuf.DotProtoField (HsProtobuf.FieldNumber 200)                 (HsProtobuf.Prim                    (HsProtobuf.Named (HsProtobuf.Single "WithNesting")))                 (HsProtobuf.Single "localNesting")                 []-                Hs.Nothing)]+                "")]   instance HsJSONPB.ToJSONPB UsingImported where         toJSONPB (UsingImported f100 f200)@@ -2319,25 +2377,26 @@                                                         ("localNesting",                                                          usingImportedLocalNesting)]}})  -instance HsDhallPb.Interpret UsingImported- -instance HsDhallPb.Inject UsingImported-  data Wrapped = Wrapped{wrappedWrapped ::                        Hs.Maybe TestProto.Wrapped}-             deriving (Hs.Show, Hs.Eq, Hs.Ord, Hs.Generic)+             deriving (Hs.Show, Hs.Eq, Hs.Ord, Hs.Generic, Hs.NFData)   instance HsProtobuf.Named Wrapped where         nameOf _ = (Hs.fromString "Wrapped")  +instance HsProtobuf.HasDefault Wrapped+  instance HsProtobuf.Message Wrapped where         encodeMessage _ Wrapped{wrappedWrapped = wrappedWrapped}           = (Hs.mconcat                [(HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 1)-                   (HsProtobuf.Nested wrappedWrapped))])+                   (Hs.coerce @(Hs.Maybe TestProto.Wrapped)+                      @(HsProtobuf.Nested TestProto.Wrapped)+                      wrappedWrapped))])         decodeMessage _           = (Hs.pure Wrapped) <*>-              ((Hs.pure HsProtobuf.nested) <*>+              (Hs.coerce @(_ (HsProtobuf.Nested TestProto.Wrapped))+                 @(_ (Hs.Maybe TestProto.Wrapped))                  (HsProtobuf.at HsProtobuf.decodeMessageField                     (HsProtobuf.FieldNumber 1)))         dotProto _@@ -2345,7 +2404,7 @@                 (HsProtobuf.Prim (HsProtobuf.Named (HsProtobuf.Single "Wrapped")))                 (HsProtobuf.Single "wrapped")                 []-                Hs.Nothing)]+                "")]   instance HsJSONPB.ToJSONPB Wrapped where         toJSONPB (Wrapped f1) = (HsJSONPB.object ["wrapped" .= f1])@@ -2379,28 +2438,31 @@                                                      HsJSONPB.insOrdFromList                                                        [("wrapped", wrappedWrapped)]}})  -instance HsDhallPb.Interpret Wrapped- -instance HsDhallPb.Inject Wrapped-  data EnumAnnots = EnumAnnotsFOO                 | EnumAnnotsBAR-                deriving (Hs.Show, Hs.Bounded, Hs.Eq, Hs.Ord, Hs.Generic)+                deriving (Hs.Show, Hs.Eq, Hs.Generic, Hs.NFData)   instance HsProtobuf.Named EnumAnnots where         nameOf _ = (Hs.fromString "EnumAnnots")  -instance Hs.Enum EnumAnnots where-        toEnum 0 = EnumAnnotsFOO-        toEnum 1 = EnumAnnotsBAR-        toEnum i = (Hs.toEnumError "EnumAnnots" i (0 :: Hs.Int, 1))-        fromEnum (EnumAnnotsFOO) = 0-        fromEnum (EnumAnnotsBAR) = 1-        succ (EnumAnnotsFOO) = EnumAnnotsBAR-        succ _ = Hs.succError "EnumAnnots"-        pred (EnumAnnotsBAR) = EnumAnnotsFOO-        pred _ = Hs.predError "EnumAnnots"+instance HsProtobuf.HasDefault EnumAnnots  +instance Hs.Bounded EnumAnnots where+        minBound = EnumAnnotsFOO+        maxBound = EnumAnnotsBAR+ +instance Hs.Ord EnumAnnots where+        compare x y+          = Hs.compare (HsProtobuf.fromProtoEnum x)+              (HsProtobuf.fromProtoEnum y)+ +instance HsProtobuf.ProtoEnum EnumAnnots where+        toProtoEnumMay 0 = Hs.Just EnumAnnotsFOO+        toProtoEnumMay 1 = Hs.Just EnumAnnotsBAR+        toProtoEnumMay _ = Hs.Nothing+        fromProtoEnum (EnumAnnotsFOO) = 0+        fromProtoEnum (EnumAnnotsBAR) = 1+  instance HsJSONPB.ToJSONPB EnumAnnots where         toJSONPB x _ = HsJSONPB.enumFieldString x         toEncodingPB x _ = HsJSONPB.enumFieldEncoding x@@ -2417,8 +2479,176 @@ instance HsJSONPB.FromJSON EnumAnnots where         parseJSON = HsJSONPB.parseJSONPB  -instance HsDhallPb.Interpret EnumAnnots+instance HsProtobuf.Finite EnumAnnots  -instance HsDhallPb.Inject EnumAnnots+data WrappedTrivial = WrappedTrivial{wrappedTrivialTrivial ::+                                     Hs.Maybe TestProto.Trivial}+                    deriving (Hs.Show, Hs.Eq, Hs.Ord, Hs.Generic, Hs.NFData)  -instance HsProtobuf.Finite EnumAnnots+instance HsProtobuf.Named WrappedTrivial where+        nameOf _ = (Hs.fromString "WrappedTrivial")+ +instance HsProtobuf.HasDefault WrappedTrivial+ +instance HsProtobuf.Message WrappedTrivial where+        encodeMessage _+          WrappedTrivial{wrappedTrivialTrivial = wrappedTrivialTrivial}+          = (Hs.mconcat+               [(HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 1)+                   (Hs.coerce @(Hs.Maybe TestProto.Trivial)+                      @(HsProtobuf.Nested TestProto.Trivial)+                      wrappedTrivialTrivial))])+        decodeMessage _+          = (Hs.pure WrappedTrivial) <*>+              (Hs.coerce @(_ (HsProtobuf.Nested TestProto.Trivial))+                 @(_ (Hs.Maybe TestProto.Trivial))+                 (HsProtobuf.at HsProtobuf.decodeMessageField+                    (HsProtobuf.FieldNumber 1)))+        dotProto _+          = [(HsProtobuf.DotProtoField (HsProtobuf.FieldNumber 1)+                (HsProtobuf.Prim (HsProtobuf.Named (HsProtobuf.Single "Trivial")))+                (HsProtobuf.Single "trivial")+                []+                "")]+ +instance HsJSONPB.ToJSONPB WrappedTrivial where+        toJSONPB (WrappedTrivial f1) = (HsJSONPB.object ["trivial" .= f1])+        toEncodingPB (WrappedTrivial f1)+          = (HsJSONPB.pairs ["trivial" .= f1])+ +instance HsJSONPB.FromJSONPB WrappedTrivial where+        parseJSONPB+          = (HsJSONPB.withObject "WrappedTrivial"+               (\ obj -> (Hs.pure WrappedTrivial) <*> obj .: "trivial"))+ +instance HsJSONPB.ToJSON WrappedTrivial where+        toJSON = HsJSONPB.toAesonValue+        toEncoding = HsJSONPB.toAesonEncoding+ +instance HsJSONPB.FromJSON WrappedTrivial where+        parseJSON = HsJSONPB.parseJSONPB+ +instance HsJSONPB.ToSchema WrappedTrivial where+        declareNamedSchema _+          = do let declare_trivial = HsJSONPB.declareSchemaRef+               wrappedTrivialTrivial <- declare_trivial Proxy.Proxy+               let _ = Hs.pure WrappedTrivial <*> HsJSONPB.asProxy declare_trivial+               Hs.return+                 (HsJSONPB.NamedSchema{HsJSONPB._namedSchemaName =+                                         Hs.Just "WrappedTrivial",+                                       HsJSONPB._namedSchemaSchema =+                                         Hs.mempty{HsJSONPB._schemaParamSchema =+                                                     Hs.mempty{HsJSONPB._paramSchemaType =+                                                                 HsJSONPB.SwaggerObject},+                                                   HsJSONPB._schemaProperties =+                                                     HsJSONPB.insOrdFromList+                                                       [("trivial", wrappedTrivialTrivial)]}})+ +data MapTest = MapTest{mapTestPrim :: Hs.Map Hs.Text Hs.Int32,+                       mapTestTrivial ::+                       Hs.Map Hs.Int32 (Hs.Maybe TestProto.WrappedTrivial),+                       mapTestSigned :: Hs.Map Hs.Int32 Hs.Int32}+             deriving (Hs.Show, Hs.Eq, Hs.Ord, Hs.Generic, Hs.NFData)+ +instance HsProtobuf.Named MapTest where+        nameOf _ = (Hs.fromString "MapTest")+ +instance HsProtobuf.HasDefault MapTest+ +instance HsProtobuf.Message MapTest where+        encodeMessage _+          MapTest{mapTestPrim = mapTestPrim, mapTestTrivial = mapTestTrivial,+                  mapTestSigned = mapTestSigned}+          = (Hs.mconcat+               [(HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 1)+                   (Hs.unsafeCoerce @(Hs.Map Hs.Text Hs.Int32)+                      @(Hs.Map Hs.Text (HsProtobuf.Signed Hs.Int32))+                      mapTestPrim)),+                (HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 2)+                   (Hs.unsafeCoerce+                      @(Hs.Map Hs.Int32 (Hs.Maybe TestProto.WrappedTrivial))+                      @(Hs.Map Hs.Int32 (HsProtobuf.Nested TestProto.WrappedTrivial))+                      mapTestTrivial)),+                (HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 3)+                   (Hs.unsafeCoerce @(Hs.Map Hs.Int32 Hs.Int32)+                      @(Hs.Map (HsProtobuf.Signed Hs.Int32) (HsProtobuf.Signed Hs.Int32))+                      mapTestSigned))])+        decodeMessage _+          = (Hs.pure MapTest) <*>+              (Hs.unsafeCoerce @(_ (Hs.Map Hs.Text (HsProtobuf.Signed Hs.Int32)))+                 @(_ (Hs.Map Hs.Text Hs.Int32))+                 (HsProtobuf.at HsProtobuf.decodeMessageField+                    (HsProtobuf.FieldNumber 1)))+              <*>+              (Hs.unsafeCoerce+                 @(_ (Hs.Map Hs.Int32 (HsProtobuf.Nested TestProto.WrappedTrivial)))+                 @(_ (Hs.Map Hs.Int32 (Hs.Maybe TestProto.WrappedTrivial)))+                 (HsProtobuf.at HsProtobuf.decodeMessageField+                    (HsProtobuf.FieldNumber 2)))+              <*>+              (Hs.unsafeCoerce+                 @(_ (Hs.Map (HsProtobuf.Signed Hs.Int32) (HsProtobuf.Signed Hs.Int32)))+                 @(_ (Hs.Map Hs.Int32 Hs.Int32))+                 (HsProtobuf.at HsProtobuf.decodeMessageField+                    (HsProtobuf.FieldNumber 3)))+        dotProto _+          = [(HsProtobuf.DotProtoField (HsProtobuf.FieldNumber 1)+                (HsProtobuf.Map HsProtobuf.String HsProtobuf.SInt32)+                (HsProtobuf.Single "prim")+                []+                ""),+             (HsProtobuf.DotProtoField (HsProtobuf.FieldNumber 2)+                (HsProtobuf.Map HsProtobuf.Int32+                   (HsProtobuf.Named (HsProtobuf.Single "WrappedTrivial")))+                (HsProtobuf.Single "trivial")+                []+                ""),+             (HsProtobuf.DotProtoField (HsProtobuf.FieldNumber 3)+                (HsProtobuf.Map HsProtobuf.SInt32 HsProtobuf.SInt32)+                (HsProtobuf.Single "signed")+                []+                "")]+ +instance HsJSONPB.ToJSONPB MapTest where+        toJSONPB (MapTest f1 f2 f3)+          = (HsJSONPB.object ["prim" .= f1, "trivial" .= f2, "signed" .= f3])+        toEncodingPB (MapTest f1 f2 f3)+          = (HsJSONPB.pairs ["prim" .= f1, "trivial" .= f2, "signed" .= f3])+ +instance HsJSONPB.FromJSONPB MapTest where+        parseJSONPB+          = (HsJSONPB.withObject "MapTest"+               (\ obj ->+                  (Hs.pure MapTest) <*> obj .: "prim" <*> obj .: "trivial" <*>+                    obj .: "signed"))+ +instance HsJSONPB.ToJSON MapTest where+        toJSON = HsJSONPB.toAesonValue+        toEncoding = HsJSONPB.toAesonEncoding+ +instance HsJSONPB.FromJSON MapTest where+        parseJSON = HsJSONPB.parseJSONPB+ +instance HsJSONPB.ToSchema MapTest where+        declareNamedSchema _+          = do let declare_prim = HsJSONPB.declareSchemaRef+               mapTestPrim <- declare_prim Proxy.Proxy+               let declare_trivial = HsJSONPB.declareSchemaRef+               mapTestTrivial <- declare_trivial Proxy.Proxy+               let declare_signed = HsJSONPB.declareSchemaRef+               mapTestSigned <- declare_signed Proxy.Proxy+               let _ = Hs.pure MapTest <*> HsJSONPB.asProxy declare_prim <*>+                         HsJSONPB.asProxy declare_trivial+                         <*> HsJSONPB.asProxy declare_signed+               Hs.return+                 (HsJSONPB.NamedSchema{HsJSONPB._namedSchemaName =+                                         Hs.Just "MapTest",+                                       HsJSONPB._namedSchemaSchema =+                                         Hs.mempty{HsJSONPB._schemaParamSchema =+                                                     Hs.mempty{HsJSONPB._paramSchemaType =+                                                                 HsJSONPB.SwaggerObject},+                                                   HsJSONPB._schemaProperties =+                                                     HsJSONPB.insOrdFromList+                                                       [("prim", mapTestPrim),+                                                        ("trivial", mapTestTrivial),+                                                        ("signed", mapTestSigned)]}})

@@ -1,6 +1,8 @@ {-# LANGUAGE DeriveGeneric     #-}+{-# LANGUAGE DeriveAnyClass    #-} {-# LANGUAGE DataKinds         #-} {-# LANGUAGE GADTs             #-}+{-# LANGUAGE TypeApplications  #-} {-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-unused-imports #-} {-# OPTIONS_GHC -fno-warn-name-shadowing #-}@@ -9,51 +11,65 @@ -- | Generated by Haskell protocol buffer compiler. DO NOT EDIT! module TestProtoImport where import qualified Prelude as Hs-import qualified Proto3.Suite.DhallPB as HsDhallPb-import qualified Proto3.Suite.DotProto as HsProtobuf-import qualified Proto3.Suite.Types as HsProtobuf 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 Control.Applicative ((<*>), (<|>), (<$>)) import qualified Control.Applicative as Hs+import Control.Applicative ((<*>), (<|>), (<$>))+import qualified Control.DeepSeq as Hs import qualified Control.Monad as Hs-import qualified Data.Text.Lazy as Hs (Text) 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.Int as Hs (Int16, Int32, Int64) import qualified Data.Word as Hs (Word16, Word32, Word64)-import qualified Data.Proxy as Proxy-import qualified GHC.Generics as Hs import qualified GHC.Enum as Hs+import qualified GHC.Generics as Hs+import qualified Unsafe.Coerce as Hs   data WithNesting = WithNesting{withNestingNestedMessage1 ::                                Hs.Maybe TestProtoImport.WithNesting_Nested,                                withNestingNestedMessage2 ::                                Hs.Maybe TestProtoImport.WithNesting_Nested}-                 deriving (Hs.Show, Hs.Eq, Hs.Ord, Hs.Generic)+                 deriving (Hs.Show, Hs.Eq, Hs.Ord, Hs.Generic, Hs.NFData)   instance HsProtobuf.Named WithNesting where         nameOf _ = (Hs.fromString "WithNesting")  +instance HsProtobuf.HasDefault WithNesting+  instance HsProtobuf.Message WithNesting where         encodeMessage _           WithNesting{withNestingNestedMessage1 = withNestingNestedMessage1,                       withNestingNestedMessage2 = withNestingNestedMessage2}           = (Hs.mconcat                [(HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 1)-                   (HsProtobuf.Nested withNestingNestedMessage1)),+                   (Hs.coerce @(Hs.Maybe TestProtoImport.WithNesting_Nested)+                      @(HsProtobuf.Nested TestProtoImport.WithNesting_Nested)+                      withNestingNestedMessage1)),                 (HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 100)-                   (HsProtobuf.Nested withNestingNestedMessage2))])+                   (Hs.coerce @(Hs.Maybe TestProtoImport.WithNesting_Nested)+                      @(HsProtobuf.Nested TestProtoImport.WithNesting_Nested)+                      withNestingNestedMessage2))])         decodeMessage _           = (Hs.pure WithNesting) <*>-              ((Hs.pure HsProtobuf.nested) <*>+              (Hs.coerce+                 @(_ (HsProtobuf.Nested TestProtoImport.WithNesting_Nested))+                 @(_ (Hs.Maybe TestProtoImport.WithNesting_Nested))                  (HsProtobuf.at HsProtobuf.decodeMessageField                     (HsProtobuf.FieldNumber 1)))               <*>-              ((Hs.pure HsProtobuf.nested) <*>+              (Hs.coerce+                 @(_ (HsProtobuf.Nested TestProtoImport.WithNesting_Nested))+                 @(_ (Hs.Maybe TestProtoImport.WithNesting_Nested))                  (HsProtobuf.at HsProtobuf.decodeMessageField                     (HsProtobuf.FieldNumber 100)))         dotProto _@@ -61,12 +77,12 @@                 (HsProtobuf.Prim (HsProtobuf.Named (HsProtobuf.Single "Nested")))                 (HsProtobuf.Single "nestedMessage1")                 []-                Hs.Nothing),+                ""),              (HsProtobuf.DotProtoField (HsProtobuf.FieldNumber 100)                 (HsProtobuf.Prim (HsProtobuf.Named (HsProtobuf.Single "Nested")))                 (HsProtobuf.Single "nestedMessage2")                 []-                Hs.Nothing)]+                "")]   instance HsJSONPB.ToJSONPB WithNesting where         toJSONPB (WithNesting f1 f100)@@ -113,18 +129,16 @@                                                         ("nestedMessage2",                                                          withNestingNestedMessage2)]}})  -instance HsDhallPb.Interpret WithNesting- -instance HsDhallPb.Inject WithNesting-  data WithNesting_Nested = WithNesting_Nested{withNesting_NestedNestedField1                                              :: Hs.Int32,                                              withNesting_NestedNestedField2 :: Hs.Int32}-                        deriving (Hs.Show, Hs.Eq, Hs.Ord, Hs.Generic)+                        deriving (Hs.Show, Hs.Eq, Hs.Ord, Hs.Generic, Hs.NFData)   instance HsProtobuf.Named WithNesting_Nested where         nameOf _ = (Hs.fromString "WithNesting_Nested")  +instance HsProtobuf.HasDefault WithNesting_Nested+  instance HsProtobuf.Message WithNesting_Nested where         encodeMessage _           WithNesting_Nested{withNesting_NestedNestedField1 =@@ -147,12 +161,12 @@                 (HsProtobuf.Prim HsProtobuf.Int32)                 (HsProtobuf.Single "nestedField1")                 []-                Hs.Nothing),+                ""),              (HsProtobuf.DotProtoField (HsProtobuf.FieldNumber 2)                 (HsProtobuf.Prim HsProtobuf.Int32)                 (HsProtobuf.Single "nestedField2")                 []-                Hs.Nothing)]+                "")]   instance HsJSONPB.ToJSONPB WithNesting_Nested where         toJSONPB (WithNesting_Nested f1 f2)@@ -196,7 +210,3 @@                                                          withNesting_NestedNestedField1),                                                         ("nestedField2",                                                          withNesting_NestedNestedField2)]}})- -instance HsDhallPb.Interpret WithNesting_Nested- -instance HsDhallPb.Inject WithNesting_Nested

@@ -1,6 +1,8 @@ {-# LANGUAGE DeriveGeneric     #-}+{-# LANGUAGE DeriveAnyClass    #-} {-# LANGUAGE DataKinds         #-} {-# LANGUAGE GADTs             #-}+{-# LANGUAGE TypeApplications  #-} {-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-unused-imports #-} {-# OPTIONS_GHC -fno-warn-name-shadowing #-}@@ -9,33 +11,39 @@ -- | Generated by Haskell protocol buffer compiler. DO NOT EDIT! module TestProtoOneof where import qualified Prelude as Hs-import qualified Proto3.Suite.DhallPB as HsDhallPb-import qualified Proto3.Suite.DotProto as HsProtobuf-import qualified Proto3.Suite.Types as HsProtobuf 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 Control.Applicative ((<*>), (<|>), (<$>)) import qualified Control.Applicative as Hs+import Control.Applicative ((<*>), (<|>), (<$>))+import qualified Control.DeepSeq as Hs import qualified Control.Monad as Hs-import qualified Data.Text.Lazy as Hs (Text) 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.Int as Hs (Int16, Int32, Int64) import qualified Data.Word as Hs (Word16, Word32, Word64)-import qualified Data.Proxy as Proxy-import qualified GHC.Generics as Hs import qualified GHC.Enum as Hs+import qualified GHC.Generics as Hs+import qualified Unsafe.Coerce as Hs import qualified TestProtoOneofImport   data DummyMsg = DummyMsg{dummyMsgDummy :: Hs.Int32}-              deriving (Hs.Show, Hs.Eq, Hs.Ord, Hs.Generic)+              deriving (Hs.Show, Hs.Eq, Hs.Ord, Hs.Generic, Hs.NFData)   instance HsProtobuf.Named DummyMsg where         nameOf _ = (Hs.fromString "DummyMsg")  +instance HsProtobuf.HasDefault DummyMsg+  instance HsProtobuf.Message DummyMsg where         encodeMessage _ DummyMsg{dummyMsgDummy = dummyMsgDummy}           = (Hs.mconcat@@ -50,7 +58,7 @@                 (HsProtobuf.Prim HsProtobuf.Int32)                 (HsProtobuf.Single "dummy")                 []-                Hs.Nothing)]+                "")]   instance HsJSONPB.ToJSONPB DummyMsg where         toJSONPB (DummyMsg f1) = (HsJSONPB.object ["dummy" .= f1])@@ -84,28 +92,31 @@                                                      HsJSONPB.insOrdFromList                                                        [("dummy", dummyMsgDummy)]}})  -instance HsDhallPb.Interpret DummyMsg- -instance HsDhallPb.Inject DummyMsg-  data DummyEnum = DummyEnumDUMMY0                | DummyEnumDUMMY1-               deriving (Hs.Show, Hs.Bounded, Hs.Eq, Hs.Ord, Hs.Generic)+               deriving (Hs.Show, Hs.Eq, Hs.Generic, Hs.NFData)   instance HsProtobuf.Named DummyEnum where         nameOf _ = (Hs.fromString "DummyEnum")  -instance Hs.Enum DummyEnum where-        toEnum 0 = DummyEnumDUMMY0-        toEnum 1 = DummyEnumDUMMY1-        toEnum i = (Hs.toEnumError "DummyEnum" i (0 :: Hs.Int, 1))-        fromEnum (DummyEnumDUMMY0) = 0-        fromEnum (DummyEnumDUMMY1) = 1-        succ (DummyEnumDUMMY0) = DummyEnumDUMMY1-        succ _ = Hs.succError "DummyEnum"-        pred (DummyEnumDUMMY1) = DummyEnumDUMMY0-        pred _ = Hs.predError "DummyEnum"+instance HsProtobuf.HasDefault DummyEnum  +instance Hs.Bounded DummyEnum where+        minBound = DummyEnumDUMMY0+        maxBound = DummyEnumDUMMY1+ +instance Hs.Ord DummyEnum where+        compare x y+          = Hs.compare (HsProtobuf.fromProtoEnum x)+              (HsProtobuf.fromProtoEnum y)+ +instance HsProtobuf.ProtoEnum DummyEnum where+        toProtoEnumMay 0 = Hs.Just DummyEnumDUMMY0+        toProtoEnumMay 1 = Hs.Just DummyEnumDUMMY1+        toProtoEnumMay _ = Hs.Nothing+        fromProtoEnum (DummyEnumDUMMY0) = 0+        fromProtoEnum (DummyEnumDUMMY1) = 1+  instance HsJSONPB.ToJSONPB DummyEnum where         toJSONPB x _ = HsJSONPB.enumFieldString x         toEncodingPB x _ = HsJSONPB.enumFieldEncoding x@@ -122,20 +133,18 @@ instance HsJSONPB.FromJSON DummyEnum where         parseJSON = HsJSONPB.parseJSONPB  -instance HsDhallPb.Interpret DummyEnum- -instance HsDhallPb.Inject DummyEnum-  instance HsProtobuf.Finite DummyEnum   data Something = Something{somethingValue :: Hs.Int64,                            somethingAnother :: Hs.Int32,                            somethingPickOne :: Hs.Maybe SomethingPickOne}-               deriving (Hs.Show, Hs.Eq, Hs.Ord, Hs.Generic)+               deriving (Hs.Show, Hs.Eq, Hs.Ord, Hs.Generic, Hs.NFData)   instance HsProtobuf.Named Something where         nameOf _ = (Hs.fromString "Something")  +instance HsProtobuf.HasDefault Something+  instance HsProtobuf.Message Something where         encodeMessage _           Something{somethingValue = somethingValue,@@ -143,9 +152,11 @@                     somethingPickOne = somethingPickOne}           = (Hs.mconcat                [(HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 1)-                   (HsProtobuf.Signed somethingValue)),+                   (Hs.coerce @(Hs.Int64) @(HsProtobuf.Signed Hs.Int64)+                      somethingValue)),                 (HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 2)-                   (HsProtobuf.Signed somethingAnother)),+                   (Hs.coerce @(Hs.Int32) @(HsProtobuf.Signed Hs.Int32)+                      somethingAnother)),                 case somethingPickOne of                     Hs.Nothing -> Hs.mempty                     Hs.Just x@@ -158,20 +169,24 @@                                      (HsProtobuf.ForceEmit y))                              SomethingPickOneDummyMsg1 y                                -> (HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 10)-                                     (HsProtobuf.Nested (Hs.Just y)))+                                     (Hs.coerce @(Hs.Maybe TestProtoOneof.DummyMsg)+                                        @(HsProtobuf.Nested TestProtoOneof.DummyMsg)+                                        (Hs.Just y)))                              SomethingPickOneDummyMsg2 y                                -> (HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 11)-                                     (HsProtobuf.Nested (Hs.Just y)))+                                     (Hs.coerce @(Hs.Maybe TestProtoOneof.DummyMsg)+                                        @(HsProtobuf.Nested TestProtoOneof.DummyMsg)+                                        (Hs.Just y)))                              SomethingPickOneDummyEnum y                                -> (HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 12)                                      (HsProtobuf.ForceEmit y))])         decodeMessage _           = (Hs.pure Something) <*>-              ((Hs.pure HsProtobuf.signed) <*>+              (Hs.coerce @(_ (HsProtobuf.Signed Hs.Int64)) @(_ Hs.Int64)                  (HsProtobuf.at HsProtobuf.decodeMessageField                     (HsProtobuf.FieldNumber 1)))               <*>-              ((Hs.pure HsProtobuf.signed) <*>+              (Hs.coerce @(_ (HsProtobuf.Signed Hs.Int32)) @(_ Hs.Int32)                  (HsProtobuf.at HsProtobuf.decodeMessageField                     (HsProtobuf.FieldNumber 2)))               <*>@@ -184,10 +199,14 @@                      HsProtobuf.decodeMessageField),                   ((HsProtobuf.FieldNumber 10),                    (Hs.pure (Hs.fmap SomethingPickOneDummyMsg1)) <*>-                     ((Hs.pure HsProtobuf.nested) <*> HsProtobuf.decodeMessageField)),+                     (Hs.coerce @(_ (HsProtobuf.Nested TestProtoOneof.DummyMsg))+                        @(_ (Hs.Maybe TestProtoOneof.DummyMsg))+                        HsProtobuf.decodeMessageField)),                   ((HsProtobuf.FieldNumber 11),                    (Hs.pure (Hs.fmap SomethingPickOneDummyMsg2)) <*>-                     ((Hs.pure HsProtobuf.nested) <*> HsProtobuf.decodeMessageField)),+                     (Hs.coerce @(_ (HsProtobuf.Nested TestProtoOneof.DummyMsg))+                        @(_ (Hs.Maybe TestProtoOneof.DummyMsg))+                        HsProtobuf.decodeMessageField)),                   ((HsProtobuf.FieldNumber 12),                    (Hs.pure (Hs.Just Hs.. SomethingPickOneDummyEnum)) <*>                      HsProtobuf.decodeMessageField)])@@ -196,12 +215,12 @@                 (HsProtobuf.Prim HsProtobuf.SInt64)                 (HsProtobuf.Single "value")                 []-                Hs.Nothing),+                ""),              (HsProtobuf.DotProtoField (HsProtobuf.FieldNumber 2)                 (HsProtobuf.Prim HsProtobuf.SInt32)                 (HsProtobuf.Single "another")                 []-                Hs.Nothing)]+                "")]   instance HsJSONPB.ToJSONPB Something where         toJSONPB (Something f1 f2 f4_or_f9_or_f10_or_f11_or_f12)@@ -299,17 +318,13 @@                                                         ("another", somethingAnother),                                                         ("pickOne", somethingPickOne)]}})  -instance HsDhallPb.Interpret Something- -instance HsDhallPb.Inject Something-  data SomethingPickOne = SomethingPickOneName Hs.Text                       | SomethingPickOneSomeid Hs.Int32                       | SomethingPickOneDummyMsg1 TestProtoOneof.DummyMsg                       | SomethingPickOneDummyMsg2 TestProtoOneof.DummyMsg                       | SomethingPickOneDummyEnum (HsProtobuf.Enumerated                                                      TestProtoOneof.DummyEnum)-                      deriving (Hs.Show, Hs.Eq, Hs.Ord, Hs.Generic)+                      deriving (Hs.Show, Hs.Eq, Hs.Ord, Hs.Generic, Hs.NFData)   instance HsProtobuf.Named SomethingPickOne where         nameOf _ = (Hs.fromString "SomethingPickOne")@@ -353,18 +368,16 @@                                                    HsJSONPB._schemaMinProperties = Hs.Just 1,                                                    HsJSONPB._schemaMaxProperties = Hs.Just 1}})  -instance HsDhallPb.Interpret SomethingPickOne- -instance HsDhallPb.Inject SomethingPickOne-  data OneofFirst = OneofFirst{oneofFirstFirst ::                              Hs.Maybe OneofFirstFirst,                              oneofFirstLast :: Hs.Int32}-                deriving (Hs.Show, Hs.Eq, Hs.Ord, Hs.Generic)+                deriving (Hs.Show, Hs.Eq, Hs.Ord, Hs.Generic, Hs.NFData)   instance HsProtobuf.Named OneofFirst where         nameOf _ = (Hs.fromString "OneofFirst")  +instance HsProtobuf.HasDefault OneofFirst+  instance HsProtobuf.Message OneofFirst where         encodeMessage _           OneofFirst{oneofFirstFirst = oneofFirstFirst,@@ -399,7 +412,7 @@                 (HsProtobuf.Prim HsProtobuf.Int32)                 (HsProtobuf.Single "last")                 []-                Hs.Nothing)]+                "")]   instance HsJSONPB.ToJSONPB OneofFirst where         toJSONPB (OneofFirst f1_or_f2 f3)@@ -473,13 +486,9 @@                                                        [("first", oneofFirstFirst),                                                         ("last", oneofFirstLast)]}})  -instance HsDhallPb.Interpret OneofFirst- -instance HsDhallPb.Inject OneofFirst-  data OneofFirstFirst = OneofFirstFirstChoice1 Hs.Text                      | OneofFirstFirstChoice2 Hs.Text-                     deriving (Hs.Show, Hs.Eq, Hs.Ord, Hs.Generic)+                     deriving (Hs.Show, Hs.Eq, Hs.Ord, Hs.Generic, Hs.NFData)   instance HsProtobuf.Named OneofFirstFirst where         nameOf _ = (Hs.fromString "OneofFirstFirst")@@ -508,18 +517,16 @@                                                    HsJSONPB._schemaMinProperties = Hs.Just 1,                                                    HsJSONPB._schemaMaxProperties = Hs.Just 1}})  -instance HsDhallPb.Interpret OneofFirstFirst- -instance HsDhallPb.Inject OneofFirstFirst-  data OneofMiddle = OneofMiddle{oneofMiddleFirst :: Hs.Int32,                                oneofMiddleMiddle :: Hs.Maybe OneofMiddleMiddle,                                oneofMiddleLast :: Hs.Int32}-                 deriving (Hs.Show, Hs.Eq, Hs.Ord, Hs.Generic)+                 deriving (Hs.Show, Hs.Eq, Hs.Ord, Hs.Generic, Hs.NFData)   instance HsProtobuf.Named OneofMiddle where         nameOf _ = (Hs.fromString "OneofMiddle")  +instance HsProtobuf.HasDefault OneofMiddle+  instance HsProtobuf.Message OneofMiddle where         encodeMessage _           OneofMiddle{oneofMiddleFirst = oneofMiddleFirst,@@ -560,12 +567,12 @@                 (HsProtobuf.Prim HsProtobuf.Int32)                 (HsProtobuf.Single "first")                 []-                Hs.Nothing),+                ""),              (HsProtobuf.DotProtoField (HsProtobuf.FieldNumber 4)                 (HsProtobuf.Prim HsProtobuf.Int32)                 (HsProtobuf.Single "last")                 []-                Hs.Nothing)]+                "")]   instance HsJSONPB.ToJSONPB OneofMiddle where         toJSONPB (OneofMiddle f1 f2_or_f3 f4)@@ -651,13 +658,9 @@                                                         ("middle", oneofMiddleMiddle),                                                         ("last", oneofMiddleLast)]}})  -instance HsDhallPb.Interpret OneofMiddle- -instance HsDhallPb.Inject OneofMiddle-  data OneofMiddleMiddle = OneofMiddleMiddleChoice1 Hs.Text                        | OneofMiddleMiddleChoice2 Hs.Text-                       deriving (Hs.Show, Hs.Eq, Hs.Ord, Hs.Generic)+                       deriving (Hs.Show, Hs.Eq, Hs.Ord, Hs.Generic, Hs.NFData)   instance HsProtobuf.Named OneofMiddleMiddle where         nameOf _ = (Hs.fromString "OneofMiddleMiddle")@@ -686,17 +689,15 @@                                                    HsJSONPB._schemaMinProperties = Hs.Just 1,                                                    HsJSONPB._schemaMaxProperties = Hs.Just 1}})  -instance HsDhallPb.Interpret OneofMiddleMiddle- -instance HsDhallPb.Inject OneofMiddleMiddle-  data WithImported = WithImported{withImportedPickOne ::                                  Hs.Maybe WithImportedPickOne}-                  deriving (Hs.Show, Hs.Eq, Hs.Ord, Hs.Generic)+                  deriving (Hs.Show, Hs.Eq, Hs.Ord, Hs.Generic, Hs.NFData)   instance HsProtobuf.Named WithImported where         nameOf _ = (Hs.fromString "WithImported")  +instance HsProtobuf.HasDefault WithImported+  instance HsProtobuf.Message WithImported where         encodeMessage _           WithImported{withImportedPickOne = withImportedPickOne}@@ -707,19 +708,27 @@                       -> case x of                              WithImportedPickOneDummyMsg1 y                                -> (HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 1)-                                     (HsProtobuf.Nested (Hs.Just y)))+                                     (Hs.coerce @(Hs.Maybe TestProtoOneof.DummyMsg)+                                        @(HsProtobuf.Nested TestProtoOneof.DummyMsg)+                                        (Hs.Just y)))                              WithImportedPickOneWithOneof y                                -> (HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 2)-                                     (HsProtobuf.Nested (Hs.Just y)))])+                                     (Hs.coerce @(Hs.Maybe TestProtoOneofImport.WithOneof)+                                        @(HsProtobuf.Nested TestProtoOneofImport.WithOneof)+                                        (Hs.Just y)))])         decodeMessage _           = (Hs.pure WithImported) <*>               (HsProtobuf.oneof Hs.Nothing                  [((HsProtobuf.FieldNumber 1),                    (Hs.pure (Hs.fmap WithImportedPickOneDummyMsg1)) <*>-                     ((Hs.pure HsProtobuf.nested) <*> HsProtobuf.decodeMessageField)),+                     (Hs.coerce @(_ (HsProtobuf.Nested TestProtoOneof.DummyMsg))+                        @(_ (Hs.Maybe TestProtoOneof.DummyMsg))+                        HsProtobuf.decodeMessageField)),                   ((HsProtobuf.FieldNumber 2),                    (Hs.pure (Hs.fmap WithImportedPickOneWithOneof)) <*>-                     ((Hs.pure HsProtobuf.nested) <*> HsProtobuf.decodeMessageField))])+                     (Hs.coerce @(_ (HsProtobuf.Nested TestProtoOneofImport.WithOneof))+                        @(_ (Hs.Maybe TestProtoOneofImport.WithOneof))+                        HsProtobuf.decodeMessageField))])         dotProto _ = []   instance HsJSONPB.ToJSONPB WithImported where@@ -794,13 +803,9 @@                                                      HsJSONPB.insOrdFromList                                                        [("pickOne", withImportedPickOne)]}})  -instance HsDhallPb.Interpret WithImported- -instance HsDhallPb.Inject WithImported-  data WithImportedPickOne = WithImportedPickOneDummyMsg1 TestProtoOneof.DummyMsg                          | WithImportedPickOneWithOneof TestProtoOneofImport.WithOneof-                         deriving (Hs.Show, Hs.Eq, Hs.Ord, Hs.Generic)+                         deriving (Hs.Show, Hs.Eq, Hs.Ord, Hs.Generic, Hs.NFData)   instance HsProtobuf.Named WithImportedPickOne where         nameOf _ = (Hs.fromString "WithImportedPickOne")@@ -829,7 +834,3 @@                                                          withImportedPickOneWithOneof)],                                                    HsJSONPB._schemaMinProperties = Hs.Just 1,                                                    HsJSONPB._schemaMaxProperties = Hs.Just 1}})- -instance HsDhallPb.Interpret WithImportedPickOne- -instance HsDhallPb.Inject WithImportedPickOne

@@ -1,6 +1,8 @@ {-# LANGUAGE DeriveGeneric     #-}+{-# LANGUAGE DeriveAnyClass    #-} {-# LANGUAGE DataKinds         #-} {-# LANGUAGE GADTs             #-}+{-# LANGUAGE TypeApplications  #-} {-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-unused-imports #-} {-# OPTIONS_GHC -fno-warn-name-shadowing #-}@@ -9,33 +11,112 @@ -- | Generated by Haskell protocol buffer compiler. DO NOT EDIT! module TestProtoOneofImport where import qualified Prelude as Hs-import qualified Proto3.Suite.DhallPB as HsDhallPb-import qualified Proto3.Suite.DotProto as HsProtobuf-import qualified Proto3.Suite.Types as HsProtobuf 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 Control.Applicative ((<*>), (<|>), (<$>)) import qualified Control.Applicative as Hs+import Control.Applicative ((<*>), (<|>), (<$>))+import qualified Control.DeepSeq as Hs import qualified Control.Monad as Hs-import qualified Data.Text.Lazy as Hs (Text) 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.Int as Hs (Int16, Int32, Int64) import qualified Data.Word as Hs (Word16, Word32, Word64)-import qualified Data.Proxy as Proxy-import qualified GHC.Generics as Hs import qualified GHC.Enum as Hs+import qualified GHC.Generics as Hs+import qualified Unsafe.Coerce as Hs  +data AMessage = AMessage{amessageX :: Hs.Text,+                         amessageY :: Hs.Int32}+              deriving (Hs.Show, Hs.Eq, Hs.Ord, Hs.Generic, Hs.NFData)+ +instance HsProtobuf.Named AMessage where+        nameOf _ = (Hs.fromString "AMessage")+ +instance HsProtobuf.HasDefault AMessage+ +instance HsProtobuf.Message AMessage where+        encodeMessage _+          AMessage{amessageX = amessageX, amessageY = amessageY}+          = (Hs.mconcat+               [(HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 1)+                   amessageX),+                (HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 2)+                   amessageY)])+        decodeMessage _+          = (Hs.pure AMessage) <*>+              (HsProtobuf.at HsProtobuf.decodeMessageField+                 (HsProtobuf.FieldNumber 1))+              <*>+              (HsProtobuf.at HsProtobuf.decodeMessageField+                 (HsProtobuf.FieldNumber 2))+        dotProto _+          = [(HsProtobuf.DotProtoField (HsProtobuf.FieldNumber 1)+                (HsProtobuf.Prim HsProtobuf.String)+                (HsProtobuf.Single "x")+                []+                ""),+             (HsProtobuf.DotProtoField (HsProtobuf.FieldNumber 2)+                (HsProtobuf.Prim HsProtobuf.Int32)+                (HsProtobuf.Single "y")+                []+                "")]+ +instance HsJSONPB.ToJSONPB AMessage where+        toJSONPB (AMessage f1 f2)+          = (HsJSONPB.object ["x" .= f1, "y" .= f2])+        toEncodingPB (AMessage f1 f2)+          = (HsJSONPB.pairs ["x" .= f1, "y" .= f2])+ +instance HsJSONPB.FromJSONPB AMessage where+        parseJSONPB+          = (HsJSONPB.withObject "AMessage"+               (\ obj -> (Hs.pure AMessage) <*> obj .: "x" <*> obj .: "y"))+ +instance HsJSONPB.ToJSON AMessage where+        toJSON = HsJSONPB.toAesonValue+        toEncoding = HsJSONPB.toAesonEncoding+ +instance HsJSONPB.FromJSON AMessage where+        parseJSON = HsJSONPB.parseJSONPB+ +instance HsJSONPB.ToSchema AMessage where+        declareNamedSchema _+          = do let declare_x = HsJSONPB.declareSchemaRef+               amessageX <- declare_x Proxy.Proxy+               let declare_y = HsJSONPB.declareSchemaRef+               amessageY <- declare_y Proxy.Proxy+               let _ = Hs.pure AMessage <*> HsJSONPB.asProxy declare_x <*>+                         HsJSONPB.asProxy declare_y+               Hs.return+                 (HsJSONPB.NamedSchema{HsJSONPB._namedSchemaName =+                                         Hs.Just "AMessage",+                                       HsJSONPB._namedSchemaSchema =+                                         Hs.mempty{HsJSONPB._schemaParamSchema =+                                                     Hs.mempty{HsJSONPB._paramSchemaType =+                                                                 HsJSONPB.SwaggerObject},+                                                   HsJSONPB._schemaProperties =+                                                     HsJSONPB.insOrdFromList+                                                       [("x", amessageX), ("y", amessageY)]}})+  data WithOneof = WithOneof{withOneofPickOne ::                            Hs.Maybe WithOneofPickOne}-               deriving (Hs.Show, Hs.Eq, Hs.Ord, Hs.Generic)+               deriving (Hs.Show, Hs.Eq, Hs.Ord, Hs.Generic, Hs.NFData)   instance HsProtobuf.Named WithOneof where         nameOf _ = (Hs.fromString "WithOneof")  +instance HsProtobuf.HasDefault WithOneof+  instance HsProtobuf.Message WithOneof where         encodeMessage _ WithOneof{withOneofPickOne = withOneofPickOne}           = (Hs.mconcat@@ -48,7 +129,12 @@                                      (HsProtobuf.ForceEmit y))                              WithOneofPickOneB y                                -> (HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 2)-                                     (HsProtobuf.ForceEmit y))])+                                     (HsProtobuf.ForceEmit y))+                             WithOneofPickOneC y+                               -> (HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 3)+                                     (Hs.coerce @(Hs.Maybe TestProtoOneofImport.AMessage)+                                        @(HsProtobuf.Nested TestProtoOneofImport.AMessage)+                                        (Hs.Just y)))])         decodeMessage _           = (Hs.pure WithOneof) <*>               (HsProtobuf.oneof Hs.Nothing@@ -57,16 +143,22 @@                      HsProtobuf.decodeMessageField),                   ((HsProtobuf.FieldNumber 2),                    (Hs.pure (Hs.Just Hs.. WithOneofPickOneB)) <*>-                     HsProtobuf.decodeMessageField)])+                     HsProtobuf.decodeMessageField),+                  ((HsProtobuf.FieldNumber 3),+                   (Hs.pure (Hs.fmap WithOneofPickOneC)) <*>+                     (Hs.coerce @(_ (HsProtobuf.Nested TestProtoOneofImport.AMessage))+                        @(_ (Hs.Maybe TestProtoOneofImport.AMessage))+                        HsProtobuf.decodeMessageField))])         dotProto _ = []   instance HsJSONPB.ToJSONPB WithOneof where-        toJSONPB (WithOneof f1_or_f2)+        toJSONPB (WithOneof f1_or_f2_or_f3)           = (HsJSONPB.object                [(let encodePickOne-                       = (case f1_or_f2 of+                       = (case f1_or_f2_or_f3 of                               Hs.Just (WithOneofPickOneA f1) -> (HsJSONPB.pair "a" f1)                               Hs.Just (WithOneofPickOneB f2) -> (HsJSONPB.pair "b" f2)+                              Hs.Just (WithOneofPickOneC f3) -> (HsJSONPB.pair "c" f3)                               Hs.Nothing -> Hs.mempty)                    in                    \ options ->@@ -74,12 +166,13 @@                        ("pickOne" .= (HsJSONPB.objectOrNull [encodePickOne] options))                          options                        else encodePickOne options)])-        toEncodingPB (WithOneof f1_or_f2)+        toEncodingPB (WithOneof f1_or_f2_or_f3)           = (HsJSONPB.pairs                [(let encodePickOne-                       = (case f1_or_f2 of+                       = (case f1_or_f2_or_f3 of                               Hs.Just (WithOneofPickOneA f1) -> (HsJSONPB.pair "a" f1)                               Hs.Just (WithOneofPickOneB f2) -> (HsJSONPB.pair "b" f2)+                              Hs.Just (WithOneofPickOneC f3) -> (HsJSONPB.pair "c" f3)                               Hs.Nothing -> Hs.mempty)                    in                    \ options ->@@ -99,6 +192,8 @@                                   (HsJSONPB.parseField parseObj "a"),                                 Hs.Just Hs.. WithOneofPickOneB <$>                                   (HsJSONPB.parseField parseObj "b"),+                                Hs.Just Hs.. WithOneofPickOneC <$>+                                  (HsJSONPB.parseField parseObj "c"),                                 Hs.pure Hs.Nothing]                        in                        ((obj .: "pickOne") Hs.>>=@@ -128,13 +223,10 @@                                                      HsJSONPB.insOrdFromList                                                        [("pickOne", withOneofPickOne)]}})  -instance HsDhallPb.Interpret WithOneof- -instance HsDhallPb.Inject WithOneof-  data WithOneofPickOne = WithOneofPickOneA Hs.Text                       | WithOneofPickOneB Hs.Int32-                      deriving (Hs.Show, Hs.Eq, Hs.Ord, Hs.Generic)+                      | WithOneofPickOneC TestProtoOneofImport.AMessage+                      deriving (Hs.Show, Hs.Eq, Hs.Ord, Hs.Generic, Hs.NFData)   instance HsProtobuf.Named WithOneofPickOne where         nameOf _ = (Hs.fromString "WithOneofPickOne")@@ -147,6 +239,9 @@                let declare_b = HsJSONPB.declareSchemaRef                withOneofPickOneB <- declare_b Proxy.Proxy                let _ = Hs.pure WithOneofPickOneB <*> HsJSONPB.asProxy declare_b+               let declare_c = HsJSONPB.declareSchemaRef+               withOneofPickOneC <- declare_c Proxy.Proxy+               let _ = Hs.pure WithOneofPickOneC <*> HsJSONPB.asProxy declare_c                Hs.return                  (HsJSONPB.NamedSchema{HsJSONPB._namedSchemaName =                                          Hs.Just "WithOneofPickOne",@@ -157,10 +252,7 @@                                                    HsJSONPB._schemaProperties =                                                      HsJSONPB.insOrdFromList                                                        [("a", withOneofPickOneA),-                                                        ("b", withOneofPickOneB)],+                                                        ("b", withOneofPickOneB),+                                                        ("c", withOneofPickOneC)],                                                    HsJSONPB._schemaMinProperties = Hs.Just 1,                                                    HsJSONPB._schemaMaxProperties = Hs.Just 1}})- -instance HsDhallPb.Interpret WithOneofPickOne- -instance HsDhallPb.Inject WithOneofPickOne

@@ -1,5 +1,5 @@ name:                proto3-suite-version:             0.3.0.0+version:             0.4.0.0 synopsis:            A low level library for writing out data in the Protocol Buffers wire format license:             Apache-2.0 author:              Awake Security@@ -27,6 +27,7 @@                        Proto3.Suite.DotProto                        Proto3.Suite.DotProto.Generate                        Proto3.Suite.DotProto.AST+                       Proto3.Suite.DotProto.AST.Lens                        Proto3.Suite.DotProto.Parsing                        Proto3.Suite.DotProto.Rendering                        Proto3.Suite.JSONPB@@ -59,12 +60,12 @@                        parsers >= 0.12 && <0.13,                        pretty ==1.1.*,                        pretty-show >= 1.6.12 && < 2.0,-                       proto3-wire == 1.0.*,-                       QuickCheck >=2.10 && <2.13,+                       proto3-wire == 1.1.*,+                       QuickCheck >=2.10 && <2.14,                        quickcheck-instances < 0.4,                        safe ==0.3.*,                        semigroups ==0.18.*,-                       swagger2 >=2.1.6 && <2.4,+                       swagger2 >=2.1.6 && <2.5,                        system-filepath,                        text >= 0.2 && <1.3,                        transformers >=0.4 && <0.6,@@ -94,7 +95,7 @@   hs-source-dirs:      tests gen   default-language:    Haskell2010   build-depends:       base >=4.8 && <5.0,-                       QuickCheck >=2.10 && <2.13,+                       QuickCheck >=2.10 && <2.14,                        aeson >= 1.1.1.0 && < 1.5,                        attoparsec >= 0.13.0.1,                        base >=4.8 && <5.0,@@ -102,10 +103,13 @@                        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.0.*,+                       proto3-wire == 1.1.*,                        semigroups ==0.18.*,                        swagger2,                        tasty >= 0.11 && <1.2,@@ -122,7 +126,7 @@   hs-source-dirs:      tools/compile-proto-file   default-language:    Haskell2010   build-depends:       base >=4.8 && <5.0-                       , optparse-generic+                       , optparse-applicative                        , proto3-suite                        , system-filepath                        , text@@ -135,9 +139,10 @@   default-language:    Haskell2010   build-depends:       base >=4.8 && <5.0                        , containers >=0.5 && <0.7+                       , mtl ==2.2.*                        , optparse-generic                        , proto3-suite-                       , proto3-wire == 1.0.*+                       , proto3-wire == 1.1.*                        , range-set-list >=0.1.2 && <0.2                        , system-filepath                        , turtle

@@ -97,6 +97,7 @@ import qualified Data.ByteString.Base64 as B64 import qualified Data.ByteString.Lazy   as BL import           Data.Coerce            (coerce)+import qualified Data.Foldable          as Foldable import           Data.Functor           (($>)) import           Data.Int               (Int32, Int64) import qualified Data.Map               as M@@ -115,20 +116,19 @@ 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 import qualified Proto3.Wire.Encode     as Encode-import           Safe                   (toEnumMay)  -- | A class for types with default values per the protocol buffers spec. class HasDefault a where   -- | The default value for this type.   def :: a -  -- | Numeric types default to zero-  default def :: Num a => a-  def = 0+  default def :: (Generic a, GenericHasDefault (Rep a)) => a+  def = to (genericDef @(Rep a))    isDefault :: a -> Bool @@ -145,19 +145,29 @@   | isDefault p = mempty   | otherwise = f p -instance HasDefault Int32-instance HasDefault Int64-instance HasDefault Word32-instance HasDefault Word64-instance HasDefault (Signed Int32)-instance HasDefault (Signed Int64)-instance HasDefault (Fixed Word32)-instance HasDefault (Fixed Word64)-instance HasDefault (Signed (Fixed Int32))-instance HasDefault (Signed (Fixed Int64))-instance HasDefault Float-instance HasDefault Double+-- -- | Numeric types default to zero+-- instance Num a => HasDefault a where def = 0 +instance HasDefault Int where def = 0+instance HasDefault Integer where def = 0++instance HasDefault Int32 where def = 0+instance HasDefault Int64 where def = 0+instance HasDefault Word32 where def = 0+instance HasDefault Word64 where def = 0+instance HasDefault (Signed Int32) where def = 0+instance HasDefault (Signed Int64) where def = 0+-- | Used in generated records to represent @sfixed32@+instance HasDefault (Fixed Int32) where def = 0+-- | Used in generated records to represent @sfixed64@+instance HasDefault (Fixed Int64) where def = 0+instance HasDefault (Fixed Word32) where def = 0+instance HasDefault (Fixed Word64) where def = 0+instance HasDefault (Signed (Fixed Int32)) where def = 0+instance HasDefault (Signed (Fixed Int64)) where def = 0+instance HasDefault Float where def = 0+instance HasDefault Double where def = 0+ instance HasDefault Bool where   def = False @@ -173,12 +183,9 @@ instance HasDefault BL.ByteString where   def = mempty -instance (Bounded e, Enum e) => HasDefault (Enumerated e) where-  def =-    case toEnumMay 0 of-      Nothing -> Enumerated (Left 0)-      Just x -> Enumerated (Right x)-  isDefault = (== 0) . either id fromEnum . enumerated+instance ProtoEnum e => HasDefault (Enumerated e) where+  def = Enumerated $ maybe (Left 0) Right (toProtoEnumMay 0)+  isDefault = (== 0) . either id fromProtoEnum . enumerated  instance HasDefault (UnpackedVec a) where   def = mempty@@ -215,20 +222,22 @@   def = M.empty   isDefault = M.null --- TODO: Determine if we have a reason for rendering fixed32/sfixed as Fixed--- Word32/Int32 in generated datatypes; for other field types, we omit the--- newtype wrappers in the type signature but un/wrap them as needed in the--- encode/decodeMessage implementations. These Fixed wrappers can probably be--- removed and the type interface would be more consistent with other types, but--- until that occurs, the following two instances are needed.------ Tracked by https://github.com/awakesecurity/proto3-suite/issues/30.---- | Used in generated records to represent @sfixed32@-instance HasDefault (Fixed Int32)---- | Used in generated records to represent @sfixed64@-instance HasDefault (Fixed Int64)+class GenericHasDefault (f :: * -> *) where+  genericDef :: f x+instance HasDefault f => GenericHasDefault (K1 i f) where+  genericDef = K1 (def @f)+instance (GenericHasDefault f, GenericHasDefault g) => GenericHasDefault (f :*: g) where+  genericDef = genericDef @f :*: genericDef @g+instance (GenericHasDefault f, GenericHasDefault g) => GenericHasDefault (f :+: g) where+  genericDef = L1 (genericDef @f)+instance GenericHasDefault U1 where+  genericDef = U1 -- unit constructor+instance (Constructor i, GenericHasDefault f) => GenericHasDefault (C1 i f) where+  genericDef = M1 (genericDef @f)+instance (Datatype i, GenericHasDefault f) => GenericHasDefault (D1 i f) where+  genericDef = M1 (genericDef @f)+instance (Selector i, GenericHasDefault f) => GenericHasDefault (S1 i f) where+  genericDef = M1 (genericDef @f)  -- | This class captures those types whose names need to appear in .proto files. --@@ -251,46 +260,44 @@ -- -- This class can be derived whenever a sum type is an instance of 'Generic', -- and only consists of zero-argument constructors. The derived instance should--- be compatible with derived `Enum` instances, in the sense that+-- be compatible with `ProtoEnum` instances, in the sense that ----- > map (toEnum . fst) enumerate+-- > map (fromJust . toProtoEnumMay . snd) enumerate -- -- should enumerate all values of the type without runtime errors.-class Enum a => Finite a where+class ProtoEnum a => Finite a where   -- | Enumerate values of a finite type, along with names of constructors.-  enumerate :: IsString string => Proxy# a -> [(string, Int)]+  enumerate :: IsString string => Proxy# a -> [(string, Int32)] -  default enumerate :: (IsString string, GenericFinite (Rep a))-                    => Proxy# a -> [(string, Int)]-  enumerate _ = snd (genericEnumerate (proxy# :: Proxy# (Rep a)) 0)+  default enumerate ::+    (IsString string, Generic a, GenericFinite (Rep a)) =>+    Proxy# a -> [(string, Int32)]+  enumerate _ =+    fmap (fromProtoEnum . (to :: Rep a p -> a)) <$> genericEnumerate  -- | Generate metadata for an enum type. enum :: (Finite e, Named e) => Proxy# e -> DotProtoDefinition-enum pr = DotProtoEnum (Single $ nameOf pr) (map enumField $ enumerate pr)+enum pr = DotProtoEnum "" (Single $ nameOf pr) (map enumField $ enumerate pr)   where     enumField (name, value) = DotProtoEnumField (Single name) value []  class GenericFinite (f :: * -> *) where-  genericEnumerate :: IsString string => Proxy# f -> Int -> (Int, [(string, Int)])+  genericEnumerate :: IsString string => [(string, f p)]  instance ( GenericFinite f          , GenericFinite g          ) => GenericFinite (f :+: g) where-  genericEnumerate _ i =-    let (j, e1) = genericEnumerate (proxy# :: Proxy# f) i-        (k, e2) = genericEnumerate (proxy# :: Proxy# g) j-    in (k, e1 <> e2)+  genericEnumerate =+    (fmap L1 <$> genericEnumerate) <>+    (fmap R1 <$> genericEnumerate) -instance Constructor c => GenericFinite (M1 C c f) where-  genericEnumerate _ i = (i + 1, [ (fromString name, i) ])+instance Constructor c => GenericFinite (M1 C c U1) where+  genericEnumerate = [ (fromString name, M1 U1) ]     where       name = conName (undefined :: M1 C c f ())  instance GenericFinite f => GenericFinite (M1 D t f) where-  genericEnumerate _ = genericEnumerate (proxy# :: Proxy# f)--instance GenericFinite f => GenericFinite (M1 S t f) where-  genericEnumerate _ = genericEnumerate (proxy# :: Proxy# f)+  genericEnumerate = fmap M1 <$> genericEnumerate  -- | This class captures those types which correspond to primitives in -- the protocol buffers specification.@@ -373,7 +380,7 @@   primType _ = SFixed64  instance Primitive Bool where-  encodePrimitive = Encode.enum+  encodePrimitive = Encode.bool   decodePrimitive = Decode.bool   primType _ = Bool @@ -407,11 +414,12 @@   decodePrimitive = Decode.lazyByteString   primType _ = Bytes -instance forall e. (Bounded e, Named e, Enum e) => Primitive (Enumerated e) where-  encodePrimitive num = Encode.enum num . enumify . enumerated-    where enumify (Left i) = i-          enumify (Right x) = fromEnum x-  decodePrimitive = coerce @(Parser RawPrimitive (Either Int e)) @(Parser RawPrimitive (Enumerated e)) Decode.enum+instance forall e. (Named e, ProtoEnum e) => Primitive (Enumerated e) where+  encodePrimitive num = either (Encode.int32 num) (Encode.enum num) . enumerated+  decodePrimitive = coerce+    @(Parser RawPrimitive (Either Int32 e))+    @(Parser RawPrimitive (Enumerated e))+    Decode.enum   primType _ = Named (Single (nameOf (proxy# :: Proxy# e)))  instance (Primitive a) => Primitive (ForceEmit a) where@@ -448,7 +456,7 @@     , dotProtoFieldType = ty     , dotProtoFieldName = Anonymous     , dotProtoFieldOptions = packingOption-    , dotProtoFieldComment = Nothing+    , dotProtoFieldComment = ""     }   where     packingOption = maybe [] (toDotProtoOption . isPacked) packing@@ -475,7 +483,7 @@ instance MessageField TL.Text instance MessageField B.ByteString instance MessageField BL.ByteString-instance (Bounded e, Named e, Enum e) => MessageField (Enumerated e)+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   encodeMessageField num = foldMap (Encode.embedded num . encodeMessage (fieldNumber 1)) . M.toList@@ -484,7 +492,7 @@   --   -- > When parsing from the wire or when merging, if there are duplicate map   -- > keys the last key seen is used.-  decodeMessageField = M.fromList . fromList+  decodeMessageField = M.fromList . Foldable.toList                        <$> repeated (Decode.embedded' (decodeMessage (fieldNumber 1)))   protoType _ = messageField (Map (primType (proxy# :: Proxy# k)) (primType (proxy# :: Proxy# v))) Nothing @@ -495,7 +503,7 @@   --   -- > When parsing from the wire or when merging, if there are duplicate map   -- > keys the last key seen is used.-  decodeMessageField = M.fromList . fromList+  decodeMessageField = M.fromList . Foldable.toList                        <$> repeated (Decode.embedded' (decodeMessage (fieldNumber 1)))   protoType _ = messageField (Map (primType (proxy# :: Proxy# k)) (Named . Single $ nameOf (proxy# :: Proxy# v))) Nothing @@ -511,30 +519,32 @@  instance Primitive a => MessageField (UnpackedVec a) where   encodeMessageField = foldMap . encodePrimitive-  decodeMessageField = UnpackedVec . fromList <$> repeated decodePrimitive+  decodeMessageField =+    UnpackedVec . fromList . Foldable.toList <$> repeated decodePrimitive   protoType _ = messageField (Repeated $ primType (proxy# :: Proxy# a)) (Just DotProto.UnpackedField)  instance forall a. (Named a, Message a) => MessageField (NestedVec a) where   encodeMessageField fn = foldMap (Encode.embedded fn . encodeMessage (fieldNumber 1))                           . coerce @(NestedVec a) @(Vector a)-  decodeMessageField = fmap (coerce @(Vector a) @(NestedVec a) . fromList)-                            (repeated (Decode.embedded' oneMsg))+  decodeMessageField =+      fmap (coerce @(Vector a) @(NestedVec a) . fromList . Foldable.toList)+           (repeated (Decode.embedded' oneMsg))     where       oneMsg :: Parser RawMessage a       oneMsg = decodeMessage (fieldNumber 1)   protoType _ = messageField (NestedRepeated . Named . Single $ nameOf (proxy# :: Proxy# a)) Nothing -instance (Bounded e, Enum e, Named e) => MessageField (PackedVec (Enumerated e)) where+instance (Named e, ProtoEnum e) => MessageField (PackedVec (Enumerated e)) where   encodeMessageField fn = omittingDefault (Encode.packedVarints fn) . foldMap omit     where       -- omit values which are outside the enum range       omit :: Enumerated e -> PackedVec Word64-      omit (Enumerated (Right e)) = pure . fromIntegral . fromEnum $ e+      omit (Enumerated (Right e)) = pure . fromIntegral . fromProtoEnum $ e       omit _                      = mempty   decodeMessageField = decodePacked (foldMap retain <$> Decode.packedVarints @Word64)     where       -- retain only those values which are inside the enum range-      retain = foldMap (pure . Enumerated. Right) . toEnumMay . fromIntegral+      retain = foldMap (pure . Enumerated . Right) . toProtoEnumMay . fromIntegral   protoType _ = messageField (Repeated . Named . Single $ nameOf (proxy# :: Proxy# e)) (Just DotProto.PackedField)  instance MessageField (PackedVec Bool) where@@ -613,7 +623,7 @@                               @(Parser RawField (Commented comments e))                               decodeMessageField   protoType p = (protoType (lowerProxy1 p))-                  { dotProtoFieldComment = Just (symbolVal (lowerProxy2 p)) }+                  { dotProtoFieldComment = symbolVal (lowerProxy2 p) }     where       lowerProxy1 :: forall f (a :: k). Proxy# (f a) -> Proxy# a       lowerProxy1 _ = proxy#@@ -625,7 +635,7 @@   :: Parser RawPrimitive [a]   -> Parser RawField (PackedVec a) decodePacked = Parser-             . fmap (fmap pack)+             . fmap (fmap (pack . Foldable.toList))              . TR.traverse              . runParser   where@@ -658,7 +668,8 @@  -- | Generate metadata for a message type. message :: (Message a, Named a) => Proxy# a -> DotProtoDefinition-message proxy = DotProtoMessage (Single $ nameOf proxy)+message proxy = DotProtoMessage ""+                                (Single $ nameOf proxy)                                 (DotProtoMessageField <$> dotProto proxy)  -- * Generic Instances

@@ -28,7 +28,7 @@  instance Dhall.Interpret a => Dhall.Interpret (Enumerated a) -instance Dhall.Interpret a => Dhall.Interpret (Either Int a)+instance Dhall.Interpret a => Dhall.Interpret (Either Int32 a)  -------------------------------------------------------------------------------- -- Interpret the strict and lazy ByteString types@@ -114,7 +114,7 @@  instance Dhall.Inject a => Dhall.Inject (Enumerated a) -instance Dhall.Inject a => Dhall.Inject (Either Int a)+instance Dhall.Inject a => Dhall.Inject (Either Int32 a)  -------------------------------------------------------------------------------- -- Inject integer scalar types

@@ -3,3 +3,5 @@ import Proto3.Suite.DotProto.AST       as M import Proto3.Suite.DotProto.Parsing   as M import Proto3.Suite.DotProto.Rendering as M+-- exported for testing+import Proto3.Suite.DotProto.Internal  as M (fieldLikeName, prefixedEnumFieldName, typeLikeName)

@@ -1,6 +1,7 @@ -- | Fairly straightforward AST encoding of the .proto grammar  {-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase                 #-} {-# LANGUAGE RecordWildCards            #-}  module Proto3.Suite.DotProto.AST@@ -19,17 +20,22 @@     , DotProtoValue(..)     , DotProtoPrimType(..)     , Packing(..)-    , Path(..)+    , Path(..), fakePath     , DotProtoType(..)     , DotProtoEnumValue     , DotProtoEnumPart(..)     , Streaming(..)     , DotProtoServicePart(..)+    , RPCMethod(..)     , DotProtoMessagePart(..)     , DotProtoField(..)     , DotProtoReservedField(..)   ) where +import           Control.Applicative+import           Control.Monad+import           Data.Int                  (Int32)+import qualified Data.List.NonEmpty        as NE import           Data.String               (IsString) import qualified Filesystem.Path.CurrentOS as FP import           Numeric.Natural@@ -63,8 +69,12 @@ instance Show PackageName where   show = show . getPackageName -newtype Path = Path { components :: [String] } deriving (Show, Eq, Ord)+newtype Path = Path { components :: NE.NonEmpty String } deriving (Show, Eq, Ord) +-- Used for testing+fakePath :: Path+fakePath = Path ("fakePath" NE.:| [])+ data DotProtoIdentifier   = Single String   | Dots   Path@@ -127,23 +137,26 @@  -- | Top-level protocol definitions data DotProtoDefinition-  = DotProtoMessage DotProtoIdentifier [DotProtoMessagePart]-  | DotProtoEnum    DotProtoIdentifier [DotProtoEnumPart]-  | DotProtoService DotProtoIdentifier [DotProtoServicePart]+  = DotProtoMessage String DotProtoIdentifier [DotProtoMessagePart]+  | DotProtoEnum    String DotProtoIdentifier [DotProtoEnumPart]+  | DotProtoService String DotProtoIdentifier [DotProtoServicePart]   deriving (Show, Eq) + instance Arbitrary DotProtoDefinition where   arbitrary = oneof [arbitraryMessage, arbitraryEnum]     where       arbitraryMessage = do+        comment    <- pure mempty  -- until parser supports comments         identifier <- arbitrarySingleIdentifier         parts      <- smallListOf arbitrary-        return (DotProtoMessage identifier parts)+        return (DotProtoMessage comment identifier parts)        arbitraryEnum = do+        comment    <- pure mempty  -- until parser supports comments         identifier <- arbitrarySingleIdentifier         parts      <- smallListOf arbitrary-        return (DotProtoEnum identifier parts)+        return (DotProtoEnum comment identifier parts)  -- | Tracks misc metadata about the AST data DotProtoMeta = DotProtoMeta@@ -158,7 +171,7 @@   } deriving (Show, Eq)  instance Arbitrary DotProtoMeta where-  arbitrary = pure . DotProtoMeta . Path $ []+  arbitrary = pure (DotProtoMeta fakePath)  -- | This data structure represents a .proto file --   The actual source order of protobuf statements isn't meaningful so@@ -264,7 +277,7 @@ instance Arbitrary DotProtoType where   arbitrary = oneof [fmap Prim arbitrary] -type DotProtoEnumValue = Int+type DotProtoEnumValue = Int32  data DotProtoEnumPart   = DotProtoEnumField DotProtoIdentifier DotProtoEnumValue [DotProtoOption]@@ -293,45 +306,40 @@ instance Arbitrary Streaming where   arbitrary = elements [Streaming, NonStreaming] --- [refactor] add named accessors to ServiceRPC---            break this into two types data DotProtoServicePart-  = DotProtoServiceRPC    DotProtoIdentifier-                          (DotProtoIdentifier, Streaming)-                          (DotProtoIdentifier, Streaming)-                          [DotProtoOption]+  = DotProtoServiceRPCMethod RPCMethod   | DotProtoServiceOption DotProtoOption   | DotProtoServiceEmpty   deriving (Show, Eq)  instance Arbitrary DotProtoServicePart where   arbitrary = oneof-    [ arbitraryServiceRPC-    , arbitraryServiceOption+    [ DotProtoServiceRPCMethod <$> arbitrary+    , DotProtoServiceOption <$> arbitrary     ]-    where-      arbitraryServiceRPC = do-        identifier <- arbitrarySingleIdentifier-        rpcClause0 <- arbitraryRPCClause-        rpcClause1 <- arbitraryRPCClause-        options    <- smallListOf arbitrary-        return (DotProtoServiceRPC identifier rpcClause0 rpcClause1 options)-        where-          arbitraryRPCClause = do-            identifier <- arbitraryIdentifier-            streaming  <- arbitrary-            return (identifier, streaming) -      arbitraryServiceOption = do-        option <- arbitrary-        return (DotProtoServiceOption option)+data RPCMethod = RPCMethod+  { rpcMethodName :: DotProtoIdentifier+  , rpcMethodRequestType :: DotProtoIdentifier+  , rpcMethodRequestStreaming :: Streaming+  , rpcMethodResponseType :: DotProtoIdentifier+  , rpcMethodResponseStreaming :: Streaming+  , rpcMethodOptions :: [DotProtoOption]+  } deriving (Show, Eq) +instance Arbitrary RPCMethod where+  arbitrary = do+    rpcMethodName <- arbitrarySingleIdentifier+    rpcMethodRequestType <- arbitraryIdentifier+    rpcMethodRequestStreaming  <- arbitrary+    rpcMethodResponseType <- arbitraryIdentifier+    rpcMethodResponseStreaming  <- arbitrary+    rpcMethodOptions <- smallListOf arbitrary+    return RPCMethod{..}+ data DotProtoMessagePart   = DotProtoMessageField DotProtoField-  | DotProtoMessageOneOf-      { dotProtoOneOfName   :: DotProtoIdentifier-      , dotProtoOneOfFields :: [DotProtoField]-      }+  | DotProtoMessageOneOf DotProtoIdentifier [DotProtoField]   | DotProtoMessageDefinition DotProtoDefinition   | DotProtoMessageReserved   [DotProtoReservedField]   deriving (Show, Eq)@@ -349,9 +357,9 @@         return (DotProtoMessageField field)        arbitraryOneOf = do-        dotProtoOneOfName   <- arbitrarySingleIdentifier-        dotProtoOneOfFields <- smallListOf arbitrary-        return (DotProtoMessageOneOf {..})+        name   <- arbitrarySingleIdentifier+        fields <- smallListOf arbitrary+        return (DotProtoMessageOneOf name fields)        arbitraryDefinition = do         definition <- arbitrary@@ -369,7 +377,7 @@   , dotProtoFieldType    :: DotProtoType   , dotProtoFieldName    :: DotProtoIdentifier   , dotProtoFieldOptions :: [DotProtoOption]-  , dotProtoFieldComment :: Maybe String+  , dotProtoFieldComment :: String   }   | DotProtoEmptyField   deriving (Show, Eq)@@ -381,7 +389,7 @@     dotProtoFieldName    <- arbitraryIdentifier     dotProtoFieldOptions <- smallListOf arbitrary     -- TODO: Generate random comments once the parser supports comments-    dotProtoFieldComment <- pure Nothing+    dotProtoFieldComment <- pure mempty     return (DotProtoField {..})  data DotProtoReservedField@@ -412,9 +420,10 @@  _arbitraryService :: Gen DotProtoDefinition _arbitraryService = do+  comment    <- pure mempty  -- until parser supports comments   identifier <- arbitrarySingleIdentifier   parts      <- smallListOf arbitrary-  return (DotProtoService identifier parts)+  return (DotProtoService comment identifier parts)  arbitraryIdentifierName :: Gen String arbitraryIdentifierName = do@@ -429,7 +438,7 @@ arbitraryPathIdentifier = do   name  <- arbitraryIdentifierName   names <- smallListOf1 arbitraryIdentifierName-  pure . Dots . Path $ name:names+  pure . Dots . Path $ name NE.:| names  arbitraryNestedIdentifier :: Gen DotProtoIdentifier arbitraryNestedIdentifier = do

@@ -0,0 +1,9 @@+{-# LANGUAGE TemplateHaskell            #-}+module Proto3.Suite.DotProto.AST.Lens where++import Control.Lens.TH+import Proto3.Suite.DotProto.AST++makePrisms ''DotProtoDefinition+makePrisms ''DotProtoMessagePart+

@@ -1,2150 +1,1818 @@-{-# LANGUAGE CPP               #-}-{-# LANGUAGE FlexibleContexts  #-}-{-# LANGUAGE LambdaCase        #-}-{-# LANGUAGE MultiWayIf        #-}-{-# LANGUAGE NamedFieldPuns    #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE QuasiQuotes       #-}-{-# LANGUAGE RecordWildCards   #-}-{-# LANGUAGE TupleSections     #-}-{-# LANGUAGE ViewPatterns      #-}--{-| This module provides functions to generate Haskell declarations for protobuf-    messages--}--module Proto3.Suite.DotProto.Generate-  ( CompileError(..)-  , TypeContext--  , compileDotProtoFile-  , compileDotProtoFileOrDie-  , hsModuleForDotProto-  , renderHsModuleForDotProto-  , readDotProtoWithContext--  -- * Utilities-  , isPackable--  -- * Exposed for unit-testing-  , fieldLikeName-  , prefixedEnumFieldName-  , typeLikeName-  ) where--import           Control.Applicative-import           Control.Arrow                  ((&&&))-import           Control.Monad.Except-import           Control.Lens                   (ix, over)-import           Data.Bifunctor                 (first)-import           Data.Char-import           Data.Coerce-import           Data.Either                    (partitionEithers)-import           Data.List                      (find, intercalate, nub, sortBy,-                                                 stripPrefix)-import qualified Data.Map                       as M-import           Data.Maybe                     (catMaybes, fromMaybe)-import           Data.Monoid-import           Data.Ord                       (comparing)-import qualified Data.Set                       as S-import           Data.String                    (fromString)-import qualified Data.Text                      as T-import           Filesystem.Path.CurrentOS      ((</>), (<.>))-import qualified Filesystem.Path.CurrentOS      as FP-import           Language.Haskell.Pretty-import           Language.Haskell.Syntax-import           Language.Haskell.Parser        (ParseResult(..), parseModule)-import qualified NeatInterpolation              as Neat-import           Prelude                        hiding (FilePath)-import           Proto3.Suite.DotProto-import           Proto3.Suite.DotProto.Rendering (Pretty(..))-import           Proto3.Suite.DotProto.Internal-import           Proto3.Wire.Types              (FieldNumber (..))-import           System.IO                      (writeFile, readFile)-import           Text.Parsec                    (ParseError)-import           Turtle                         (FilePath)-import qualified Turtle-import           Turtle.Format                  ((%))-import qualified Turtle.Format                  as F---- * Public interface--data CompileError-  = CircularImport          FilePath-  | CompileParseError       ParseError-  | InternalEmptyModulePath-  | InternalError           String-  | InvalidMethodName       DotProtoIdentifier-  | InvalidTypeName         String-  | InvalidMapKeyType       String-  | NoPackageDeclaration-  | NoSuchType              DotProtoIdentifier-  | Unimplemented           String-  deriving (Show, Eq)--#if !(MIN_VERSION_mtl(2,2,2))-liftEither :: MonadError e m => Either e a -> m a-liftEither x =-    case x of-        Left  e -> throwError e-        Right a -> return a-#endif---- | Generate a Haskell module corresponding to a @.proto@ file-compileDotProtoFile-    :: [FilePath]-    -- ^ Haskell modules containing instances used to override default generated-    -- instances-    -> FilePath-    -- ^ Output directory-    -> [FilePath]-    -- ^ List of search paths-    -> FilePath-    -- ^ Path to @.proto@ file (relative to search path)-    -> IO (Either CompileError ())-compileDotProtoFile-  extraInstanceFiles-  outputDirectory-  searchPaths-  dotProtoPath = runExceptT $ do-    (dotProto, importTypeContext) <- do-      ExceptT (readDotProtoWithContext searchPaths dotProtoPath)--    let DotProto     { protoMeta      } = dotProto-    let DotProtoMeta { metaModulePath } = protoMeta-    let Path         { components     } = metaModulePath--    when (null components) (throwError InternalEmptyModulePath)--    typeLikeComponents <- traverse typeLikeName components--    let relativePath = FP.concat (map fromString typeLikeComponents) <.> "hs"-    let modulePath   = outputDirectory </> relativePath--    Turtle.mktree (Turtle.directory modulePath)--    listOfExtraInstances <- traverse getExtraInstances extraInstanceFiles--    let extraInstances = mconcat listOfExtraInstances--    haskellModule <- do-      renderHsModuleForDotProto extraInstances dotProto importTypeContext--    liftIO (writeFile (FP.encodeString modulePath) haskellModule)---- | As 'compileDotProtoFile', except terminates the program with an error--- message on failure.-compileDotProtoFileOrDie-    :: [FilePath]-    -- ^ Haskell modules containing instances used to override default generated-    -- instances-    -> FilePath-    -- ^ Output directory-    -> [FilePath]-    -- ^ List of search paths-    -> FilePath-    -- ^ Path to @.proto@ file (relative to search path)-    -> IO ()-compileDotProtoFileOrDie-  extraInstanceFiles-  outputDirectory-  searchPaths-  dotProtoPath = do-  compileResult <- do-    compileDotProtoFile-      extraInstanceFiles-      outputDirectory-      searchPaths-      dotProtoPath--  case compileResult of-    Left e -> do-      -- TODO: pretty print the error messages-      let errText          = Turtle.format Turtle.w  e-      let dotProtoPathText = Turtle.format Turtle.fp dotProtoPath-      dieLines [Neat.text|-        Error: failed to compile "${dotProtoPathText}":--        ${errText}-      |]-    _ -> pure ()--getExtraInstances-    :: (MonadIO m, MonadError CompileError m)-    => FilePath -> m ([HsImportDecl], [HsDecl])-getExtraInstances extraInstanceFile = do-  let extraInstanceFileString = FP.encodeString extraInstanceFile--  parseRes <- parseModule <$> liftIO (readFile extraInstanceFileString)--  case parseRes 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)---- | 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-    => ([HsImportDecl],[HsDecl]) -> DotProto -> TypeContext -> m String-renderHsModuleForDotProto extraInstanceFiles dotProto importCtxt = do-    haskellModule <- hsModuleForDotProto extraInstanceFiles dotProto importCtxt-    return (T.unpack header ++ prettyPrint haskellModule)-  where-    header = [Neat.text|-      {-# 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 #-}--      -- | Generated by Haskell protocol buffer compiler. DO NOT EDIT!-    |]---- | Compile a Haskell module AST given a 'DotProto' package AST.--- Instances given in @eis@ override those otherwise generated.-hsModuleForDotProto-    :: MonadError CompileError m-    => ([HsImportDecl], [HsDecl])-    -- ^ Extra user-define instances that override default generated instances-    -> DotProto-    -- ^-    -> TypeContext-    -- ^-    -> m HsModule-hsModuleForDotProto-    _-    DotProto { protoMeta = DotProtoMeta { metaModulePath = Path [] } }-    _ =-    throwError InternalEmptyModulePath-hsModuleForDotProto-  (extraImports, extraInstances)-  dotProto@DotProto-    { protoPackage     = DotProtoPackageSpec packageIdentifier-    , protoMeta        = DotProtoMeta { metaModulePath = modulePath }-    , protoDefinitions-    }-  importTypeContext = do-    moduleName <- modulePathModName modulePath--    typeContextImports <- ctxtImports importTypeContext--    let importDeclarations =-          concat [ defaultImports hasService, extraImports, typeContextImports ]--    typeContext <- dotProtoTypeContext dotProto--    let toDotProtoDeclaration =-          dotProtoDefinitionD packageIdentifier (typeContext <> importTypeContext)--    let instances = instancesForModule moduleName extraInstances--    listOfDeclarations <- traverse toDotProtoDeclaration protoDefinitions--    let overridenDeclarations =-          replaceHsInstDecls instances (mconcat listOfDeclarations)--    return (module_ moduleName Nothing importDeclarations overridenDeclarations)-  where-    hasService = not (null [ () | DotProtoService {} <- protoDefinitions ])--hsModuleForDotProto _ _ _ =-  throwError NoPackageDeclaration---- 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 (filtered,customized) = partitionEithers (map (deriv tyn) insts)-            in HsDataDecl loc ctx tyn names def filtered : 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-    :: [FilePath]-    -> FilePath-    -> IO (Either CompileError (DotProto, TypeContext))-readDotProtoWithContext [] dotProtoPath = do-  -- If we're not given a search path, default to using the current working-  -- directory, as `protoc` does-  cwd <- Turtle.pwd-  readDotProtoWithContext [cwd] dotProtoPath--readDotProtoWithContext searchPaths toplevelProto = runExceptT $ do-  findProto searchPaths toplevelProto >>= \case-    Found mp fp     -> parse mp fp-    BadModulePath e -> fatalBadModulePath toplevelProto e-    NotFound        -> dieLines [Neat.text|-      Error: failed to find file "${toplevelProtoText}", after looking in-      the following locations (controlled via the --includeDir switch(es)):--      $searchPathsText-    |]-  where-    parse mp fp = parseProtoFile mp fp >>= \case-      Right dp -> do-        let importIt = readImportTypeContext searchPaths toplevelProto (S.singleton toplevelProto)-        tc <- mconcat <$> mapM importIt (protoImports dp)-        pure (dp, tc)-      Left err -> throwError (CompileParseError err)--    searchPathsText   = T.unlines (Turtle.format ("  "%F.fp) . (</> toplevelProto) <$> searchPaths)-    toplevelProtoText = Turtle.format F.fp toplevelProto--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_ <- liftEither . first CompileParseError =<< importProto searchPaths toplevelFP path-         case protoPackage import_ of-           DotProtoPackageSpec importPkg ->-             do importTypeContext <- dotProtoTypeContext import_-                let importTypeContext' = flip fmap importTypeContext $ \tyInfo ->-                      tyInfo { dotProtoTypeInfoPackage    = DotProtoPackageSpec importPkg-                             , dotProtoTypeInfoModulePath = metaModulePath . protoMeta $ import_-                             }-                    qualifiedTypeContext = M.fromList <$>-                        mapM (\(nm, tyInfo) -> (,tyInfo) <$> concatDotProtoIdentifier importPkg nm)-                            (M.assocs importTypeContext')--                importTypeContext'' <- (importTypeContext' <>) <$> qualifiedTypeContext-                (importTypeContext'' <>) . mconcat <$> sequence-                    [ readImportTypeContext searchPaths toplevelFP (S.insert path alreadyRead) importImport-                    | importImport@(DotProtoImport DotProtoImportPublic _) <- protoImports import_-                    ]-           _ -> throwError NoPackageDeclaration---- * Type-tracking data structures---- | Whether a definition is an enumeration or a message-data DotProtoKind = DotProtoKindEnum-                  | DotProtoKindMessage-                  deriving (Show, Eq, Ord, Enum, Bounded)---- | Information about messages and enumerations-data DotProtoTypeInfo = DotProtoTypeInfo-  { dotProtoTypeInfoPackage    :: DotProtoPackageSpec-     -- ^ The package this type is defined in-  , dotProtoTypeInfoParent     :: DotProtoIdentifier-    -- ^ The message this type is nested under, or 'Anonymous' if it's top-level-  , dotProtoTypeChildContext   :: TypeContext-    -- ^ The context that should be used for declarations within the-    --   scope of this type-  , dotProtoTypeInfoKind       :: DotProtoKind-    -- ^ Whether this type is an enumeration or message-  , dotProtoTypeInfoModulePath :: Path-    -- ^ The include-relative module path used when importing this module-  } deriving Show---- | A mapping from .proto type identifiers to their type information-type TypeContext = M.Map DotProtoIdentifier DotProtoTypeInfo---- ** Generating type contexts from ASTs--dotProtoTypeContext :: MonadError CompileError m => DotProto -> m TypeContext-dotProtoTypeContext DotProto { protoDefinitions-                             , protoMeta = DotProtoMeta modulePath-                             }-  = mconcat <$> mapM (definitionTypeContext modulePath) protoDefinitions--definitionTypeContext-    :: MonadError CompileError m => Path -> DotProtoDefinition -> m TypeContext-definitionTypeContext modulePath (DotProtoMessage msgIdent parts) =-    do childTyContext <--          mapM updateDotProtoTypeInfoParent =<<-          (mconcat <$> sequenceA-               [ definitionTypeContext modulePath def-               | DotProtoMessageDefinition def <- parts ])--       qualifiedChildTyContext <- M.fromList <$>-          mapM (\(nm, tyInfo) -> (,tyInfo) <$>-                                 concatDotProtoIdentifier msgIdent nm)-               (M.assocs childTyContext)--       pure (M.singleton msgIdent-                 (DotProtoTypeInfo DotProtoNoPackage Anonymous-                      childTyContext DotProtoKindMessage modulePath) <>-               qualifiedChildTyContext)-  where updateDotProtoTypeInfoParent tyInfo =-            do dotProtoTypeInfoParent <--                     concatDotProtoIdentifier msgIdent (dotProtoTypeInfoParent tyInfo)-               pure tyInfo { dotProtoTypeInfoParent }-definitionTypeContext modulePath (DotProtoEnum enumIdent _) =-  pure (M.singleton enumIdent-            (DotProtoTypeInfo DotProtoNoPackage Anonymous mempty DotProtoKindEnum modulePath))-definitionTypeContext _ _ = pure mempty--concatDotProtoIdentifier :: MonadError CompileError m-                         => DotProtoIdentifier -> DotProtoIdentifier -> m DotProtoIdentifier--concatDotProtoIdentifier Qualified{} _ = internalError "concatDotProtoIdentifier: Qualified"-concatDotProtoIdentifier _ Qualified{} = internalError "concatDotProtoIdentifier Qualified"--concatDotProtoIdentifier Anonymous Anonymous = pure Anonymous-concatDotProtoIdentifier Anonymous b = pure b-concatDotProtoIdentifier a Anonymous = pure a--concatDotProtoIdentifier (Single a) b = concatDotProtoIdentifier (Dots (Path [a])) b-concatDotProtoIdentifier a (Single b) = concatDotProtoIdentifier a (Dots (Path [b]))--concatDotProtoIdentifier (Dots (Path a)) (Dots (Path b)) = pure . Dots . Path $ a ++ b---- | Given a type context, generates the import statements necessary---   to import all the required types.-ctxtImports :: MonadError CompileError m => TypeContext -> m [HsImportDecl]-ctxtImports tyCtxt =-  do imports <- nub <$> sequence-                          [ modulePathModName modulePath-                          | DotProtoTypeInfo { dotProtoTypeInfoModulePath = modulePath }-                             <- M.elems tyCtxt-                          ]-     pure [ importDecl_ modName True Nothing Nothing | modName <- imports ]---- * Functions to convert 'DotProtoType' into Haskell types---- Convert a dot proto type to a Haskell type-dptToHsType :: MonadError CompileError m => TypeContext -> DotProtoType -> m HsType-dptToHsType = foldDPT dptToHsContType dpptToHsType---- Convert a dot proto type to a wrapped Haskell type-dptToHsTypeWrapped :: MonadError CompileError m => [DotProtoOption] -> TypeContext -> DotProtoType -> m HsType-dptToHsTypeWrapped opts =-   foldDPT-     -- The wrapper for the collection type replaces the native haskell-     -- collection type, so try that first.-     (\ctxt ty -> maybe (dptToHsContType ctxt ty) id (dptToHsWrappedContType ctxt opts ty))-     -- Always wrap the primitive type.-     (\ctxt ty -> dpptToHsTypeWrapper ty <$> dpptToHsType ctxt ty)--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 -> 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).-dptToHsWrappedContType :: TypeContext -> [DotProtoOption] -> DotProtoType -> Maybe (HsType -> HsType)-dptToHsWrappedContType ctxt opts = \case-  Prim (Named tyName)-    | 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.-dptToHsContType :: TypeContext -> DotProtoType -> HsType -> HsType-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"-  _                  -> id---- Haskell wrapper for primitive dot proto types-dpptToHsTypeWrapper :: DotProtoPrimType -> HsType -> HsType-dpptToHsTypeWrapper = \case-  SInt32   -> HsTyApp (protobufType_ "Signed")-  SInt64   -> HsTyApp (protobufType_ "Signed")-  SFixed32 -> HsTyApp (protobufType_ "Signed") . HsTyApp (protobufType_ "Fixed")-  SFixed64 -> HsTyApp (protobufType_ "Signed") . HsTyApp (protobufType_ "Fixed")-  Fixed32  -> HsTyApp (protobufType_ "Fixed")-  Fixed64  -> HsTyApp (protobufType_ "Fixed")-  _        -> id---- Convert a dot proto prim type to an unwrapped Haskell type-dpptToHsType :: MonadError CompileError m => TypeContext -> DotProtoPrimType -> m HsType-dpptToHsType 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_ "Text"-  Bytes    -> pure $ primType_ "ByteString"-  Bool     -> pure $ primType_ "Bool"-  Float    -> pure $ primType_ "Float"-  Double   -> pure $ primType_ "Double"-  Named msgName ->-    case M.lookup msgName ctxt of-      Just ty@(DotProtoTypeInfo { dotProtoTypeInfoKind = DotProtoKindEnum }) ->-          HsTyApp (protobufType_ "Enumerated") <$> msgTypeFromDpTypeInfo ty msgName-      Just ty -> msgTypeFromDpTypeInfo ty msgName-      Nothing -> noSuchTypeError msgName---validMapKey :: DotProtoPrimType -> Bool-validMapKey = (`elem` [ Int32, Int64, SInt32, SInt64, UInt32, UInt64-                      , Fixed32, Fixed64, SFixed32, SFixed64-                      , String, Bool])--isMessage :: TypeContext -> DotProtoIdentifier -> Bool-isMessage ctxt n = Just DotProtoKindMessage == (dotProtoTypeInfoKind <$> M.lookup n ctxt)--isPacked :: [DotProtoOption] -> Bool-isPacked opts =-    case find (\(DotProtoOption name _) -> name == Single "packed") opts of-        Just (DotProtoOption _ (BoolLit x)) -> x-        _ -> False--isUnpacked :: [DotProtoOption] -> Bool-isUnpacked opts =-    case find (\(DotProtoOption name _) -> name == Single "packed") opts of-        Just (DotProtoOption _ (BoolLit x)) -> not x-        _ -> False---- | 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--- packable.-isPackable :: TypeContext -> DotProtoPrimType -> Bool-isPackable _ Bytes    = False-isPackable _ String   = False-isPackable _ Int32    = True-isPackable _ Int64    = True-isPackable _ SInt32   = True-isPackable _ SInt64   = True-isPackable _ UInt32   = True-isPackable _ UInt64   = True-isPackable _ Fixed32  = True-isPackable _ Fixed64  = True-isPackable _ SFixed32 = True-isPackable _ SFixed64 = True-isPackable _ Bool     = True-isPackable _ Float    = True-isPackable _ Double   = True-isPackable ctxt (Named tyName) =-  Just DotProtoKindEnum == (dotProtoTypeInfoKind <$> M.lookup tyName ctxt)---- *** Helper functions for 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-                      => DotProtoTypeInfo -> DotProtoIdentifier -> m HsType-msgTypeFromDpTypeInfo-    DotProtoTypeInfo { dotProtoTypeInfoParent = p-                     , dotProtoTypeInfoModulePath = modulePath-                     }-    ident-  | Path [] <- modulePath = throwError InternalEmptyModulePath-  | otherwise = do-       modName <- modulePathModName modulePath-       identName <- nestedTypeName p =<< dpIdentUnqualName ident-       pure $ HsTyCon (Qual modName (HsIdent identName))---- | Given a 'DotProtoIdentifier' for the parent type and the unqualified name--- of this type, generate the corresponding Haskell name-nestedTypeName :: MonadError CompileError m => DotProtoIdentifier -> String -> m String-nestedTypeName Anonymous             nm = typeLikeName nm-nestedTypeName (Single parent)       nm = intercalate "_" <$> sequenceA [ typeLikeName parent , typeLikeName nm ]-nestedTypeName (Dots (Path parents)) nm = intercalate "_" . (<>[nm]) <$> mapM typeLikeName parents-nestedTypeName (Qualified {})        _  = internalError "nestedTypeName: Qualified"--haskellName, jsonpbName, grpcName, protobufName, proxyName-    :: String -> HsQName-haskellName  name = Qual (Module "Hs")         (HsIdent name)-jsonpbName   name = Qual (Module "HsJSONPB")   (HsIdent name)-grpcName     name = Qual (Module "HsGRPC")     (HsIdent name)-protobufName name = Qual (Module "HsProtobuf") (HsIdent name)-proxyName    name = Qual (Module "Proxy")      (HsIdent name)--#ifdef DHALL-hsDhallPB :: String-hsDhallPB = "HsDhallPb"--dhallPBName :: String -> HsQName-dhallPBName name = Qual (Module hsDhallPB) (HsIdent name)-#endif--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--typeLikeName :: MonadError CompileError m => String -> m String-typeLikeName ident@(firstChar:remainingChars)-  | isUpper firstChar = pure (camelCased ident)-  | isLower firstChar = pure (camelCased (toUpper firstChar:remainingChars))-  | firstChar == '_'  = pure (camelCased ('X':ident))-typeLikeName ident = invalidTypeNameError ident--fieldLikeName :: String -> String-fieldLikeName ident@(firstChar:_)-  | isUpper firstChar = let (prefix, suffix) = span isUpper ident-                        in map toLower prefix ++ suffix-fieldLikeName ident = ident--prefixedEnumFieldName :: String -> String -> String-prefixedEnumFieldName enumName fieldName = enumName <> fieldName--prefixedConName :: MonadError CompileError m => String -> String -> m String-prefixedConName msgName conName =-  (msgName ++) <$> typeLikeName conName---- TODO: This should be ~:: MessageName -> FieldName -> ...; same elsewhere, the--- String types are a bit of a hassle.-prefixedFieldName :: MonadError CompileError m => String -> String -> m String-prefixedFieldName msgName fieldName =-  (fieldLikeName msgName ++) <$> typeLikeName fieldName--dpIdentUnqualName :: MonadError CompileError m => DotProtoIdentifier -> m String-dpIdentUnqualName (Single name)       = pure name-dpIdentUnqualName (Dots (Path names)) = pure (last names)-dpIdentUnqualName (Qualified _ next)  = dpIdentUnqualName next-dpIdentUnqualName Anonymous           = internalError "dpIdentUnqualName: Anonymous"--dpIdentQualName :: MonadError CompileError m => DotProtoIdentifier -> m String-dpIdentQualName (Single name)       = pure name-dpIdentQualName (Dots (Path names)) = pure (intercalate "." names)-dpIdentQualName (Qualified _ _)     = internalError "dpIdentQualName: Qualified"-dpIdentQualName Anonymous           = internalError "dpIdentQualName: Anonymous"--modulePathModName :: MonadError CompileError m => Path -> m Module-modulePathModName (Path [])    = throwError InternalEmptyModulePath-modulePathModName (Path comps) = Module <$> (intercalate "." <$> mapM typeLikeName comps)--_pkgIdentModName :: MonadError CompileError m => DotProtoIdentifier -> m Module-_pkgIdentModName (Single s)          = Module <$> typeLikeName s-_pkgIdentModName (Dots (Path paths)) = Module <$> (intercalate "." <$> mapM typeLikeName paths)-_pkgIdentModName _                   = internalError "pkgIdentModName: Malformed package name"---- * Generate instances for a 'DotProto' package--dotProtoDefinitionD-    :: MonadError CompileError m-    => DotProtoIdentifier -> TypeContext -> DotProtoDefinition -> m [HsDecl]-dotProtoDefinitionD _ ctxt (DotProtoMessage messageName dotProtoMessage) =-    dotProtoMessageD ctxt Anonymous messageName dotProtoMessage-dotProtoDefinitionD _ _ (DotProtoEnum messageName dotProtoEnum) =-    dotProtoEnumD Anonymous messageName dotProtoEnum-dotProtoDefinitionD pkgIdent ctxt (DotProtoService serviceName dotProtoService) =-    dotProtoServiceD pkgIdent ctxt serviceName dotProtoService---- | 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-                                               [ HsLit (HsString 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-    :: MonadError CompileError m-    => TypeContext-    -> DotProtoIdentifier-    -> DotProtoIdentifier-    -> [DotProtoMessagePart]-    -> m [HsDecl]-dotProtoMessageD ctxt parentIdent messageIdent message = do-       messageName <- nestedTypeName parentIdent =<< dpIdentUnqualName messageIdent--       let ctxt' = maybe mempty dotProtoTypeChildContext (M.lookup messageIdent ctxt) <> ctxt--           messagePartFieldD (DotProtoMessageField (DotProtoField _ ty fieldName _ _)) = do-               fullName <- prefixedFieldName messageName =<< dpIdentUnqualName fieldName-               fullTy <- dptToHsType ctxt' ty-               pure [ ([HsIdent fullName], HsUnBangedTy fullTy ) ]--           messagePartFieldD (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 :: MonadError CompileError m => 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 :: MonadError CompileError m-                            => DotProtoIdentifier -> [DotProtoField] -> m [HsDecl]-           nestedOneOfDecls identifier fields = do-               fullName <- prefixedConName messageName =<< dpIdentUnqualName identifier-               let oneOfCons (DotProtoField _ ty fieldName _ _) = do-                       consTy <- case ty of-                            Prim msg@(Named msgName)-                              | Just DotProtoKindMessage <- dotProtoTypeInfoKind <$> M.lookup msgName ctxt'-                                -> -- Do not wrap message summands with Maybe.-                                   dpptToHsType ctxt' msg--                            _   -> dptToHsType ctxt' ty--                       consName <- prefixedConName fullName =<< dpIdentUnqualName fieldName-                       let ident = HsIdent consName-                       pure (conDecl_ ident [HsUnBangedTy consTy], ident)--                   oneOfCons DotProtoEmptyField = internalError "field type : empty field"--               (cons, idents) <- fmap unzip (mapM oneOfCons fields)--               fieldNames <- mapM (dpIdentUnqualName . dotProtoFieldName) fields--               toSchemaInstance <- toSchemaInstanceDeclaration fullName fieldNames (Just idents)--               pure [ dataDecl_ fullName cons defaultMessageDeriving-                    , namedInstD fullName-                    , toSchemaInstance--#ifdef DHALL-                    , dhallInterpretInstDecl fullName-                    , dhallInjectInstDecl fullName-#endif-                    ]--       conDecl <- recDecl_ (HsIdent messageName) . mconcat <$>-                  mapM messagePartFieldD message--       nestedDecls_ <- mconcat <$>-           sequence [ nestedDecls def | DotProtoMessageDefinition def <- message]--       nestedOneofs_ <- mconcat <$>-           sequence [ nestedOneOfDecls ident fields | DotProtoMessageOneOf ident fields <- message ]--       messageInst <- messageInstD ctxt' parentIdent messageIdent message--       toJSONPBInst   <- toJSONPBMessageInstD   ctxt' parentIdent messageIdent message-       fromJSONPBInst <- fromJSONPBMessageInstD ctxt' parentIdent messageIdent message--       fieldNames <- sequence $ do-           messagePart <- message-           dotProtoIdentifier <- case messagePart of-                 DotProtoMessageField dotProtoField ->-                   return (dotProtoFieldName dotProtoField)-                 DotProtoMessageOneOf dotProtoIdentifier _ ->-                   return dotProtoIdentifier-                 _ -> empty-           return (dpIdentUnqualName dotProtoIdentifier)--       toSchemaInstance <- toSchemaInstanceDeclaration messageName fieldNames Nothing--       pure $ [ dataDecl_ messageName [ conDecl ] defaultMessageDeriving-              , namedInstD messageName-              , messageInst-              , toJSONPBInst-              , fromJSONPBInst-                -- Generate Aeson instances in terms of JSONPB instances-              , toJSONInstDecl messageName-              , fromJSONInstDecl messageName-              -- And the Swagger ToSchema instance corresponding to JSONPB encodings-              , toSchemaInstance--#ifdef DHALL-              -- Generate Dhall instances-              , dhallInterpretInstDecl messageName-              , dhallInjectInstDecl messageName-#endif-              ]-              <> nestedOneofs_-              <> nestedDecls_---- *** Generate Protobuf 'Message' instances--messageInstD-    :: MonadError CompileError m-    => TypeContext-    -> DotProtoIdentifier -> DotProtoIdentifier-    -> [DotProtoMessagePart]-    -> m HsDecl-messageInstD ctxt parentIdent msgIdent messageParts = do-     msgName <- nestedTypeName parentIdent =<< dpIdentUnqualName msgIdent-     qualifiedFields <- getQualifiedFields msgName messageParts--     let encodeMessageField QualifiedField{recordFieldName, fieldInfo} =-             let recordFieldName' = HsVar (unqual_ (coerce recordFieldName)) in-             case fieldInfo of-                 FieldNormal _fieldName fieldNum dpType options -> do-                     fieldE <- wrapE ctxt options dpType recordFieldName'-                     pure $ apply encodeMessageFieldE [ fieldNumberE fieldNum, fieldE ]--                 FieldOneOf OneofField{subfields} -> do-                      -- 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-                      let mkAlt (OneofSubfield fieldNum conName _ dpType options) = do-                            let isMaybe-                                   | Prim (Named tyName) <- dpType-                                   = Just DotProtoKindMessage == fmap dotProtoTypeInfoKind (M.lookup tyName ctxt)-                                   | otherwise-                                   = False--                            let wrapJust = HsParen . HsApp (HsVar (haskellName "Just"))--                            xE <- (if isMaybe then id else fmap forceEmitE)-                                   . wrapE ctxt options dpType-                                   . (if isMaybe then wrapJust else id)-                                   $ HsVar (unqual_ "y")--                            pure $ alt_ (HsPApp (unqual_ conName) [patVar "y"])-                                        (HsUnGuardedAlt (apply encodeMessageFieldE [fieldNumberE fieldNum, xE]))-                                        []--                      alts <- mapM mkAlt subfields--                      pure $ HsCase recordFieldName'-                             [ alt_ (HsPApp (haskellName "Nothing") [])-                                    (HsUnGuardedAlt memptyE)-                                    []-                             , alt_ (HsPApp (haskellName "Just") [patVar "x"])-                                    (HsUnGuardedAlt (HsCase (HsVar (unqual_ "x")) alts))-                                    []-                             ]--     let decodeMessageField QualifiedField{fieldInfo} = do-             case fieldInfo of-                 FieldNormal _fieldName fieldNum dpType options ->-                     unwrapE ctxt options dpType $ apply atE [ decodeMessageFieldE, fieldNumberE fieldNum ]--                 FieldOneOf OneofField{subfields} -> do-                     -- create a list of (fieldNumber, Cons <$> parser)-                     let subfieldParserE (OneofSubfield fieldNumber consName _ dpType options) = do-                           let fE = case dpType of-                                      Prim (Named tyName)-                                        | Just DotProtoKindMessage <- dotProtoTypeInfoKind <$> M.lookup tyName ctxt-                                          -> HsParen (HsApp fmapE (HsVar (unqual_ consName)))-                                      _ -> HsParen (HsInfixApp (HsVar (haskellName "Just"))-                                                               composeOp-                                                               (HsVar (unqual_ consName)))--                           alts <- unwrapE ctxt options dpType decodeMessageFieldE--                           pure $ HsTuple-                                [ fieldNumberE fieldNumber-                                , HsInfixApp (apply pureE [ fE ]) apOp alts-                                ]--                     parsers <- mapM subfieldParserE subfields--                     pure $  apply oneofE [ HsVar (haskellName "Nothing")-                                          , HsList parsers-                                          ]--     let dotProtoE = HsList-             [ apply dotProtoFieldC-                  [ fieldNumberE fieldNum-                  , dpTypeE dpType-                  , dpIdentE fieldIdent-                  , HsList (map optionE options)-                  , maybeE (HsLit . HsString) comments-                  ]-             | DotProtoMessageField (DotProtoField fieldNum dpType fieldIdent options comments)-                <- messageParts-             ]--     let punnedFieldsP =-             [ HsPFieldPat (unqual_ fieldName) (HsPVar (HsIdent fieldName))-             | QualifiedField (coerce -> fieldName) _ <- qualifiedFields-             ]--     encodedFields <- mapM encodeMessageField qualifiedFields-     decodedFields <- mapM decodeMessageField qualifiedFields--     let encodeMessageE = apply mconcatE [ HsList encodedFields]-     let decodeMessageE = foldl (\f -> HsInfixApp f apOp)-                                (apply pureE [ HsVar (unqual_ msgName) ])-                                decodedFields--     let encodeMessageDecl = match_ (HsIdent "encodeMessage")-                                    [HsPWildCard, HsPRec (unqual_ msgName) punnedFieldsP]-                                    (HsUnGuardedRhs encodeMessageE) []-     let decodeMessageDecl = match_ (HsIdent "decodeMessage") [ HsPWildCard ]-                                    (HsUnGuardedRhs decodeMessageE) []-     let dotProtoDecl      = match_ (HsIdent "dotProto") [HsPWildCard]-                                    (HsUnGuardedRhs dotProtoE) []--     pure $ instDecl_ (protobufName "Message")-                      [ type_ msgName ]-                      [ HsFunBind [ encodeMessageDecl ]-                      , HsFunBind [ decodeMessageDecl ]-                      , HsFunBind [ dotProtoDecl ]-                      ]----- *** Generate ToJSONPB/FromJSONPB instances--toJSONPBMessageInstD-    :: MonadError CompileError m-    => TypeContext-    -> DotProtoIdentifier-    -> DotProtoIdentifier-    -> [DotProtoMessagePart]-    -> m HsDecl-toJSONPBMessageInstD _ctxt parentIdent msgIdent messageParts = do-  msgName    <- nestedTypeName parentIdent =<< dpIdentUnqualName msgIdent-  qualFields <- getQualifiedFields msgName messageParts--  -- E.g.-  -- "another" .= f2 -- always succeeds (produces default value on missing field)-  let defPairE fldName fldNum =-        HsInfixApp (HsLit (HsString (coerce fldName)))-                   toJSONPBOp-                   (HsVar (unqual_ (fieldBinder fldNum)))-  -- E.g.-  -- HsJSONPB.pair "name" f4 -- fails on missing field-  let pairE fldNm varNm =-        apply (HsVar (jsonpbName "pair"))-              [ HsLit (HsString (coerce fldNm))-              , HsVar (unqual_ varNm)-              ]--  -- 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>-  -- >     ]-  let oneofCaseE retJsonCtor (OneofField typeName subfields) =-          HsParen-            $ HsLet [ HsFunBind [ match_ (HsIdent caseName) [] (HsUnGuardedRhs caseExpr) [] ] ]-            $ HsLambda l [patVar optsStr] (HsIf dontInline noInline yesInline)-        where-          optsStr = "options"-          opts    = HsVar (unqual_ optsStr)--          caseName = "encode" <> over (ix 0) toUpper typeName-          caseBnd = HsVar (unqual_ caseName)--          dontInline = HsApp (HsVar (jsonpbName "optEmitNamedOneof")) opts--          noInline = HsApp (HsParen (HsInfixApp (HsLit (HsString typeName))-                                                toJSONPBOp-                                                (apply (HsVar (jsonpbName retJsonCtor)) [ HsList [caseBnd], opts ])))-                           opts--          yesInline = HsApp caseBnd opts---          -- E.g.-          -- case f4_or_f9 of-          --   Just (SomethingPickOneName f4)-          --     -> HsJSONPB.pair "name" f4-          --   Just (SomethingPickOneSomeid f9)-          --     -> HsJSONPB.pair "someid" f9-          --   Nothing-          --     -> mempty-          caseExpr = HsParen $-              HsCase disjunctName (altEs <> [fallthroughE])-            where-              disjunctName = HsVar (unqual_ (oneofSubDisjunctBinder subfields))-              altEs = do-                sub@(OneofSubfield _ conName pbFldNm _ _) <- subfields-                let patVarNm = oneofSubBinder sub-                pure $ alt_ (HsPApp (haskellName "Just")-                                    [ HsPParen-                                      $ HsPApp (unqual_ conName) [patVar patVarNm]-                                    ]-                            )-                            (HsUnGuardedAlt (pairE pbFldNm patVarNm))-                            []-              fallthroughE =-                alt_ (HsPApp (haskellName "Nothing") [])-                     (HsUnGuardedAlt memptyE)-                     []--  let patBinder = onQF (const fieldBinder) (oneofSubDisjunctBinder . subfields)--  let applyE nm oneofNm =-        apply (HsVar (jsonpbName nm))-              [ HsList (onQF defPairE (oneofCaseE oneofNm) <$> qualFields) ]--  let matchE nm appNm oneofAppNm =-        match_-          (HsIdent nm)-          [ HsPApp (unqual_ msgName)-                   (patVar . patBinder <$> qualFields) ]-          (HsUnGuardedRhs (applyE appNm oneofAppNm))-          []--  pure $ instDecl_ (jsonpbName "ToJSONPB")-                   [ type_ msgName ]-                   [ HsFunBind [matchE "toJSONPB"     "object" "objectOrNull"]-                   , HsFunBind [matchE "toEncodingPB" "pairs"  "pairsOrNull" ]-                   ]---fromJSONPBMessageInstD-    :: MonadError CompileError m-    => TypeContext-    -> DotProtoIdentifier-    -> DotProtoIdentifier-    -> [DotProtoMessagePart]-    -> m HsDecl-fromJSONPBMessageInstD _ctxt parentIdent msgIdent messageParts = do-  msgName    <- nestedTypeName parentIdent =<< dpIdentUnqualName msgIdent-  qualFields <- getQualifiedFields msgName messageParts--  let lambdaPVar = patVar "obj"-  let lambdaVar  = HsVar (unqual_ "obj")--  -- 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)-  -- )-  let oneofParserE (OneofField oneofType fields) =-          HsParen $-            HsLet [ HsFunBind [ match_ (HsIdent letBndStr) [patVar letArgStr ]-                                       (HsUnGuardedRhs tryParseDisjunctsE) []-                              ]-                  ]-                  (HsInfixApp parseWrapped altOp parseUnwrapped)-        where-          oneofTyLit = HsLit (HsString oneofType) -- FIXME--          letBndStr  = "parse" <> over (ix 0) toUpper oneofType-          letBndName = HsVar (unqual_ letBndStr)-          letArgStr  = "parseObj"-          letArgName = HsVar (unqual_ 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 =-              HsApp msumE (HsList (map subParserE fields <> fallThruE))-            where-              fallThruE-                = [ HsApp pureE (HsVar (haskellName "Nothing")) ]-              subParserE OneofSubfield{subfieldConsName, subfieldName}-                = HsInfixApp-                    (HsInfixApp (HsVar (haskellName "Just"))-                                composeOp-                                (HsVar (unqual_ subfieldConsName)))-                    fmapOp-                    (apply (HsVar (jsonpbName "parseField"))-                           [ letArgName-                           , HsLit (HsString (coerce subfieldName))])--  -- E.g. obj .: "someid"-  let normalParserE fldNm _ =-        HsInfixApp lambdaVar-                   parseJSONPBOp-                   (HsLit (HsString (coerce fldNm)))--  let parseJSONPBE =-        apply (HsVar (jsonpbName "withObject"))-              [ HsLit (HsString msgName)-              , HsParen (HsLambda l [lambdaPVar] fieldAps)-              ]-        where-          fieldAps = foldl (\f -> HsInfixApp f apOp)-                           (apply pureE [ HsVar (unqual_ msgName) ])-                           (onQF normalParserE oneofParserE <$> qualFields)--  let parseJSONPBDecl =-        match_ (HsIdent "parseJSONPB") [] (HsUnGuardedRhs parseJSONPBE) []--  pure (instDecl_ (jsonpbName "FromJSONPB")-                 [ type_ msgName ]-                 [ HsFunBind [ parseJSONPBDecl ] ])--#ifdef DHALL--- *** Generate Dhall Interpret and Inject generic instances--dhallInterpretInstDecl :: String -> HsDecl-dhallInterpretInstDecl typeName =-  instDecl_ (dhallPBName "Interpret")-            [ type_ typeName ]-            [ ]--dhallInjectInstDecl :: String -> HsDecl-dhallInjectInstDecl typeName =-  instDecl_ (dhallPBName "Inject")-            [ type_ typeName ]-            [ ]-#endif---- *** 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"))) []-                        ]-            ]----- ** `ToSchema` instance code-generation--toSchemaInstanceDeclaration-    :: MonadError CompileError m-    => String-    -- ^ Name of the message type to create an instance for-    -> [String]-    -- ^ Field names-    -> Maybe [HsName]-    -- ^ Oneof constructors-    -> m HsDecl-toSchemaInstanceDeclaration messageName fieldNames maybeConstructors = do-  qualifiedFieldNames <- mapM (prefixedFieldName messageName) fieldNames-  let messageConstructor = HsCon (UnQual (HsIdent messageName))--  let _namedSchemaNameExpression = HsApp justC (HsLit (HsString messageName))--      -- { _paramSchemaType = HsJSONPB.SwaggerObject-      -- }-  let paramSchemaUpdates =-        [ HsFieldUpdate _paramSchemaType _paramSchemaTypeExpression-        ]-        where-          _paramSchemaType = jsonpbName "_paramSchemaType"--          _paramSchemaTypeExpression = HsVar (jsonpbName "SwaggerObject")--  let _schemaParamSchemaExpression = HsRecUpdate memptyE paramSchemaUpdates--      -- [ ("fieldName0", qualifiedFieldName0)-      -- , ("fieldName1", qualifiedFieldName1)-      -- ...-      -- ]-  let properties = HsList $ do-        (fieldName, qualifiedFieldName) <- zip fieldNames qualifiedFieldNames--        let string = HsLit (HsString fieldName)--        let variable = HsVar (UnQual (HsIdent qualifiedFieldName))--        return (HsTuple [ string, variable ])--  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 fieldName = HsApp asProxy declare-        where-          declare = HsVar (UnQual (HsIdent (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 =-        HsDo (bindingStatements ++ inferenceStatements ++ [ returnStatement ])-        where-          bindingStatements = do-            (fieldName, qualifiedFieldName) <- zip fieldNames qualifiedFieldNames--            let declareIdentifier = HsIdent (toDeclareName fieldName)--            let rightHandSide0 =-                    HsUnGuardedRhs (HsVar (jsonpbName "declareSchemaRef"))--            let match = HsMatch l declareIdentifier [] rightHandSide0 []--            let statement0 = HsLetStmt [ HsFunBind [ match ] ]--            let declareVariable = HsVar (UnQual declareIdentifier)--            let proxy = HsCon (proxyName "Proxy")--            let rightHandSide1 = HsApp declareVariable proxy--            let pattern = HsPVar (HsIdent qualifiedFieldName)--            let statement1 = HsGenerator l pattern rightHandSide1--            [ statement0, statement1 ]---          inferenceStatements =-              if null fieldNames then [] else [ HsLetStmt [ patternBind ] ]-            where-              arguments = map toArgument fieldNames--              rightHandSide =-                HsUnGuardedRhs (applicativeApply messageConstructor arguments)--              patternBind = HsPatBind l HsPWildCard rightHandSide []--          returnStatement = HsQualifier (HsApp returnE (HsParen namedSchema))--      -- 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 =-        HsDo (bindingStatements ++ [ returnStatement ])-        where-          bindingStatements = do-            (fieldName, qualifiedFieldName, constructor) <- zip3 fieldNames qualifiedFieldNames constructors--            let declareIdentifier = HsIdent (toDeclareName fieldName)--            let rightHandSide0 =-                    HsUnGuardedRhs (HsVar (jsonpbName "declareSchemaRef"))--            let match = HsMatch l declareIdentifier [] rightHandSide0 []--            let statement0 = HsLetStmt [ HsFunBind [ match ] ]--            let declareVariable = HsVar (UnQual declareIdentifier)--            let proxy = HsCon (proxyName "Proxy")--            let rightHandSide1 = HsApp declareVariable proxy--            let pattern = HsPVar (HsIdent qualifiedFieldName)--            let statement1 = HsGenerator l pattern rightHandSide1--            let inferenceStatements =-                  if null fieldNames then [] else [ HsLetStmt [ patternBind ] ]-                  where-                    arguments = [ toArgument fieldName ]--                    rightHandSide =-                      HsUnGuardedRhs (applicativeApply (HsCon (UnQual constructor)) arguments)--                    patternBind = HsPatBind l HsPWildCard rightHandSide []--            [ statement0, statement1 ] ++ inferenceStatements--          returnStatement = HsQualifier (HsApp returnE (HsParen namedSchema))--  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-                  expression = case maybeConstructors of-                      Nothing           -> expressionForMessage-                      Just constructors -> expressionForOneOf constructors--                  rightHandSide = HsUnGuardedRhs expression--                  matchName = HsIdent "declareNamedSchema"-  return instanceDeclaration---- ** Codegen bookkeeping helpers---- | Bookeeping for qualified fields-data QualifiedField = QualifiedField-  { recordFieldName :: FieldName-  , fieldInfo       :: FieldInfo-  } deriving Show---- | Bookkeeping for fields-data FieldInfo-  = FieldOneOf OneofField-  | FieldNormal FieldName FieldNumber DotProtoType [DotProtoOption]-  deriving Show---- | Bookkeeping for oneof fields-data OneofField = OneofField-  { oneofType :: String-  , subfields :: [OneofSubfield]-  } deriving Show---- | Bookkeeping for oneof subfields-data OneofSubfield = OneofSubfield-  { subfieldNumber   :: FieldNumber-  , subfieldConsName :: String-  , subfieldName     :: FieldName-  , subfieldType     :: DotProtoType-  , subfieldOptions  :: [DotProtoOption]-  } deriving Show--getQualifiedFields-    :: MonadError CompileError m-    => String -> [DotProtoMessagePart] -> m [QualifiedField]-getQualifiedFields msgName msgParts = fmap catMaybes . forM msgParts $ \case-  DotProtoMessageField (DotProtoField fieldNum dpType fieldIdent options _) -> do-    fieldName <- dpIdentUnqualName fieldIdent-    qualName  <- prefixedFieldName msgName fieldName-    pure $ Just $-      QualifiedField (coerce qualName) (FieldNormal (coerce fieldName) fieldNum dpType options)--  DotProtoMessageOneOf _ [] ->-    throwError (InternalError "getQualifiedFields: encountered oneof with no oneof fields")--  DotProtoMessageOneOf oneofIdent fields -> do-    ident <- dpIdentUnqualName oneofIdent-    oneofName <- prefixedFieldName msgName ident-    oneofTypeName <- prefixedConName msgName ident-    fieldElems <- sequence-                    [ do s <- dpIdentUnqualName subFieldName-                         c <- prefixedConName oneofTypeName s-                         pure (OneofSubfield fieldNum c (coerce s) dpType options)-                    | DotProtoField fieldNum dpType subFieldName options _ <- fields-                    ]-    pure $ Just $ QualifiedField (coerce oneofName) (FieldOneOf (OneofField ident fieldElems))--  _ ->-    pure Nothing---- | Project qualified fields, given a projection function per field type.-onQF :: (FieldName -> FieldNumber -> a) -- ^ projection for normal fields-     -> (OneofField -> a)               -- ^ projection for oneof fields-     -> QualifiedField-     -> a-onQF f _ (QualifiedField _ (FieldNormal fldName fldNum _ _)) = f fldName fldNum-onQF _ g (QualifiedField _ (FieldOneOf fld))                 = g fld--fieldBinder :: FieldNumber -> String-fieldBinder = ("f" ++) . show--oneofSubBinder :: OneofSubfield -> String-oneofSubBinder = fieldBinder . subfieldNumber--oneofSubDisjunctBinder :: [OneofSubfield] -> String-oneofSubDisjunctBinder = intercalate "_or_" . fmap oneofSubBinder---- ** Helpers to wrap/unwrap types for protobuf (de-)serialization--coerceE :: Bool -> HsType -> HsType -> Maybe HsExp-coerceE _ from to | from == to = Nothing-coerceE unsafe from to = Just $ HsApp (HsApp coerceF (typeApp from)) (typeApp to)-  where-    -- Do not add linebreaks to typeapps as that causes parse errors-    pp = prettyPrintStyleMode style{mode=OneLineMode} defaultMode-    typeApp ty = HsVar (UnQual (HsIdent ("@("++ pp ty ++ ")")))-    coerceF | unsafe = HsVar (haskellName "unsafeCoerce")-            | otherwise  = HsVar (haskellName "coerce")--wrapE :: MonadError CompileError m => TypeContext -> [DotProtoOption] -> DotProtoType -> HsExp -> m HsExp-wrapE ctxt opts dpt e = maybe e (\f -> HsParen (HsApp (HsParen f) e)) <$>-  (coerceE (isMap dpt) <$> dptToHsType ctxt dpt <*> dptToHsTypeWrapped opts ctxt dpt)--unwrapE :: MonadError CompileError m => TypeContext -> [DotProtoOption] -> DotProtoType -> HsExp -> m HsExp-unwrapE ctxt opts dpt e = maybe e (\f -> HsParen (HsApp (HsParen f) e)) <$>-   (coerceE (isMap dpt) <$> overParser (dptToHsTypeWrapped opts ctxt dpt) <*> overParser (dptToHsType ctxt dpt))-  where-    overParser = fmap $ HsTyApp (HsTyVar (HsIdent "_"))--isMap :: DotProtoType -> Bool-isMap Map{} = True-isMap _ = False--internalError :: MonadError CompileError m => String -> m a-internalError = throwError . InternalError--invalidTypeNameError :: MonadError CompileError m => String -> m a-invalidTypeNameError = throwError . InvalidTypeName--_unimplementedError :: MonadError CompileError m => String -> m a-_unimplementedError = throwError . Unimplemented--invalidMethodNameError :: MonadError CompileError m => DotProtoIdentifier -> m a-invalidMethodNameError = throwError . InvalidMethodName--noSuchTypeError :: MonadError CompileError m => DotProtoIdentifier -> m a-noSuchTypeError = throwError. NoSuchType---- ** Generate types and instances for .proto enums--dotProtoEnumD-    :: MonadError CompileError m-    => DotProtoIdentifier-    -> DotProtoIdentifier-    -> [DotProtoEnumPart]-    -> m [HsDecl]-dotProtoEnumD parentIdent enumIdent enumParts =-  do enumName <- nestedTypeName parentIdent =<<-                 dpIdentUnqualName enumIdent--     enumCons <- sortBy (comparing fst) <$>-                 sequence [ (i,) . prefixedEnumFieldName enumName <$> dpIdentUnqualName conIdent-                          | DotProtoEnumField conIdent i _options <- enumParts ]--     let enumNameE = HsLit (HsString enumName)-         -- TODO assert that there is more than one enumeration constructor-         ((minEnumVal, maxEnumVal), enumConNames) = first (minimum &&& maximum) $ unzip enumCons--         boundsE = HsTuple-                     [ HsExpTypeSig l (intE minEnumVal) (HsQualType [] (HsTyCon (haskellName "Int")))-                     , intE maxEnumVal-                     ]--         toEnumD = toEnumDPatterns <> [ toEnumFailure ]-         fromEnumD =-             [ match_ (HsIdent "fromEnum") [ HsPApp (unqual_ conName) [] ]-                      (HsUnGuardedRhs (intE conIdx))-                      []-             | (conIdx, conName) <- enumCons-             ]-         succD = zipWith succDPattern enumConNames (tail enumConNames) <> [ succFailure ]-         predD = zipWith predDPattern (tail enumConNames) enumConNames <> [ predFailure ]--         toEnumDPatterns =-             [ match_ (HsIdent "toEnum")-                      [ intP conIdx ]-                      (HsUnGuardedRhs (HsVar (unqual_ conName))) []-             | (conIdx, conName) <- enumCons ]--         succDPattern thisCon nextCon =-             match_ (HsIdent "succ") [ HsPApp (unqual_ thisCon) [] ]-                    (HsUnGuardedRhs (HsVar (unqual_ nextCon))) []-         predDPattern thisCon prevCon =-             match_ (HsIdent "pred") [ HsPApp (unqual_ thisCon) [] ]-                    (HsUnGuardedRhs (HsVar (unqual_ prevCon))) []--         toEnumFailure   = match_ (HsIdent "toEnum") [ HsPVar (HsIdent "i") ]-                                  (HsUnGuardedRhs-                                     (apply toEnumErrorE [enumNameE , HsVar (unqual_ "i") , boundsE]))-                                  []-         succFailure     = match_ (HsIdent "succ") [ HsPWildCard ]-                                  (HsUnGuardedRhs (HsApp succErrorE enumNameE)) []-         predFailure     = match_ (HsIdent "pred") [ HsPWildCard ]-                                  (HsUnGuardedRhs (HsApp predErrorE enumNameE)) []--         parseJSONPBDecls :: [HsMatch]-         parseJSONPBDecls =-           [ let pat nm =-                   HsPApp (jsonpbName "String")-                     [ HsPLit (HsString (fromMaybe <*> stripPrefix enumName $ nm)) ]-             in-             match_ (HsIdent "parseJSONPB") [pat conName]-                    (HsUnGuardedRhs-                       (HsApp pureE (HsVar (unqual_ conName))))-                    []-           | conName <- enumConNames-           ]-           <> [ match_ (HsIdent "parseJSONPB") [patVar "v"]-                       (HsUnGuardedRhs-                          (apply (HsVar (jsonpbName "typeMismatch"))-                                 [ HsLit (HsString enumName), HsVar (unqual_ "v") ]))-                       []-              ]--         toJSONPBDecl =-           match_ (HsIdent "toJSONPB") [ patVar "x", HsPWildCard ]-             (HsUnGuardedRhs-                (HsApp (HsVar (jsonpbName "enumFieldString"))-                       (HsVar (unqual_ "x"))))-             []--         toEncodingPBDecl =-           match_ (HsIdent "toEncodingPB") [ patVar "x", HsPWildCard ]-             (HsUnGuardedRhs-                (HsApp (HsVar (jsonpbName "enumFieldEncoding"))-                       (HsVar (unqual_ "x"))))-             []--     pure [ dataDecl_ enumName-                      [ conDecl_ (HsIdent con) [] | con <- enumConNames ]-                      defaultEnumDeriving-          , namedInstD enumName-          , instDecl_ (haskellName "Enum") [ type_ enumName ]-                      [ HsFunBind toEnumD, HsFunBind fromEnumD-                      , HsFunBind succD, HsFunBind predD ]-          , 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-    => DotProtoIdentifier-    -> TypeContext-    -> DotProtoIdentifier-    -> [DotProtoServicePart]-    -> m [HsDecl]-dotProtoServiceD pkgIdent ctxt serviceIdent service = do-     serviceNameUnqual <- dpIdentUnqualName serviceIdent-     packageName <- dpIdentQualName pkgIdent--     serviceName <- typeLikeName serviceNameUnqual--     let endpointPrefix = "/" ++ packageName ++ "." ++ serviceName ++ "/"--         serviceFieldD (DotProtoServiceRPC-                            rpcName-                            (request, requestStreaming)-                            (response, responseStreaming)-                            _-                       ) = do-           fullName <- prefixedFieldName serviceName =<<-                       dpIdentUnqualName rpcName--           methodName <- case rpcName of-                           Single nm -> pure nm-                           _ -> invalidMethodNameError rpcName--           requestTy <- dpptToHsType ctxt  (Named request)-           responseTy <- dpptToHsType ctxt (Named response)--           let streamingType =-                 case (requestStreaming, responseStreaming) of-                   (Streaming, Streaming)       -> biDiStreamingC-                   (Streaming, NonStreaming)    -> clientStreamingC-                   (NonStreaming, Streaming)    -> serverStreamingC-                   (NonStreaming, NonStreaming) -> normalC--           pure [ ( endpointPrefix ++ methodName-                  , fullName, requestStreaming, responseStreaming-                  , HsUnBangedTy $-                    HsTyFun (tyApp (HsTyVar (HsIdent "request")) [streamingType, requestTy, responseTy])-                            (tyApp ioT [tyApp (HsTyVar (HsIdent "response")) [streamingType, responseTy]])-                  )-                ]--         serviceFieldD _ = pure []--     fieldsD <- mconcat <$> mapM serviceFieldD service--     serverFuncName <- prefixedFieldName serviceName "server"-     clientFuncName <- prefixedFieldName serviceName "client"--     let conDecl = recDecl_ (HsIdent serviceName)-                            [ ([HsIdent hsName], ty) | (_, hsName, _, _, ty) <- fieldsD ]--         serverT = tyApp (HsTyCon (unqual_ serviceName))-                         [ serverRequestT, serverResponseT ]--         serviceServerTypeD = HsTypeSig l [ HsIdent serverFuncName ]-                                        (HsQualType [] (HsTyFun serverT (HsTyFun serviceOptionsC ioActionT)))--         serviceServerD =-             let 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"-                                   ]-                          ]-                          (HsUnGuardedRhs (apply serverLoopE [ serverOptsE ]))-                          []--                 handlerE handlerC adapterE methodName hsName =-                     apply handlerC [ apply methodNameC [ HsLit (HsString methodName) ]-                                    , apply adapterE [ HsVar (unqual_ hsName) ]-                                    ]--                 update u v = HsFieldUpdate (unqual_ u) (HsVar (unqual_ 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"-                     ]-             in-                HsFunBind [serverFuncD]--         clientT = tyApp (HsTyCon (unqual_ serviceName)) [ clientRequestT, clientResultT ]--         serviceClientTypeD =-             HsTypeSig l [ HsIdent clientFuncName ]-                       (HsQualType [] (HsTyFun grpcClientT (HsTyApp ioT clientT)))--         serviceClientD =-             let clientFuncD = match_ (HsIdent clientFuncName)-                                      [ HsPVar (HsIdent "client") ]-                                      ( HsUnGuardedRhs clientRecE ) []--                 clientRecE = foldl (\f -> HsInfixApp f apOp)-                                    (apply pureE [ HsVar (unqual_ serviceName) ])-                                    [ HsParen $ HsInfixApp clientRequestE' apOp (registerClientMethodE endpointName)-                                    | (endpointName, _, _, _, _) <- fieldsD-                                    ]--                 clientRequestE' = apply pureE [ apply clientRequestE [ HsVar (unqual_ "client") ] ]--                 registerClientMethodE endpoint =-                   apply clientRegisterMethodE [ HsVar (unqual_ "client")-                                               , apply methodNameC [ HsLit (HsString endpoint) ]-                                               ]-             in-                HsFunBind [ clientFuncD ]--     pure [ HsDataDecl l  [] (HsIdent serviceName)-                [ HsIdent "request", HsIdent "response" ]-                [ conDecl ] defaultServiceDeriving--          , serviceServerTypeD-          , serviceServerD--          , serviceClientTypeD-          , serviceClientD-          ]---- * Common Haskell expressions, constructors, and operators--dotProtoFieldC, primC, optionalC, repeatedC, nestedRepeatedC, namedC, mapC,-  fieldNumberC, singleC, dotsC, pathC, nestedC, anonymousC, dotProtoOptionC,-  identifierC, stringLitC, intLitC, floatLitC, boolLitC, trueC, falseC,-  unaryHandlerC, clientStreamHandlerC, serverStreamHandlerC, biDiStreamHandlerC,-  methodNameC, nothingC, justC, forceEmitC, mconcatE, encodeMessageFieldE,-  fromStringE, decodeMessageFieldE, pureE, returnE, memptyE, msumE, atE, oneofE,-  succErrorE, predErrorE, toEnumErrorE, fmapE, defaultOptionsE, serverLoopE,-  convertServerHandlerE, convertServerReaderHandlerE, convertServerWriterHandlerE,-  convertServerRWHandlerE, clientRegisterMethodE, clientRequestE :: HsExp--dotProtoFieldC       = HsVar (protobufName "DotProtoField")-primC                = HsVar (protobufName "Prim")-optionalC            = HsVar (protobufName "Optional")-repeatedC            = HsVar (protobufName "Repeated")-nestedRepeatedC      = HsVar (protobufName "NestedRepeated")-namedC               = HsVar (protobufName "Named")-mapC                 = HsVar (protobufName "Map")-fieldNumberC         = HsVar (protobufName "FieldNumber")-singleC              = HsVar (protobufName "Single")-pathC                = HsVar (protobufName "Path")-dotsC                = HsVar (protobufName "Dots")-nestedC              = HsVar (protobufName "Nested")-anonymousC           = HsVar (protobufName "Anonymous")-dotProtoOptionC      = HsVar (protobufName "DotProtoOption")-identifierC          = HsVar (protobufName "Identifier")-stringLitC           = HsVar (protobufName "StringLit")-intLitC              = HsVar (protobufName "IntLit")-floatLitC            = HsVar (protobufName "FloatLit")-boolLitC             = HsVar (protobufName "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")-mconcatE                    = HsVar (haskellName "mconcat")-fromStringE                 = HsVar (haskellName "fromString")-pureE                       = HsVar (haskellName "pure")-returnE                     = HsVar (haskellName "return")-memptyE                     = HsVar (haskellName "mempty")-msumE                       = HsVar (haskellName "msum")-succErrorE                  = HsVar (haskellName "succError")-predErrorE                  = HsVar (haskellName "predError")-toEnumErrorE                = HsVar (haskellName "toEnumError")-fmapE                       = HsVar (haskellName "fmap")--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")--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 ".:"))--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---- ** Expressions for protobuf-wire types--forceEmitE :: HsExp -> HsExp-forceEmitE = HsParen . HsApp forceEmitC--fieldNumberE :: FieldNumber -> HsExp-fieldNumberE = HsParen . HsApp fieldNumberC . intE . getFieldNumber--maybeE :: (a -> HsExp) -> Maybe a -> HsExp-maybeE _ Nothing = nothingC-maybeE f (Just a) = HsApp justC (f a)--dpIdentE :: DotProtoIdentifier -> HsExp-dpIdentE (Single n)       = apply singleC [ HsLit (HsString n) ]-dpIdentE (Dots (Path ns)) = apply dotsC [apply pathC [ HsList (map (HsLit . HsString) ns) ] ]-dpIdentE (Qualified a b)  = apply nestedC [ dpIdentE a, dpIdentE b ]-dpIdentE Anonymous        = anonymousC--dpValueE :: DotProtoValue -> HsExp-dpValueE (Identifier nm) = apply identifierC [ dpIdentE nm ]-dpValueE (StringLit s)   = apply stringLitC  [ HsLit (HsString 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 (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 = HsVar . protobufName 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 :: Bool -> [HsImportDecl]-defaultImports usesGrpc =-    [ importDecl_ preludeM                  True  (Just haskellNS)  Nothing--#ifdef DHALL-    , importDecl_ proto3SuiteDhallPBM       True  (Just (Module hsDhallPB)) Nothing-#endif--    , importDecl_ dataProtobufWireDotProtoM True  (Just protobufNS) Nothing-    , importDecl_ dataProtobufWireTypesM    True  (Just protobufNS) Nothing-    , importDecl_ dataProtobufWireClassM    True  (Just protobufNS) Nothing-    , importDecl_ proto3SuiteJSONPBM        True  (Just jsonpbNS) Nothing-    , importDecl_ proto3SuiteJSONPBM        False  Nothing-                  (Just (False, [ HsIAbs (HsSymbol ".=")-                                , HsIAbs (HsSymbol ".:")-                                ]-                        )-                  )-    , importDecl_ proto3WireM               True  (Just protobufNS) Nothing-    , importDecl_ controlApplicativeM       False Nothing-                  (Just (False, [ HsIAbs (HsSymbol "<*>")-                                , HsIAbs (HsSymbol "<|>")-                                , HsIAbs (HsSymbol "<$>")-                                ]-                        )-                  )-    , importDecl_ controlApplicativeM       True  (Just haskellNS) Nothing-    , importDecl_ controlDeepSeqM           True  (Just haskellNS) Nothing-    , importDecl_ controlMonadM             True  (Just haskellNS) Nothing-    , importDecl_ dataTextM                 True-                  (Just haskellNS) (Just (False, [ importSym "Text" ]))-    , importDecl_ dataByteStringM           True  (Just haskellNS) Nothing-    , importDecl_ dataCoerceM               True  (Just haskellNS) Nothing-    , importDecl_ dataStringM               True  (Just haskellNS)-                  (Just (False, [ importSym "fromString" ]))-    , importDecl_ dataVectorM               True  (Just haskellNS)-                  (Just (False, [ importSym "Vector" ]))-    , importDecl_ dataMapM               True  (Just haskellNS)-                  (Just (False, [ importSym "Map", importSym "mapKeysMonotonic" ]))-    , importDecl_ dataIntM                  True  (Just haskellNS)-                  (Just (False, [ importSym "Int16", importSym "Int32", importSym "Int64" ]))-    , importDecl_ dataWordM                 True  (Just haskellNS)-                  (Just (False, [ importSym "Word16", importSym "Word32", importSym "Word64" ]))-    , importDecl_ dataProxy                 True (Just proxyNS)   Nothing-    , importDecl_ ghcGenericsM              True (Just haskellNS) Nothing-    , importDecl_ ghcEnumM                  True (Just haskellNS) Nothing-    , importDecl_ unsafeCoerceM             True (Just haskellNS) Nothing-    ]-    <>-    if usesGrpc-      then [ importDecl_ networkGrpcHighLevelGeneratedM   False (Just grpcNS) Nothing-           , importDecl_ networkGrpcHighLevelClientM      False (Just grpcNS) Nothing-           , importDecl_ networkGrpcHighLevelServerM      False (Just grpcNS)-                 (Just (True, [ importSym "serverLoop" ]))-           , importDecl_ networkGrpcHighLevelServerUnregM False (Just grpcNS)-                 (Just (False, [ importSym "serverLoop" ]))-           ]-      else []-  where-    preludeM                  = Module "Prelude"-    dataProtobufWireDotProtoM = Module "Proto3.Suite.DotProto"-    dataProtobufWireClassM    = Module "Proto3.Suite.Class"-    dataProtobufWireTypesM    = Module "Proto3.Suite.Types"-    proto3SuiteJSONPBM        = Module "Proto3.Suite.JSONPB"-    proto3WireM               = Module "Proto3.Wire"-    controlApplicativeM       = Module "Control.Applicative"-    controlDeepSeqM           = Module "Control.DeepSeq"-    controlMonadM             = Module "Control.Monad"-    dataCoerceM               = Module "Data.Coerce"-    dataTextM                 = Module "Data.Text.Lazy"-    dataByteStringM           = Module "Data.ByteString"-    dataStringM               = Module "Data.String"-    dataIntM                  = Module "Data.Int"-    dataVectorM               = Module "Data.Vector"-    dataMapM                  = Module "Data.Map"-    dataWordM                 = Module "Data.Word"-    dataProxy                 = Module "Data.Proxy"-    ghcGenericsM              = Module "GHC.Generics"-    ghcEnumM                  = Module "GHC.Enum"-    unsafeCoerceM             = Module "Unsafe.Coerce"-    networkGrpcHighLevelGeneratedM   = Module "Network.GRPC.HighLevel.Generated"-    networkGrpcHighLevelServerM      = Module "Network.GRPC.HighLevel.Server"-    networkGrpcHighLevelClientM      = Module "Network.GRPC.HighLevel.Client"-    networkGrpcHighLevelServerUnregM = Module "Network.GRPC.HighLevel.Server.Unregistered"--#ifdef DHALL-    proto3SuiteDhallPBM       = Module "Proto3.Suite.DhallPB"-#endif--    grpcNS                    = Module "HsGRPC"-    jsonpbNS                  = Module "HsJSONPB"-    protobufNS                = Module "HsProtobuf"-    proxyNS                   = Module "Proxy"--    importSym = HsIAbs . HsIdent--haskellNS :: Module-haskellNS = Module "Hs"--defaultMessageDeriving :: [HsQName]-defaultMessageDeriving = map haskellName [ "Show", "Eq", "Ord", "Generic", "NFData" ]--defaultEnumDeriving :: [HsQName]-defaultEnumDeriving = map haskellName [ "Show", "Bounded", "Eq", "Ord", "Generic", "NFData" ]--defaultServiceDeriving :: [HsQName]-defaultServiceDeriving = map haskellName [ "Generic" ]---- * Wrappers around haskell-src-exts constructors--apply :: HsExp -> [HsExp] -> HsExp-apply f = HsParen . foldl HsApp f--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 l--importDecl_ :: Module -> Bool -> Maybe Module -> Maybe (Bool, [HsImportSpec]) -> HsImportDecl-importDecl_ = HsImportDecl l--dataDecl_ :: String -> [HsConDecl] -> [HsQName] -> HsDecl-dataDecl_ messageName = HsDataDecl l [] (HsIdent messageName) []--recDecl_ :: HsName -> [([HsName], HsBangType)] -> HsConDecl-recDecl_ = HsRecDecl l--conDecl_ :: HsName -> [HsBangType] -> HsConDecl-conDecl_ = HsConDecl l--instDecl_ :: HsQName -> [HsType] -> [HsDecl] -> HsDecl-instDecl_ = HsInstDecl l []--match_ :: HsName -> [HsPat] -> HsRhs -> [HsDecl] -> HsMatch-match_ = HsMatch l--unqual_ :: String -> HsQName-unqual_ = UnQual . HsIdent--protobufType_, primType_ :: String -> HsType-protobufType_ = HsTyCon . protobufName-primType_ = HsTyCon . haskellName--type_ :: String -> HsType-type_ = HsTyCon . unqual_--patVar :: String -> HsPat-patVar =  HsPVar . HsIdent--alt_ :: HsPat -> HsGuardedAlts -> [HsDecl] -> HsAlt-alt_ = HsAlt l+{-# LANGUAGE CPP                       #-}+{-# LANGUAGE DataKinds                 #-}+{-# 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(..)+  , TypeContext+  , CompileArgs(..)+  , compileDotProtoFile+  , compileDotProtoFileOrDie+  , hsModuleForDotProto+  , renderHsModuleForDotProto+  , readDotProtoWithContext+  ) where++import           Control.Applicative+import           Control.Lens                   ((&), ix, over, has, filtered)+import           Control.Monad.Except+import           Data.Char+import           Data.Coerce+import           Data.Either                    (partitionEithers)+import           Data.List                      (find, intercalate, nub, sortBy, stripPrefix)+import qualified Data.List.NonEmpty             as NE+import qualified Data.Map                       as M+import           Data.Maybe                     (fromMaybe)+import           Data.Monoid+import           Data.Ord                       (comparing)+import qualified Data.Set                       as S+import           Data.String                    (fromString)+import qualified Data.Text                      as T+import           Filesystem.Path.CurrentOS      ((</>), (<.>))+import qualified Filesystem.Path.CurrentOS      as FP+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           Proto3.Suite.DotProto.Internal+import           Proto3.Suite.DotProto.Rendering (Pretty(..))+import           Proto3.Wire.Types              (FieldNumber (..))+import           System.IO                      (writeFile, readFile)+import qualified Turtle+import           Turtle                         (FilePath)+++--+-- * Public interface+--++data CompileArgs = CompileArgs+  { includeDir         :: [FilePath]+  , extraInstanceFiles :: [FilePath]+  , inputProto         :: FilePath+  , outputDir          :: FilePath+  }++-- | 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++    Turtle.mktree (Turtle.directory modulePath)++    extraInstances <- foldMapM getExtraInstances extraInstanceFiles++    haskellModule <- renderHsModuleForDotProto extraInstances dotProto importTypeContext++    liftIO (writeFile (FP.encodeString modulePath) haskellModule)++-- | 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 ()++-- | 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+    => ([HsImportDecl],[HsDecl]) -> DotProto -> TypeContext -> m String+renderHsModuleForDotProto extraInstanceFiles dotProto importCtxt = do+    haskellModule <- hsModuleForDotProto extraInstanceFiles dotProto importCtxt+    return (T.unpack header ++ prettyPrint haskellModule)+  where+    header = [Neat.text|+      {-# 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 #-}++      -- | Generated by Haskell protocol buffer compiler. DO NOT EDIT!+    |]++-- | Compile a Haskell module AST given a 'DotProto' package AST.+-- Instances given in @eis@ override those otherwise generated.+hsModuleForDotProto+    :: MonadError CompileError m+    => ([HsImportDecl], [HsDecl])+    -- ^ Extra user-define instances that override default generated instances+    -> DotProto+    -- ^+    -> TypeContext+    -- ^+    -> m HsModule+hsModuleForDotProto+    (extraImports, extraInstances)+    dotProto@DotProto{ protoMeta = DotProtoMeta { metaModulePath = modulePath }+                     , protoPackage+                     , protoDefinitions+                     }+    importTypeContext+  = do+       packageIdentifier <- protoPackageName protoPackage+       moduleName <- modulePathModName modulePath++       typeContextImports <- ctxtImports importTypeContext++       let hasService = has (traverse._DotProtoService) protoDefinitions++       let importDeclarations =+             concat [ defaultImports hasService, extraImports, typeContextImports ]++       typeContext <- dotProtoTypeContext dotProto++       let toDotProtoDeclaration =+             dotProtoDefinitionD packageIdentifier (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 (FP.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++    -- 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+      importPkg <- protoPackageName (protoPackage import_)++      let fixImportTyInfo tyInfo =+             tyInfo { dotProtoTypeInfoPackage    = DotProtoPackageSpec importPkg+                    , dotProtoTypeInfoModulePath = metaModulePath . protoMeta $ import_+                    }+      importTypeContext <- fmap fixImportTyInfo <$> dotProtoTypeContext import_++      qualifiedTypeContext <- mapKeysM (concatDotProtoIdentifier importPkg) 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.+ctxtImports :: MonadError CompileError m => TypeContext -> m [HsImportDecl]+ctxtImports = fmap (map mkImport . nub)+            . 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+                      => DotProtoTypeInfo -> DotProtoIdentifier -> m HsType+msgTypeFromDpTypeInfo DotProtoTypeInfo{..} ident = do+    modName   <- modulePathModName dotProtoTypeInfoModulePath+    identName <- qualifiedMessageName dotProtoTypeInfoParent ident+    pure $ HsTyCon (Qual modName (HsIdent identName))++haskellName, jsonpbName, grpcName, protobufName, proxyName :: String -> HsQName+haskellName  name = Qual (Module "Hs")         (HsIdent name)+jsonpbName   name = Qual (Module "HsJSONPB")   (HsIdent name)+grpcName     name = Qual (Module "HsGRPC")     (HsIdent name)+protobufName name = Qual (Module "HsProtobuf") (HsIdent name)+proxyName    name = Qual (Module "Proxy")      (HsIdent name)++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++dhallInterpretInstDecl :: String -> HsDecl+dhallInterpretInstDecl typeName =+  instDecl_ (dhallPBName "Interpret")+            [ type_ typeName ]+            [ ]++dhallInjectInstDecl :: String -> HsDecl+dhallInjectInstDecl typeName =+  instDecl_ (dhallPBName "Inject")+            [ type_ typeName ]+            [ ]+#endif++-- ** Helpers to wrap/unwrap types for protobuf (de-)serialization++coerceE :: Bool -> HsType -> HsType -> Maybe HsExp+coerceE _ from to | from == to = Nothing+coerceE unsafe from to = Just $ HsApp (HsApp coerceF (typeApp from)) (typeApp to)+  where+    -- Do not add linebreaks to typeapps as that causes parse errors+    pp = prettyPrintStyleMode style{mode=OneLineMode} defaultMode+    typeApp ty = uvar_ ("@("++ pp ty ++ ")")+    coerceF | unsafe = HsVar (haskellName "unsafeCoerce")+            | otherwise  = HsVar (haskellName "coerce")++wrapE :: MonadError CompileError m => TypeContext -> [DotProtoOption] -> DotProtoType -> HsExp -> m HsExp+wrapE ctxt opts dpt e = maybe e (\f -> apply f [e]) <$>+  (coerceE (isMap dpt) <$> dptToHsType ctxt dpt <*> dptToHsTypeWrapped opts ctxt dpt)++unwrapE :: MonadError CompileError m => TypeContext -> [DotProtoOption] -> DotProtoType -> HsExp -> m HsExp+unwrapE ctxt opts dpt e = maybe e (\f -> apply f [e]) <$>+   (coerceE (isMap dpt) <$> overParser (dptToHsTypeWrapped opts ctxt dpt) <*> overParser (dptToHsType ctxt dpt))+  where+    overParser = fmap $ HsTyApp (HsTyVar (HsIdent "_"))+++--------------------------------------------------------------------------------+--+-- * Functions to convert 'DotProtoType' into Haskell types+--++-- | Convert a dot proto type to a Haskell type+dptToHsType :: MonadError CompileError m => TypeContext -> DotProtoType -> m HsType+dptToHsType = foldDPT dptToHsContType dpptToHsType++-- | Convert a dot proto type to a wrapped Haskell type+dptToHsTypeWrapped :: MonadError CompileError m => [DotProtoOption] -> TypeContext -> DotProtoType -> m HsType+dptToHsTypeWrapped opts =+   foldDPT+     -- The wrapper for the collection type replaces the native haskell+     -- collection type, so try that first.+     (\ctxt ty -> maybe (dptToHsContType ctxt ty) id (dptToHsWrappedContType ctxt opts ty))+     -- Always wrap the primitive type.+     (\ctxt ty -> dpptToHsTypeWrapper ty <$> dpptToHsType ctxt ty)++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 -> 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).+dptToHsWrappedContType :: TypeContext -> [DotProtoOption] -> DotProtoType -> Maybe (HsType -> HsType)+dptToHsWrappedContType ctxt opts = \case+  Prim (Named tyName)+    | 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.+dptToHsContType :: TypeContext -> DotProtoType -> HsType -> HsType+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"+  _                  -> id++-- | Haskell wrapper for primitive dot proto types+dpptToHsTypeWrapper :: DotProtoPrimType -> HsType -> HsType+dpptToHsTypeWrapper = \case+  SInt32   -> HsTyApp (protobufType_ "Signed")+  SInt64   -> HsTyApp (protobufType_ "Signed")+  SFixed32 -> HsTyApp (protobufType_ "Signed") . HsTyApp (protobufType_ "Fixed")+  SFixed64 -> HsTyApp (protobufType_ "Signed") . HsTyApp (protobufType_ "Fixed")+  Fixed32  -> HsTyApp (protobufType_ "Fixed")+  Fixed64  -> HsTyApp (protobufType_ "Fixed")+  _        -> id++-- | Convert a dot proto prim type to an unwrapped Haskell type+dpptToHsType :: MonadError CompileError m => TypeContext -> DotProtoPrimType -> m HsType+dpptToHsType 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_ "Text"+  Bytes    -> pure $ primType_ "ByteString"+  Bool     -> pure $ primType_ "Bool"+  Float    -> pure $ primType_ "Float"+  Double   -> pure $ primType_ "Double"+  Named msgName ->+    case M.lookup msgName ctxt of+      Just ty@(DotProtoTypeInfo { dotProtoTypeInfoKind = DotProtoKindEnum }) ->+          HsTyApp (protobufType_ "Enumerated") <$> msgTypeFromDpTypeInfo ty msgName+      Just ty -> msgTypeFromDpTypeInfo 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+                    => DotProtoIdentifier -> TypeContext -> DotProtoDefinition -> m [HsDecl]+dotProtoDefinitionD pkgIdent ctxt = \case+  DotProtoMessage _ messageName messageParts ->+    dotProtoMessageD ctxt Anonymous messageName messageParts++  DotProtoEnum _ enumName enumParts ->+    dotProtoEnumD Anonymous enumName enumParts++  DotProtoService _ serviceName serviceParts ->+    dotProtoServiceD pkgIdent 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+    => TypeContext+    -> DotProtoIdentifier+    -> DotProtoIdentifier+    -> [DotProtoMessagePart]+    -> m [HsDecl]+dotProtoMessageD ctxt parentIdent messageIdent messageParts = do+    messageName <- qualifiedMessageName parentIdent messageIdent++    let mkDataDecl flds =+           dataDecl_ messageName+                     [ recDecl_ (HsIdent messageName) flds ]+                     defaultMessageDeriving++    let getName = \case+          DotProtoMessageField fld     -> [dotProtoFieldName fld]+          DotProtoMessageOneOf ident _ -> [ident]+          _                            -> []++    foldMapM id+      [ sequence+          [ mkDataDecl <$> foldMapM (messagePartFieldD messageName) messageParts+          , 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)++          -- And the Swagger ToSchema instance corresponding to JSONPB encodings+          , toSchemaInstanceDeclaration messageName Nothing+              =<< foldMapM (traverse dpIdentUnqualName . getName) messageParts++#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++    messagePartFieldD :: String -> DotProtoMessagePart -> m [([HsName], HsBangType)]+    messagePartFieldD messageName (DotProtoMessageField DotProtoField{..}) = do+      fullName <- prefixedFieldName messageName =<< dpIdentUnqualName dotProtoFieldName+      fullTy <- dptToHsType 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 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)++      toSchemaInstance <- toSchemaInstanceDeclaration fullName (Just idents)+                            =<< mapM (dpIdentUnqualName . dotProtoFieldName) fields++      pure [ dataDecl_ fullName cons defaultMessageDeriving+           , namedInstD fullName+           , toSchemaInstance++#ifdef DHALL+           , dhallInterpretInstDecl fullName+           , dhallInjectInstDecl fullName+#endif+           ]++    oneOfCons :: String -> DotProtoField -> m (HsConDecl, HsName)+    oneOfCons fullName DotProtoField{..} = do+       consTy <- case dotProtoFieldType of+            Prim msg@(Named msgName)+              | isMessage ctxt' msgName+                -> -- Do not wrap message summands with Maybe.+                   dpptToHsType ctxt' msg++            _   -> dptToHsType 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+    => 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 encodeMessageDecl = match_ (HsIdent "encodeMessage")+                                    [HsPWildCard, HsPRec (unqual_ msgName) punnedFieldsP]+                                    (HsUnGuardedRhs encodeMessageE) []++         encodeMessageE = apply mconcatE [HsList encodedFields]++         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 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 ctxt options dpType+                     . (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 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))++              alts <- unwrapE ctxt options dpType decodeMessageFieldE++              pure $ HsTuple+                   [ fieldNumberE fieldNumber+                   , HsInfixApp (apply pureE [ fE ]) apOp alts+                   ]+++-- *** Generate ToJSONPB/FromJSONPB instances++toJSONPBMessageInstD+    :: MonadError CompileError m+    => TypeContext+    -> DotProtoIdentifier+    -> DotProtoIdentifier+    -> [DotProtoMessagePart]+    -> m HsDecl+toJSONPBMessageInstD _ctxt parentIdent msgIdent messageParts = do+    msgName    <- qualifiedMessageName parentIdent msgIdent+    qualFields <- getQualifiedFields msgName messageParts++    let applyE nm oneofNm =+          apply (HsVar (jsonpbName nm))+                [ HsList (foldQF defPairE (oneofCaseE oneofNm) <$> qualFields) ]++    let patBinder = foldQF (const fieldBinder) (oneofSubDisjunctBinder . subfields)+    let matchE nm appNm oneofAppNm =+          match_+            (HsIdent nm)+            [ HsPApp (unqual_ msgName)+                     (patVar . patBinder <$> qualFields) ]+            (HsUnGuardedRhs (applyE appNm oneofAppNm))+            []++    pure $ instDecl_ (jsonpbName "ToJSONPB")+                     [ type_ msgName ]+                     [ HsFunBind [matchE "toJSONPB"     "object" "objectOrNull"]+                     , HsFunBind [matchE "toEncodingPB" "pairs"  "pairsOrNull" ]+                     ]++  where+    -- E.g.+    -- "another" .= f2 -- always succeeds (produces default value on missing field)+    defPairE fldName fldNum =+      HsInfixApp (str_ (coerce fldName))+                 toJSONPBOp+                 (uvar_ (fieldBinder fldNum))++    -- E.g.+    -- HsJSONPB.pair "name" f4 -- fails on missing field+    pairE fldNm varNm =+      apply (HsVar (jsonpbName "pair"))+            [ str_ (coerce fldNm) , uvar_ varNm]++    -- 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 retJsonCtor (OneofField typeName subfields) =+        HsParen+          $ HsLet [ HsFunBind [ match_ (HsIdent caseName) [] (HsUnGuardedRhs caseExpr) [] ] ]+          $ HsLambda l [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+++        -- E.g.+        -- case f4_or_f9 of+        --   Just (SomethingPickOneName f4)+        --     -> HsJSONPB.pair "name" f4+        --   Just (SomethingPickOneSomeid f9)+        --     -> HsJSONPB.pair "someid" f9+        --   Nothing+        --     -> mempty+        caseExpr = HsParen $+            HsCase disjunctName (altEs <> [fallthroughE])+          where+            disjunctName = uvar_ (oneofSubDisjunctBinder subfields)+            altEs = do+              sub@(OneofSubfield _ conName pbFldNm _ _) <- subfields+              let patVarNm = oneofSubBinder sub+              pure $ alt_ (HsPApp (haskellName "Just")+                                  [ HsPParen+                                    (HsPApp (unqual_ conName) [patVar patVarNm])+                                  ]+                          )+                          (HsUnGuardedAlt (pairE pbFldNm patVarNm))+                          []+            fallthroughE =+              alt_ (HsPApp (haskellName "Nothing") [])+                   (HsUnGuardedAlt memptyE)+                   []++fromJSONPBMessageInstD+    :: MonadError CompileError m+    => TypeContext+    -> DotProtoIdentifier+    -> DotProtoIdentifier+    -> [DotProtoMessagePart]+    -> m HsDecl+fromJSONPBMessageInstD _ctxt parentIdent msgIdent messageParts = do+    msgName    <- qualifiedMessageName parentIdent msgIdent+    qualFields <- getQualifiedFields msgName messageParts++    let parseJSONPBE =+          apply (HsVar (jsonpbName "withObject"))+                [ str_ msgName+                , HsParen (HsLambda l [lambdaPVar] fieldAps)+                ]+          where+            fieldAps = foldl (\f -> HsInfixApp f apOp)+                             (apply pureE [ uvar_ msgName ])+                             (foldQF normalParserE oneofParserE <$> qualFields)++    let parseJSONPBDecl =+          match_ (HsIdent "parseJSONPB") [] (HsUnGuardedRhs parseJSONPBE) []++    pure (instDecl_ (jsonpbName "FromJSONPB")+                   [ type_ msgName ]+                   [ HsFunBind [ parseJSONPBDecl ] ])+  where+    lambdaPVar = patVar "obj"+    lambdaVar  = uvar_ "obj"++    -- 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 oneofType fields) =+        HsParen $+          HsLet [ HsFunBind [ match_ (HsIdent letBndStr) [patVar letArgStr ]+                                     (HsUnGuardedRhs tryParseDisjunctsE) []+                            ]+                ]+                (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 =+            HsApp msumE (HsList (map subParserE fields <> fallThruE))+          where+            fallThruE+              = [ HsApp pureE (HsVar (haskellName "Nothing")) ]+            subParserE OneofSubfield{subfieldConsName, subfieldName}+              = HsInfixApp+                  (HsInfixApp (HsVar (haskellName "Just"))+                              composeOp+                              (uvar_ subfieldConsName))+                  fmapOp+                  (apply (HsVar (jsonpbName "parseField"))+                         [ letArgName+                         , str_ (coerce subfieldName)])++    -- E.g. obj .: "someid"+    normalParserE fldNm _ =+      HsInfixApp lambdaVar+                 parseJSONPBOp+                 (str_(coerce fldNm))++-- *** 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++toSchemaInstanceDeclaration+    :: MonadError CompileError m+    => String+    -- ^ Name of the message type to create an instance for+    -> Maybe [HsName]+    -- ^ Oneof constructors+    -> [String]+    -- ^ Field names+    -> m HsDecl+toSchemaInstanceDeclaration messageName maybeConstructors fieldNames = do+  qualifiedFieldNames <- mapM (prefixedFieldName messageName) fieldNames++  let messageConstructor = HsCon (UnQual (HsIdent messageName))++  let _namedSchemaNameExpression = HsApp justC (str_ messageName)++      -- { _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++  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 fieldName = 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 =+          HsDo (bindingStatements ++ inferenceStatement ++ [ returnStatement ])+        where+          bindingStatements = do+            (fieldName, qualifiedFieldName) <- zip fieldNames qualifiedFieldNames++            let declareIdentifier = HsIdent (toDeclareName fieldName)++            let stmt0 = HsLetStmt [ HsFunBind+                                    [ HsMatch l declareIdentifier []+                                               (HsUnGuardedRhs (HsVar (jsonpbName "declareSchemaRef"))) []+                                    ]+                                  ]++            let stmt1 = HsGenerator l (HsPVar (HsIdent qualifiedFieldName))+                                      (HsApp (HsVar (UnQual declareIdentifier))+                                             (HsCon (proxyName "Proxy")))+            [ stmt0, stmt1]+++          inferenceStatement =+              if null fieldNames then [] else [ HsLetStmt [ patternBind ] ]+            where+              arguments = map toArgument fieldNames++              patternBind = HsPatBind l HsPWildCard+                                        (HsUnGuardedRhs (applicativeApply messageConstructor arguments)) []++          returnStatement = HsQualifier (HsApp returnE (HsParen namedSchema))++      -- 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 =+          HsDo (bindingStatements ++ [ returnStatement ])+        where+          bindingStatements = do+            (fieldName, qualifiedFieldName, constructor)+                <- zip3 fieldNames qualifiedFieldNames constructors++            let declareIdentifier = HsIdent (toDeclareName fieldName)++            let stmt0 = HsLetStmt [ HsFunBind+                                      [ HsMatch l declareIdentifier []+                                                 (HsUnGuardedRhs (HsVar (jsonpbName "declareSchemaRef"))) []+                                      ]+                                  ]+            let stmt1 = HsGenerator l (HsPVar (HsIdent qualifiedFieldName))+                                      (HsApp (HsVar (UnQual declareIdentifier))+                                             (HsCon (proxyName "Proxy")))+            let inferenceStatement =+                    if null fieldNames then [] else [ HsLetStmt [ patternBind ] ]+                  where+                    arguments = [ toArgument fieldName ]++                    patternBind = HsPatBind l HsPWildCard+                                              (HsUnGuardedRhs (applicativeApply (HsCon (UnQual constructor)) arguments)) []++            [stmt0, stmt1] ++ inferenceStatement+++          returnStatement = HsQualifier (HsApp returnE (HsParen namedSchema))++  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+                  expression = case maybeConstructors of+                      Nothing           -> expressionForMessage+                      Just constructors -> expressionForOneOf constructors++                  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 <- fmap (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+    => DotProtoIdentifier+    -> TypeContext+    -> DotProtoIdentifier+    -> [DotProtoServicePart]+    -> m [HsDecl]+dotProtoServiceD pkgIdent ctxt serviceIdent service = do+     serviceName <- typeLikeName =<< dpIdentUnqualName serviceIdent+     packageName <- dpIdentQualName pkgIdent++     let endpointPrefix = "/" ++ packageName ++ "." ++ serviceName ++ "/"++     let serviceFieldD (DotProtoServiceRPCMethod RPCMethod{..}) = do+           fullName <- prefixedFieldName 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+                  , 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 l [ 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"+                               ]+                      ]+                      (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"+                 ]+++     let clientT = tyApp (HsTyCon (unqual_ serviceName)) [ clientRequestT, clientResultT ]++     let serviceClientTypeD =+             HsTypeSig l [ 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 l  [] (HsIdent serviceName)+                [ HsIdent "request", HsIdent "response" ]+                [ conDecl ] defaultServiceDeriving++          , serviceServerTypeD+          , serviceServerD++          , serviceClientTypeD+          , serviceClientD+          ]++--------------------------------------------------------------------------------++--+-- * Common Haskell expressions, constructors, and operators+--++dotProtoFieldC, primC, optionalC, repeatedC, nestedRepeatedC, namedC, mapC,+  fieldNumberC, singleC, dotsC, pathC, nestedC, anonymousC, dotProtoOptionC,+  identifierC, stringLitC, intLitC, floatLitC, boolLitC, trueC, falseC,+  unaryHandlerC, clientStreamHandlerC, serverStreamHandlerC, biDiStreamHandlerC,+  methodNameC, nothingC, justC, forceEmitC, mconcatE, encodeMessageFieldE,+  fromStringE, decodeMessageFieldE, pureE, returnE, memptyE, msumE, atE, oneofE,+  fmapE, defaultOptionsE, serverLoopE, convertServerHandlerE,+  convertServerReaderHandlerE, convertServerWriterHandlerE,+  convertServerRWHandlerE, clientRegisterMethodE, clientRequestE :: HsExp++dotProtoFieldC       = HsVar (protobufName "DotProtoField")+primC                = HsVar (protobufName "Prim")+optionalC            = HsVar (protobufName "Optional")+repeatedC            = HsVar (protobufName "Repeated")+nestedRepeatedC      = HsVar (protobufName "NestedRepeated")+namedC               = HsVar (protobufName "Named")+mapC                 = HsVar (protobufName "Map")+fieldNumberC         = HsVar (protobufName "FieldNumber")+singleC              = HsVar (protobufName "Single")+pathC                = HsVar (protobufName "Path")+dotsC                = HsVar (protobufName "Dots")+nestedC              = HsVar (protobufName "Nested")+anonymousC           = HsVar (protobufName "Anonymous")+dotProtoOptionC      = HsVar (protobufName "DotProtoOption")+identifierC          = HsVar (protobufName "Identifier")+stringLitC           = HsVar (protobufName "StringLit")+intLitC              = HsVar (protobufName "IntLit")+floatLitC            = HsVar (protobufName "FloatLit")+boolLitC             = HsVar (protobufName "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")+mconcatE                    = HsVar (haskellName "mconcat")+fromStringE                 = HsVar (haskellName "fromString")+pureE                       = HsVar (haskellName "pure")+returnE                     = HsVar (haskellName "return")+memptyE                     = HsVar (haskellName "mempty")+msumE                       = HsVar (haskellName "msum")+fmapE                       = HsVar (haskellName "fmap")++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")++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++-- ** 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 nestedC [ 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 (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 = HsVar . protobufName 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 :: Bool -> [HsImportDecl]+defaultImports usesGrpc =+    [ 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 protobufNS & 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 "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 "Data.Text.Lazy")        & qualified haskellNS  & selecting  [i"Text"]+    , 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 "Unsafe.Coerce")         & qualified haskellNS  & everything+    ]+    <>+    (if not usesGrpc 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"]+    ])+  where+    m = Module+    i = HsIVar . HsIdent+    s = HsIVar . HsSymbol++    grpcNS                    = m "HsGRPC"+    jsonpbNS                  = m "HsJSONPB"+    protobufNS                = m "HsProtobuf"+    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++haskellNS :: Module+haskellNS = Module "Hs"++defaultMessageDeriving :: [HsQName]+defaultMessageDeriving = map haskellName [ "Show", "Eq", "Ord", "Generic", "NFData" ]++defaultEnumDeriving :: [HsQName]+defaultEnumDeriving = map haskellName [ "Show", "Eq", "Generic", "NFData" ]++defaultServiceDeriving :: [HsQName]+defaultServiceDeriving = map haskellName [ "Generic" ]++--------------------------------------------------------------------------------+--+-- * Wrappers around haskell-src-exts constructors+--++apply :: HsExp -> [HsExp] -> HsExp+apply f = HsParen . foldl HsApp f++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 l++importDecl_ :: Module -> Bool -> Maybe Module -> Maybe (Bool, [HsImportSpec]) -> HsImportDecl+importDecl_ = HsImportDecl l++dataDecl_ :: String -> [HsConDecl] -> [HsQName] -> HsDecl+dataDecl_ messageName = HsDataDecl l [] (HsIdent messageName) []++recDecl_ :: HsName -> [([HsName], HsBangType)] -> HsConDecl+recDecl_ = HsRecDecl l++conDecl_ :: HsName -> [HsBangType] -> HsConDecl+conDecl_ = HsConDecl l++instDecl_ :: HsQName -> [HsType] -> [HsDecl] -> HsDecl+instDecl_ = HsInstDecl l []++match_ :: HsName -> [HsPat] -> HsRhs -> [HsDecl] -> HsMatch+match_ = HsMatch l++unqual_ :: String -> HsQName+unqual_ = UnQual . HsIdent++uvar_ :: String -> HsExp+uvar_ = HsVar . unqual_++protobufType_, primType_ :: String -> HsType+protobufType_ = HsTyCon . protobufName+primType_ = HsTyCon . haskellName++type_ :: String -> HsType+type_ = HsTyCon . unqual_++patVar :: String -> HsPat+patVar =  HsPVar . HsIdent++alt_ :: HsPat -> HsGuardedAlts -> [HsDecl] -> HsAlt+alt_ = HsAlt l++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

@@ -1,3 +1,4 @@+{-# LANGUAGE CPP                 #-} {-# LANGUAGE DataKinds           #-} {-# LANGUAGE FlexibleInstances   #-} {-# LANGUAGE FlexibleContexts    #-}@@ -17,7 +18,11 @@   ) where +#if MIN_VERSION_swagger2(2,4,0)+import           Control.Lens                    ((&), (?~))+#else import           Control.Lens                    ((&), (.~), (?~))+#endif import           Data.Aeson                      (Value (String)) import           Data.Aeson.Encode.Pretty        (encodePretty) import           Data.ByteString                 (ByteString)@@ -55,7 +60,11 @@   declareNamedSchema _ = return (NamedSchema Nothing schema_)     where       schema_ = mempty+#if MIN_VERSION_swagger2(2,4,0)+        & type_ ?~ SwaggerArray+#else         & type_ .~ SwaggerArray+#endif         & items ?~ SwaggerItemsObject (Inline byteSchema)  {-| This is a convenience function that uses type inference to select the@@ -66,7 +75,7 @@  -- | Pretty-prints a schema. Useful when playing around with schemas in the -- REPL.-ppSchema :: ToSchema a => proxy a -> IO ()+ppSchema :: ToSchema a => Proxy a -> IO () ppSchema = LC8.putStrLn . encodePretty . toSchema  -- | JSONPB schemas for protobuf enumerations@@ -77,7 +86,11 @@     let enumMemberNames = dropPrefix . fst <$> enumerate (proxy# :: Proxy# e)     return $ NamedSchema (Just enumName)            $ mempty+#if MIN_VERSION_swagger2(2,4,0)+             & type_ ?~ SwaggerString+#else              & type_ .~ SwaggerString+#endif              & enum_ ?~ fmap String enumMemberNames  instance ToSchema (Fixed Int32) where

@@ -1,31 +1,84 @@ -- | This module provides misc internal helpers and utilities +{-# LANGUAGE CPP               #-}+{-# LANGUAGE FlexibleContexts  #-} {-# LANGUAGE LambdaCase        #-}+{-# LANGUAGE MultiWayIf        #-}+{-# LANGUAGE NamedFieldPuns    #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes       #-}+{-# LANGUAGE RankNTypes        #-}+{-# LANGUAGE RecordWildCards   #-}+{-# LANGUAGE TupleSections     #-} {-# LANGUAGE ViewPatterns      #-}  module Proto3.Suite.DotProto.Internal where +import           Control.Applicative import qualified Control.Foldl             as FL-import           Control.Lens              (over)+import           Control.Lens              (Lens', lens, over) import           Control.Lens.Cons         (_head)-import           Data.Char                 (toUpper)+import           Control.Monad+import           Control.Monad.Except+import           Data.Bifunctor            (first)+import           Data.Char+import           Data.Coerce+import           Data.Either+import           Data.Foldable+import           Data.Functor.Compose+import           Data.Int                  (Int32)+import           Data.List                 (find, 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           System.FilePath           (isPathSeparator)-import qualified Filesystem.Path.CurrentOS as FP+import           Data.Tuple                (swap) import           Filesystem.Path.CurrentOS ((</>))+import qualified Filesystem.Path.CurrentOS as FP import qualified NeatInterpolation         as Neat import           Prelude                   hiding (FilePath)-import           Proto3.Suite.DotProto+import           Proto3.Suite.DotProto.AST+import           Proto3.Suite.DotProto.AST.Lens+import           Proto3.Suite.DotProto.Parsing+import           Proto3.Wire.Types         (FieldNumber (..))+import           System.FilePath           (isPathSeparator) import           Text.Parsec               (ParseError)+import qualified Turtle import           Turtle                    (ExitCode (..), FilePath, MonadIO,                                             Text)-import qualified Turtle import           Turtle.Format             ((%)) import qualified Turtle.Format             as F +-------------------------------------------------------------------------------+--+-- * Utilities+--++#if !(MIN_VERSION_mtl(2,2,2))+liftEither :: MonadError e m => Either e a -> m a+liftEither = either throwError pure+#endif++-- | Like 'foldMap', but with an effectful projection.+foldMapM ::+  (Foldable t, Monad m, Monoid b, Semigroup b) => (a -> m b) -> t a -> m b+foldMapM f = foldM (\b a -> (b <>) <$> f a) mempty++-- | Like 'Control.Lens.Getter.Getting', but allows for retrieving the 'r'+-- element in some Applicative context 'm'.+type GettingM r s a = forall m. Applicative m => (a -> Compose m (Const r) a) -> s -> Compose m (Const r) s++-- | Given an effectful projection from 'a' into a monoid 'r', retrieve the sum+-- of all 'a' values in an 's' structure as targetted by the 'GettingM' optic.+-- Note that the Monoid constraint on 'r' is implicit via 'Const', but we+-- note it in the type for clarity.+foldMapOfM :: (Applicative m, Monoid r) => GettingM r s a -> (a -> m r) -> s -> m r+foldMapOfM l f = fmap getConst . getCompose . l (Compose . fmap Const . f)++mapKeysM :: (Monad m, Ord k2) => (k1 -> m k2) -> M.Map k1 a -> m (M.Map k2 a)+mapKeysM f = fmap M.fromList . traverse (fmap swap . traverse f . swap) . M.assocs+ -- $setup -- >>> :set -XOverloadedStrings @@ -34,6 +87,11 @@   mapM_ Turtle.err msg   Turtle.exit (ExitFailure 1) +--------------------------------------------------------------------------------+--+-- * Reading files+--+ -- | toModulePath takes an include-relative path to a .proto file and produces a -- "module path" which is used during code generation. --@@ -65,23 +123,23 @@ -- Left "path contained unexpected .. after canonicalization, please use form x.y.z.proto" -- -- >>> toModulePath "google/protobuf/timestamp.proto"--- Right (Path {components = ["Google","Protobuf","Timestamp"]})+-- Right (Path {components = "Google" :| ["Protobuf","Timestamp"]}) -- -- >>> toModulePath "a/b/c/google.protobuf.timestamp.proto"--- Right (Path {components = ["A","B","C","Google","Protobuf","Timestamp"]})+-- Right (Path {components = "A" :| ["B","C","Google","Protobuf","Timestamp"]}) -- -- >>> toModulePath "foo/FiLeName_underscore.and.then.some.dots.proto"--- Right (Path {components = ["Foo","FiLeName_underscore","And","Then","Some","Dots"]})+-- Right (Path {components = "Foo" :| ["FiLeName_underscore","And","Then","Some","Dots"]}) -- -- >>> toModulePath "foo/bar/././baz/../boggle.proto"--- Right (Path {components = ["Foo","Bar","Boggle"]})+-- Right (Path {components = "Foo" :| ["Bar","Boggle"]}) -- -- >>> toModulePath "./foo.proto"--- Right (Path {components = ["Foo"]})+-- Right (Path {components = "Foo" :| []}) -- -- NB: We ignore preceding single '.' characters -- >>> toModulePath ".foo.proto"--- Right (Path {components = ["Foo"]})+-- Right (Path {components = "Foo" :| []}) toModulePath :: FilePath -> Either String Path toModulePath fp0@(fromMaybe fp0 . FP.stripPrefix "./" -> fp)   | Turtle.absolute fp@@ -92,11 +150,11 @@     = case FP.stripPrefix "../" fp of         Just{}  -> Left "expected include-relative path, but the path started with ../"         Nothing-          | T.isInfixOf ".." (Turtle.format F.fp . FP.collapse $ fp)+          | T.isInfixOf ".." . Turtle.format F.fp . FP.collapse $ fp             -> Left "path contained unexpected .. after canonicalization, please use form x.y.z.proto"           | otherwise-            -> Right-             . Path+            -> maybe (Left "empty path after canonicalization") (Right . Path)+             . NE.nonEmpty              . dropWhile null -- Remove a potential preceding empty component which                               -- arose from a preceding '.' in the input path, which we                               -- want to ignore. E.g. ".foo.proto" => ["","Foo"].@@ -108,27 +166,55 @@              . Turtle.dropExtension              $ fp -fatalBadModulePath :: MonadIO m => FilePath -> String -> m a-fatalBadModulePath (Turtle.format F.fp -> fp) (T.pack -> rsn) =-  dieLines [Neat.text|-    Error: failed when computing the "module path" for "${fp}": ${rsn}--    Please ensure that the provided path to a .proto file is specified as-    relative to some --includeDir path and that it has the .proto suffix.-  |]- -- | @importProto searchPaths toplevel inc@ attempts to import include-relative -- @inc@ after locating it somewhere in the @searchPaths@; @toplevel@ is simply -- the path of toplevel .proto being processed so we can report it in an error -- message. This function terminates the program if it cannot find the file to -- import or if it cannot construct a valid module path from it.-importProto :: MonadIO m-            => [FilePath] -> FilePath -> FilePath -> m (Either ParseError DotProto)-importProto paths (Turtle.format F.fp -> toplevelProtoText) protoFP =+importProto :: (MonadIO m, MonadError CompileError m)+            => [FilePath] -> FilePath -> FilePath -> m DotProto+importProto paths toplevelProto protoFP =   findProto paths protoFP >>= \case-    Found mp fp     -> parseProtoFile mp fp-    BadModulePath e -> fatalBadModulePath protoFP e-    NotFound        -> dieLines [Neat.text|+    Left e+      -> dieLines (badModulePathErrorMsg protoFP e)+    Right Nothing+      | toplevelProto == protoFP+        -> dieLines (toplevelNotFoundErrorMsg paths toplevelProto)+      | otherwise+        -> dieLines (importNotFoundErrorMsg paths toplevelProto protoFP)+    Right (Just (mp, fp))+      -> liftEither . first CompileParseError =<< parseProtoFile mp fp++type FindProtoResult = Either String (Maybe (Path, FilePath))++-- | Attempts to locate the first (if any) filename that exists on the given+-- search paths, and constructs the "module path" from the given+-- include-relative filename (2nd parameter). Terminates the program with an+-- error if the given pathname is not relative.+findProto :: MonadIO m => [FilePath] -> FilePath -> m FindProtoResult+findProto searchPaths protoFP+  | Turtle.absolute protoFP = dieLines absolutePathErrorMsg+  | otherwise = forM (toModulePath protoFP) $ \mp ->+                  flip Turtle.fold FL.head $ do+                     sp <- Turtle.select searchPaths+                     let fp = sp </> protoFP+                     True <- Turtle.testfile fp+                     pure (mp, fp)++-- * Pretty Error Messages++badModulePathErrorMsg :: FilePath -> String -> T.Text+badModulePathErrorMsg (Turtle.format F.fp -> fp) (T.pack -> rsn) =+  [Neat.text|+    Error: failed when computing the "module path" for "${fp}": ${rsn}++    Please ensure that the provided path to a .proto file is specified as+    relative to some --includeDir path and that it has the .proto suffix.+  |]++importNotFoundErrorMsg :: [FilePath] -> FilePath -> FilePath -> T.Text+importNotFoundErrorMsg paths toplevelProto protoFP =+    [Neat.text|       Error: while processing include statements in "${toplevelProtoText}", failed       to find the imported file "${protoFPText}", after looking in the following       locations (controlled via the --includeDir switch(es)):@@ -136,39 +222,340 @@       $pathsText     |]   where-    pathsText   = T.unlines (Turtle.format ("  "%F.fp) . (</> protoFP) <$> paths)+    pathsText = T.unlines (Turtle.format ("  "%F.fp) . (</> protoFP) <$> paths)+    toplevelProtoText = Turtle.format F.fp toplevelProto     protoFPText = Turtle.format F.fp protoFP -data FindProtoResult-  = Found Path FilePath-  | NotFound-  | BadModulePath String-  deriving (Eq, Show)+toplevelNotFoundErrorMsg :: [FilePath] -> FilePath -> T.Text+toplevelNotFoundErrorMsg searchPaths toplevelProto =+    [Neat.text|+      Error: failed to find file "${toplevelProtoText}", after looking in+      the following locations (controlled via the --includeDir switch(es)): --- | Attempts to locate the first (if any) filename that exists on the given--- search paths, and constructs the "module path" from the given--- include-relative filename (2nd parameter). Terminates the program with an--- error if the given pathname is not relative.-findProto :: MonadIO m => [FilePath] -> FilePath -> m FindProtoResult-findProto searchPaths protoFP-  | Turtle.absolute protoFP = dieLines [Neat.text|-      Error: Absolute paths to .proto files, whether on the command line or-      in include directives, are not currently permitted; rather, all .proto-      filenames must be relative to the current directory, or relative to some-      search path specified via --includeDir.+      $searchPathsText+    |]+  where+    searchPathsText   = T.unlines (Turtle.format ("  "%F.fp) . (</> toplevelProto) <$> searchPaths)+    toplevelProtoText = Turtle.format F.fp toplevelProto -      This is because we currently use the include-relative name to decide-      the structure of the Haskell module tree that we emit during code-      generation.-      |]-  | otherwise = case toModulePath protoFP of-      Left e -> pure (BadModulePath e)-      Right mp -> do-        mfp <- flip Turtle.fold FL.head $ do-          sp <- Turtle.select searchPaths-          let fp = sp </> protoFP-          True <- Turtle.testfile fp-          pure fp-        case mfp of-          Nothing -> pure NotFound-          Just fp -> pure (Found mp fp)+absolutePathErrorMsg :: T.Text+absolutePathErrorMsg =+    [Neat.text|+     Error: Absolute paths to .proto files, whether on the command line or+     in include directives, are not currently permitted; rather, all .proto+     filenames must be relative to the current directory, or relative to some+     search path specified via --includeDir.++     This is because we currently use the include-relative name to decide+     the structure of the Haskell module tree that we emit during code+     generation.+    |]++--------------------------------------------------------------------------------+--+-- * Type context+--++-- | A mapping from .proto type identifiers to their type information+type TypeContext = M.Map DotProtoIdentifier DotProtoTypeInfo++-- | Information about messages and enumerations+data DotProtoTypeInfo = DotProtoTypeInfo+  { dotProtoTypeInfoPackage    :: DotProtoPackageSpec+     -- ^ The package this type is defined in+  , dotProtoTypeInfoParent     :: DotProtoIdentifier+    -- ^ The message this type is nested under, or 'Anonymous' if it's top-level+  , dotProtoTypeChildContext   :: TypeContext+    -- ^ The context that should be used for declarations within the+    --   scope of this type+  , dotProtoTypeInfoKind       :: DotProtoKind+    -- ^ Whether this type is an enumeration or message+  , dotProtoTypeInfoModulePath :: Path+    -- ^ The include-relative module path used when importing this module+  } deriving Show++tiParent :: Lens' DotProtoTypeInfo DotProtoIdentifier+tiParent = lens dotProtoTypeInfoParent (\d p -> d{ dotProtoTypeInfoParent = p })++-- | Whether a definition is an enumeration or a message+data DotProtoKind = DotProtoKindEnum+                  | DotProtoKindMessage+                  deriving (Show, Eq, Ord, Enum, Bounded)++-- ** Generating type contexts from ASTs++dotProtoTypeContext :: MonadError CompileError m => DotProto -> m TypeContext+dotProtoTypeContext DotProto{..} =+  foldMapM (definitionTypeContext (metaModulePath protoMeta)) protoDefinitions++definitionTypeContext :: MonadError CompileError m+                      => Path -> DotProtoDefinition -> m TypeContext+definitionTypeContext modulePath (DotProtoMessage _ msgIdent parts) = do+  let updateParent = tiParent (concatDotProtoIdentifier msgIdent)++  childTyContext <- foldMapOfM (traverse . _DotProtoMessageDefinition)+                               (definitionTypeContext modulePath >=> traverse updateParent)+                               parts++  qualifiedChildTyContext <- mapKeysM (concatDotProtoIdentifier msgIdent) childTyContext++  let tyInfo = DotProtoTypeInfo { dotProtoTypeInfoPackage = DotProtoNoPackage+                                , dotProtoTypeInfoParent =  Anonymous+                                , dotProtoTypeChildContext = childTyContext+                                , dotProtoTypeInfoKind = DotProtoKindMessage+                                , dotProtoTypeInfoModulePath = modulePath+                                }++  pure $ M.singleton msgIdent tyInfo <> qualifiedChildTyContext++definitionTypeContext modulePath (DotProtoEnum _ enumIdent _) = do+  let tyInfo = DotProtoTypeInfo { dotProtoTypeInfoPackage = DotProtoNoPackage+                                , dotProtoTypeInfoParent =  Anonymous+                                , dotProtoTypeChildContext = mempty+                                , dotProtoTypeInfoKind = DotProtoKindEnum+                                , dotProtoTypeInfoModulePath = modulePath+                                }+  pure (M.singleton enumIdent tyInfo)++definitionTypeContext _ _ = pure mempty+++isMessage :: TypeContext -> DotProtoIdentifier -> Bool+isMessage ctxt n = Just DotProtoKindMessage == (dotProtoTypeInfoKind <$> M.lookup n ctxt)++isPacked :: [DotProtoOption] -> Bool+isPacked opts =+    case find (\(DotProtoOption name _) -> name == Single "packed") opts of+        Just (DotProtoOption _ (BoolLit x)) -> x+        _ -> False++isUnpacked :: [DotProtoOption] -> Bool+isUnpacked opts =+    case find (\(DotProtoOption name _) -> name == Single "packed") opts of+        Just (DotProtoOption _ (BoolLit x)) -> not x+        _ -> False++-- | 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+-- packable.+isPackable :: TypeContext -> DotProtoPrimType -> Bool+isPackable _ Bytes    = False+isPackable _ String   = False+isPackable _ Int32    = True+isPackable _ Int64    = True+isPackable _ SInt32   = True+isPackable _ SInt64   = True+isPackable _ UInt32   = True+isPackable _ UInt64   = True+isPackable _ Fixed32  = True+isPackable _ Fixed64  = True+isPackable _ SFixed32 = True+isPackable _ SFixed64 = True+isPackable _ Bool     = True+isPackable _ Float    = True+isPackable _ Double   = True+isPackable ctxt (Named tyName) =+  Just DotProtoKindEnum == (dotProtoTypeInfoKind <$> M.lookup tyName ctxt)++isMap :: DotProtoType -> Bool+isMap Map{} = True+isMap _ = False++--------------------------------------------------------------------------------+--+-- * Name resolution+--++concatDotProtoIdentifier :: MonadError CompileError m+                         => DotProtoIdentifier -> DotProtoIdentifier -> m DotProtoIdentifier+concatDotProtoIdentifier i1 i2 = case (i1, i2) of+  (Qualified{}  ,  _           ) -> internalError "concatDotProtoIdentifier: Qualified"+  (_            , Qualified{}  ) -> internalError "concatDotProtoIdentifier Qualified"+  (Anonymous    , Anonymous    ) -> pure Anonymous+  (Anonymous    , b            ) -> pure b+  (a            , Anonymous    ) -> pure a+  (Single a     , b            ) -> concatDotProtoIdentifier (Dots (Path (pure a))) b+  (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++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++fieldLikeName :: String -> String+fieldLikeName ident@(c:_)+  | isUpper c = let (prefix, suffix) = span isUpper ident+                in map toLower prefix ++ suffix+fieldLikeName ident = ident++prefixedEnumFieldName :: String -> String -> String+prefixedEnumFieldName enumName fieldName = enumName <> fieldName++prefixedConName :: MonadError CompileError m => String -> String -> m String+prefixedConName msgName conName = (msgName ++) <$> typeLikeName conName++-- TODO: This should be ~:: MessageName -> FieldName -> ...; same elsewhere, the+-- String types are a bit of a hassle.+prefixedFieldName :: MonadError CompileError m => String -> String -> m String+prefixedFieldName msgName fieldName = (fieldLikeName msgName ++) <$> typeLikeName fieldName++dpIdentUnqualName :: MonadError CompileError m => DotProtoIdentifier -> m String+dpIdentUnqualName (Single name)       = pure name+dpIdentUnqualName (Dots (Path names)) = pure (NE.last names)+dpIdentUnqualName (Qualified _ next)  = dpIdentUnqualName next+dpIdentUnqualName Anonymous           = internalError "dpIdentUnqualName: Anonymous"++dpIdentQualName :: MonadError CompileError m => DotProtoIdentifier -> m String+dpIdentQualName (Single name)       = pure name+dpIdentQualName (Dots (Path names)) = pure (intercalate "." (NE.toList names))+dpIdentQualName (Qualified _ _)     = internalError "dpIdentQualName: Qualified"+dpIdentQualName Anonymous           = internalError "dpIdentQualName: Anonymous"++-- | Given a 'DotProtoIdentifier' for the parent type and the unqualified name+-- of this type, generate the corresponding Haskell name+nestedTypeName :: MonadError CompileError m => DotProtoIdentifier -> String -> m String+nestedTypeName Anonymous             nm = typeLikeName nm+nestedTypeName (Single parent)       nm = intercalate "_" <$> traverse typeLikeName [parent, nm]+nestedTypeName (Dots (Path parents)) nm = intercalate "_" . (<> [nm]) <$> traverse typeLikeName (NE.toList parents)+nestedTypeName (Qualified {})        _  = internalError "nestedTypeName: Qualified"++qualifiedMessageName :: MonadError CompileError m => DotProtoIdentifier -> DotProtoIdentifier -> m String+qualifiedMessageName parentIdent msgIdent = nestedTypeName parentIdent =<< dpIdentUnqualName msgIdent++--------------------------------------------------------------------------------+--+-- ** Codegen bookkeeping helpers+--++-- | Bookeeping for qualified fields+data QualifiedField = QualifiedField+  { recordFieldName :: FieldName+  , fieldInfo       :: FieldInfo+  } deriving Show++-- | Bookkeeping for fields+data FieldInfo+  = FieldOneOf OneofField+  | FieldNormal FieldName FieldNumber DotProtoType [DotProtoOption]+  deriving Show++-- | Bookkeeping for oneof fields+data OneofField = OneofField+  { oneofType :: String+  , subfields :: [OneofSubfield]+  } deriving Show++-- | Bookkeeping for oneof subfields+data OneofSubfield = OneofSubfield+  { subfieldNumber   :: FieldNumber+  , subfieldConsName :: String+  , subfieldName     :: FieldName+  , subfieldType     :: DotProtoType+  , subfieldOptions  :: [DotProtoOption]+  } deriving Show++getQualifiedFields :: MonadError CompileError m+                   => String -> [DotProtoMessagePart] -> m [QualifiedField]+getQualifiedFields msgName msgParts = flip foldMapM msgParts $ \case+  DotProtoMessageField DotProtoField{..} -> do+    fieldName <- dpIdentUnqualName dotProtoFieldName+    qualName  <- prefixedFieldName msgName fieldName+    pure . (:[]) $ QualifiedField { recordFieldName = coerce qualName+                                  , fieldInfo = FieldNormal (coerce fieldName)+                                                            dotProtoFieldNumber+                                                            dotProtoFieldType+                                                            dotProtoFieldOptions+                                  }++  DotProtoMessageOneOf _ [] ->+    throwError (InternalError "getQualifiedFields: encountered oneof with no oneof fields")++  DotProtoMessageOneOf oneofIdent fields -> do+    ident <- dpIdentUnqualName oneofIdent+    oneofName <- prefixedFieldName msgName ident+    oneofTypeName <- prefixedConName msgName ident++    let mkSubfield DotProtoField{..} = do+            s <- dpIdentUnqualName dotProtoFieldName+            c <- prefixedConName oneofTypeName s+            pure [OneofSubfield dotProtoFieldNumber c (coerce s) dotProtoFieldType dotProtoFieldOptions]+        mkSubfield DotProtoEmptyField = pure []++    fieldElems <- foldMapM mkSubfield fields++    pure . (:[]) $ QualifiedField { recordFieldName = coerce oneofName+                                  , fieldInfo = FieldOneOf (OneofField ident fieldElems)+                                  }+  _ -> pure []++-- | Project qualified fields, given a projection function per field type.+foldQF :: (FieldName -> FieldNumber -> a) -- ^ projection for normal fields+       -> (OneofField -> a)               -- ^ projection for oneof fields+       -> QualifiedField+       -> a+foldQF f _ (QualifiedField _ (FieldNormal fldName fldNum _ _)) = f fldName fldNum+foldQF _ g (QualifiedField _ (FieldOneOf fld))                 = g fld++fieldBinder :: FieldNumber -> String+fieldBinder = ("f" ++) . show++oneofSubBinder :: OneofSubfield -> String+oneofSubBinder = fieldBinder . subfieldNumber++oneofSubDisjunctBinder :: [OneofSubfield] -> String+oneofSubDisjunctBinder = intercalate "_or_" . fmap oneofSubBinder++--------------------------------------------------------------------------------+--+-- * Errors+--++data CompileError+  = CircularImport          FilePath+  | CompileParseError       ParseError+  | InternalError           String+  | InvalidPackageName      DotProtoIdentifier+  | InvalidMethodName       DotProtoIdentifier+  | InvalidTypeName         String+  | InvalidMapKeyType       String+  | NoPackageDeclaration+  | NoSuchType              DotProtoIdentifier+  | NonzeroFirstEnumeration String DotProtoIdentifier Int32+  | EmptyEnumeration        String+  | Unimplemented           String+  deriving (Show, Eq)+++internalError :: MonadError CompileError m => String -> m a+internalError = throwError . InternalError++invalidTypeNameError :: MonadError CompileError m => String -> m a+invalidTypeNameError = throwError . InvalidTypeName++_unimplementedError :: MonadError CompileError m => String -> m a+_unimplementedError = throwError . Unimplemented++invalidMethodNameError :: MonadError CompileError m => DotProtoIdentifier -> m a+invalidMethodNameError = throwError . InvalidMethodName++noSuchTypeError :: MonadError CompileError m => DotProtoIdentifier -> m a+noSuchTypeError = throwError . NoSuchType++protoPackageName :: MonadError CompileError m => DotProtoPackageSpec -> m DotProtoIdentifier+protoPackageName (DotProtoPackageSpec name) = pure name+protoPackageName DotProtoNoPackage = throwError NoPackageDeclaration