proto3-suite (empty) → 0.3.0.0
raw patch · 43 files changed
+10099/−0 lines, 43 filesdep +QuickCheckdep +aesondep +aeson-prettysetup-changedbinary-added
Dependencies added: QuickCheck, aeson, aeson-pretty, attoparsec, base, base64-bytestring, binary, bytestring, cereal, containers, contravariant, deepseq, dhall, doctest, filepath, foldl, hashable, haskell-src, insert-ordered-containers, lens, mtl, neat-interpolation, optparse-generic, parsec, parsers, pretty, pretty-show, proto3-suite, proto3-wire, quickcheck-instances, range-set-list, safe, semigroups, swagger2, system-filepath, tasty, tasty-hunit, tasty-quickcheck, text, transformers, turtle, vector
Files
- Setup.hs +2/−0
- gen/TestProto.hs +2424/−0
- gen/TestProtoImport.hs +202/−0
- gen/TestProtoOneof.hs +835/−0
- gen/TestProtoOneofImport.hs +166/−0
- proto3-suite.cabal +144/−0
- src/Proto3/Suite.hs +57/−0
- src/Proto3/Suite/Class.hs +739/−0
- src/Proto3/Suite/DhallPB.hs +177/−0
- src/Proto3/Suite/DotProto.hs +5/−0
- src/Proto3/Suite/DotProto/AST.hs +450/−0
- src/Proto3/Suite/DotProto/Generate.hs +2156/−0
- src/Proto3/Suite/DotProto/Generate/Swagger.hs +93/−0
- src/Proto3/Suite/DotProto/Internal.hs +174/−0
- src/Proto3/Suite/DotProto/Parsing.hs +344/−0
- src/Proto3/Suite/DotProto/Rendering.hs +221/−0
- src/Proto3/Suite/JSONPB.hs +50/−0
- src/Proto3/Suite/JSONPB/Class.hs +522/−0
- src/Proto3/Suite/Tutorial.hs +140/−0
- src/Proto3/Suite/Types.hs +119/−0
- test-files/all_packed_types.bin binary
- test-files/multiple_fields.bin binary
- test-files/signedints.bin +1/−0
- test-files/trivial.bin +1/−0
- test-files/trivial_negative.bin +1/−0
- test-files/with_bytes.bin +2/−0
- test-files/with_enum0.bin +0/−0
- test-files/with_enum1.bin +1/−0
- test-files/with_fixed.bin binary
- test-files/with_nesting.bin +3/−0
- test-files/with_nesting_ints.bin +3/−0
- test-files/with_nesting_maybe.bin +3/−0
- test-files/with_nesting_repeated.bin binary
- test-files/with_packing.bin +1/−0
- test-files/with_repetition.bin +2/−0
- tests/ArbitraryGeneratedTestTypes.hs +158/−0
- tests/Main.hs +318/−0
- tests/TestCodeGen.hs +257/−0
- tests/TestDhall.hs +23/−0
- tests/decode.sh +15/−0
- tests/encode.sh +15/−0
- tools/canonicalize-proto-file/Main.hs +247/−0
- tools/compile-proto-file/Main.hs +28/−0
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ gen/TestProto.hs view
@@ -0,0 +1,2424 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE GADTs #-}+{-# 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!+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.JSONPB as HsJSONPB+import Proto3.Suite.JSONPB ((.=), (.:))+import qualified Proto3.Wire as HsProtobuf+import Control.Applicative ((<*>), (<|>), (<$>))+import qualified Control.Applicative 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.String as Hs (fromString)+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 TestProtoImport+ +data Trivial = Trivial{trivialTrivialField :: Hs.Int32}+ deriving (Hs.Show, Hs.Eq, Hs.Ord, Hs.Generic)+ +instance HsProtobuf.Named Trivial where+ nameOf _ = (Hs.fromString "Trivial")+ +instance HsProtobuf.Message Trivial where+ encodeMessage _ Trivial{trivialTrivialField = trivialTrivialField}+ = (Hs.mconcat+ [(HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 1)+ trivialTrivialField)])+ decodeMessage _+ = (Hs.pure Trivial) <*>+ (HsProtobuf.at HsProtobuf.decodeMessageField+ (HsProtobuf.FieldNumber 1))+ dotProto _+ = [(HsProtobuf.DotProtoField (HsProtobuf.FieldNumber 1)+ (HsProtobuf.Prim HsProtobuf.Int32)+ (HsProtobuf.Single "trivialField")+ []+ Hs.Nothing)]+ +instance HsJSONPB.ToJSONPB Trivial where+ toJSONPB (Trivial f1) = (HsJSONPB.object ["trivialField" .= f1])+ toEncodingPB (Trivial f1) = (HsJSONPB.pairs ["trivialField" .= f1])+ +instance HsJSONPB.FromJSONPB Trivial where+ parseJSONPB+ = (HsJSONPB.withObject "Trivial"+ (\ obj -> (Hs.pure Trivial) <*> obj .: "trivialField"))+ +instance HsJSONPB.ToJSON Trivial where+ toJSON = HsJSONPB.toAesonValue+ toEncoding = HsJSONPB.toAesonEncoding+ +instance HsJSONPB.FromJSON Trivial where+ parseJSON = HsJSONPB.parseJSONPB+ +instance HsJSONPB.ToSchema Trivial where+ declareNamedSchema _+ = do let declare_trivialField = HsJSONPB.declareSchemaRef+ trivialTrivialField <- declare_trivialField Proxy.Proxy+ let _ = Hs.pure Trivial <*> HsJSONPB.asProxy declare_trivialField+ Hs.return+ (HsJSONPB.NamedSchema{HsJSONPB._namedSchemaName =+ Hs.Just "Trivial",+ HsJSONPB._namedSchemaSchema =+ Hs.mempty{HsJSONPB._schemaParamSchema =+ Hs.mempty{HsJSONPB._paramSchemaType =+ HsJSONPB.SwaggerObject},+ HsJSONPB._schemaProperties =+ HsJSONPB.insOrdFromList+ [("trivialField", trivialTrivialField)]}})+ +instance HsDhallPb.Interpret Trivial+ +instance HsDhallPb.Inject Trivial+ +data MultipleFields = MultipleFields{multipleFieldsMultiFieldDouble+ :: Hs.Double,+ multipleFieldsMultiFieldFloat :: Hs.Float,+ multipleFieldsMultiFieldInt32 :: Hs.Int32,+ multipleFieldsMultiFieldInt64 :: Hs.Int64,+ multipleFieldsMultiFieldString :: Hs.Text,+ multipleFieldsMultiFieldBool :: Hs.Bool}+ deriving (Hs.Show, Hs.Eq, Hs.Ord, Hs.Generic)+ +instance HsProtobuf.Named MultipleFields where+ nameOf _ = (Hs.fromString "MultipleFields")+ +instance HsProtobuf.Message MultipleFields where+ encodeMessage _+ MultipleFields{multipleFieldsMultiFieldDouble =+ multipleFieldsMultiFieldDouble,+ multipleFieldsMultiFieldFloat = multipleFieldsMultiFieldFloat,+ multipleFieldsMultiFieldInt32 = multipleFieldsMultiFieldInt32,+ multipleFieldsMultiFieldInt64 = multipleFieldsMultiFieldInt64,+ multipleFieldsMultiFieldString = multipleFieldsMultiFieldString,+ multipleFieldsMultiFieldBool = multipleFieldsMultiFieldBool}+ = (Hs.mconcat+ [(HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 1)+ multipleFieldsMultiFieldDouble),+ (HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 2)+ multipleFieldsMultiFieldFloat),+ (HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 3)+ multipleFieldsMultiFieldInt32),+ (HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 4)+ multipleFieldsMultiFieldInt64),+ (HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 5)+ multipleFieldsMultiFieldString),+ (HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 6)+ multipleFieldsMultiFieldBool)])+ decodeMessage _+ = (Hs.pure MultipleFields) <*>+ (HsProtobuf.at HsProtobuf.decodeMessageField+ (HsProtobuf.FieldNumber 1))+ <*>+ (HsProtobuf.at HsProtobuf.decodeMessageField+ (HsProtobuf.FieldNumber 2))+ <*>+ (HsProtobuf.at HsProtobuf.decodeMessageField+ (HsProtobuf.FieldNumber 3))+ <*>+ (HsProtobuf.at HsProtobuf.decodeMessageField+ (HsProtobuf.FieldNumber 4))+ <*>+ (HsProtobuf.at HsProtobuf.decodeMessageField+ (HsProtobuf.FieldNumber 5))+ <*>+ (HsProtobuf.at HsProtobuf.decodeMessageField+ (HsProtobuf.FieldNumber 6))+ dotProto _+ = [(HsProtobuf.DotProtoField (HsProtobuf.FieldNumber 1)+ (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)+ = (HsJSONPB.object+ ["multiFieldDouble" .= f1, "multiFieldFloat" .= f2,+ "multiFieldInt32" .= f3, "multiFieldInt64" .= f4,+ "multiFieldString" .= f5, "multiFieldBool" .= f6])+ toEncodingPB (MultipleFields f1 f2 f3 f4 f5 f6)+ = (HsJSONPB.pairs+ ["multiFieldDouble" .= f1, "multiFieldFloat" .= f2,+ "multiFieldInt32" .= f3, "multiFieldInt64" .= f4,+ "multiFieldString" .= f5, "multiFieldBool" .= f6])+ +instance HsJSONPB.FromJSONPB MultipleFields where+ parseJSONPB+ = (HsJSONPB.withObject "MultipleFields"+ (\ obj ->+ (Hs.pure MultipleFields) <*> obj .: "multiFieldDouble" <*>+ obj .: "multiFieldFloat"+ <*> obj .: "multiFieldInt32"+ <*> obj .: "multiFieldInt64"+ <*> obj .: "multiFieldString"+ <*> obj .: "multiFieldBool"))+ +instance HsJSONPB.ToJSON MultipleFields where+ toJSON = HsJSONPB.toAesonValue+ toEncoding = HsJSONPB.toAesonEncoding+ +instance HsJSONPB.FromJSON MultipleFields where+ parseJSON = HsJSONPB.parseJSONPB+ +instance HsJSONPB.ToSchema MultipleFields where+ declareNamedSchema _+ = do let declare_multiFieldDouble = HsJSONPB.declareSchemaRef+ multipleFieldsMultiFieldDouble <- declare_multiFieldDouble+ Proxy.Proxy+ let declare_multiFieldFloat = HsJSONPB.declareSchemaRef+ multipleFieldsMultiFieldFloat <- declare_multiFieldFloat+ Proxy.Proxy+ let declare_multiFieldInt32 = HsJSONPB.declareSchemaRef+ multipleFieldsMultiFieldInt32 <- declare_multiFieldInt32+ Proxy.Proxy+ let declare_multiFieldInt64 = HsJSONPB.declareSchemaRef+ multipleFieldsMultiFieldInt64 <- declare_multiFieldInt64+ Proxy.Proxy+ let declare_multiFieldString = HsJSONPB.declareSchemaRef+ multipleFieldsMultiFieldString <- declare_multiFieldString+ Proxy.Proxy+ let declare_multiFieldBool = HsJSONPB.declareSchemaRef+ multipleFieldsMultiFieldBool <- declare_multiFieldBool Proxy.Proxy+ let _ = Hs.pure MultipleFields <*>+ HsJSONPB.asProxy declare_multiFieldDouble+ <*> HsJSONPB.asProxy declare_multiFieldFloat+ <*> HsJSONPB.asProxy declare_multiFieldInt32+ <*> HsJSONPB.asProxy declare_multiFieldInt64+ <*> HsJSONPB.asProxy declare_multiFieldString+ <*> HsJSONPB.asProxy declare_multiFieldBool+ Hs.return+ (HsJSONPB.NamedSchema{HsJSONPB._namedSchemaName =+ Hs.Just "MultipleFields",+ HsJSONPB._namedSchemaSchema =+ Hs.mempty{HsJSONPB._schemaParamSchema =+ Hs.mempty{HsJSONPB._paramSchemaType =+ HsJSONPB.SwaggerObject},+ HsJSONPB._schemaProperties =+ HsJSONPB.insOrdFromList+ [("multiFieldDouble",+ multipleFieldsMultiFieldDouble),+ ("multiFieldFloat",+ multipleFieldsMultiFieldFloat),+ ("multiFieldInt32",+ multipleFieldsMultiFieldInt32),+ ("multiFieldInt64",+ multipleFieldsMultiFieldInt64),+ ("multiFieldString",+ multipleFieldsMultiFieldString),+ ("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)+ +instance HsProtobuf.Named SignedInts where+ nameOf _ = (Hs.fromString "SignedInts")+ +instance HsProtobuf.Message SignedInts where+ encodeMessage _+ SignedInts{signedIntsSigned32 = signedIntsSigned32,+ signedIntsSigned64 = signedIntsSigned64}+ = (Hs.mconcat+ [(HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 1)+ (HsProtobuf.Signed signedIntsSigned32)),+ (HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 2)+ (HsProtobuf.Signed signedIntsSigned64))])+ decodeMessage _+ = (Hs.pure SignedInts) <*>+ ((Hs.pure HsProtobuf.signed) <*>+ (HsProtobuf.at HsProtobuf.decodeMessageField+ (HsProtobuf.FieldNumber 1)))+ <*>+ ((Hs.pure HsProtobuf.signed) <*>+ (HsProtobuf.at HsProtobuf.decodeMessageField+ (HsProtobuf.FieldNumber 2)))+ dotProto _+ = [(HsProtobuf.DotProtoField (HsProtobuf.FieldNumber 1)+ (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)+ = (HsJSONPB.object ["signed32" .= f1, "signed64" .= f2])+ toEncodingPB (SignedInts f1 f2)+ = (HsJSONPB.pairs ["signed32" .= f1, "signed64" .= f2])+ +instance HsJSONPB.FromJSONPB SignedInts where+ parseJSONPB+ = (HsJSONPB.withObject "SignedInts"+ (\ obj ->+ (Hs.pure SignedInts) <*> obj .: "signed32" <*> obj .: "signed64"))+ +instance HsJSONPB.ToJSON SignedInts where+ toJSON = HsJSONPB.toAesonValue+ toEncoding = HsJSONPB.toAesonEncoding+ +instance HsJSONPB.FromJSON SignedInts where+ parseJSON = HsJSONPB.parseJSONPB+ +instance HsJSONPB.ToSchema SignedInts where+ declareNamedSchema _+ = do let declare_signed32 = HsJSONPB.declareSchemaRef+ signedIntsSigned32 <- declare_signed32 Proxy.Proxy+ let declare_signed64 = HsJSONPB.declareSchemaRef+ signedIntsSigned64 <- declare_signed64 Proxy.Proxy+ let _ = Hs.pure SignedInts <*> HsJSONPB.asProxy declare_signed32+ <*> HsJSONPB.asProxy declare_signed64+ Hs.return+ (HsJSONPB.NamedSchema{HsJSONPB._namedSchemaName =+ Hs.Just "SignedInts",+ HsJSONPB._namedSchemaSchema =+ Hs.mempty{HsJSONPB._schemaParamSchema =+ Hs.mempty{HsJSONPB._paramSchemaType =+ HsJSONPB.SwaggerObject},+ HsJSONPB._schemaProperties =+ HsJSONPB.insOrdFromList+ [("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)+ +instance HsProtobuf.Named WithEnum where+ nameOf _ = (Hs.fromString "WithEnum")+ +instance HsProtobuf.Message WithEnum where+ encodeMessage _ WithEnum{withEnumEnumField = withEnumEnumField}+ = (Hs.mconcat+ [(HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 1)+ withEnumEnumField)])+ decodeMessage _+ = (Hs.pure WithEnum) <*>+ (HsProtobuf.at HsProtobuf.decodeMessageField+ (HsProtobuf.FieldNumber 1))+ dotProto _+ = [(HsProtobuf.DotProtoField (HsProtobuf.FieldNumber 1)+ (HsProtobuf.Prim (HsProtobuf.Named (HsProtobuf.Single "TestEnum")))+ (HsProtobuf.Single "enumField")+ []+ Hs.Nothing)]+ +instance HsJSONPB.ToJSONPB WithEnum where+ toJSONPB (WithEnum f1) = (HsJSONPB.object ["enumField" .= f1])+ toEncodingPB (WithEnum f1) = (HsJSONPB.pairs ["enumField" .= f1])+ +instance HsJSONPB.FromJSONPB WithEnum where+ parseJSONPB+ = (HsJSONPB.withObject "WithEnum"+ (\ obj -> (Hs.pure WithEnum) <*> obj .: "enumField"))+ +instance HsJSONPB.ToJSON WithEnum where+ toJSON = HsJSONPB.toAesonValue+ toEncoding = HsJSONPB.toAesonEncoding+ +instance HsJSONPB.FromJSON WithEnum where+ parseJSON = HsJSONPB.parseJSONPB+ +instance HsJSONPB.ToSchema WithEnum where+ declareNamedSchema _+ = do let declare_enumField = HsJSONPB.declareSchemaRef+ withEnumEnumField <- declare_enumField Proxy.Proxy+ let _ = Hs.pure WithEnum <*> HsJSONPB.asProxy declare_enumField+ Hs.return+ (HsJSONPB.NamedSchema{HsJSONPB._namedSchemaName =+ Hs.Just "WithEnum",+ HsJSONPB._namedSchemaSchema =+ Hs.mempty{HsJSONPB._schemaParamSchema =+ Hs.mempty{HsJSONPB._paramSchemaType =+ HsJSONPB.SwaggerObject},+ HsJSONPB._schemaProperties =+ 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)+ +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 HsJSONPB.ToJSONPB WithEnum_TestEnum where+ toJSONPB x _ = HsJSONPB.enumFieldString x+ toEncodingPB x _ = HsJSONPB.enumFieldEncoding x+ +instance HsJSONPB.FromJSONPB WithEnum_TestEnum where+ parseJSONPB (HsJSONPB.String "ENUM1")+ = Hs.pure WithEnum_TestEnumENUM1+ parseJSONPB (HsJSONPB.String "ENUM2")+ = Hs.pure WithEnum_TestEnumENUM2+ parseJSONPB (HsJSONPB.String "ENUM3")+ = Hs.pure WithEnum_TestEnumENUM3+ parseJSONPB v = (HsJSONPB.typeMismatch "WithEnum_TestEnum" v)+ +instance HsJSONPB.ToJSON WithEnum_TestEnum where+ toJSON = HsJSONPB.toAesonValue+ toEncoding = HsJSONPB.toAesonEncoding+ +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)+ +instance HsProtobuf.Named WithNesting where+ nameOf _ = (Hs.fromString "WithNesting")+ +instance HsProtobuf.Message WithNesting where+ encodeMessage _+ WithNesting{withNestingNestedMessage = withNestingNestedMessage}+ = (Hs.mconcat+ [(HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 1)+ (HsProtobuf.Nested withNestingNestedMessage))])+ decodeMessage _+ = (Hs.pure WithNesting) <*>+ ((Hs.pure HsProtobuf.nested) <*>+ (HsProtobuf.at HsProtobuf.decodeMessageField+ (HsProtobuf.FieldNumber 1)))+ dotProto _+ = [(HsProtobuf.DotProtoField (HsProtobuf.FieldNumber 1)+ (HsProtobuf.Prim (HsProtobuf.Named (HsProtobuf.Single "Nested")))+ (HsProtobuf.Single "nestedMessage")+ []+ Hs.Nothing)]+ +instance HsJSONPB.ToJSONPB WithNesting where+ toJSONPB (WithNesting f1)+ = (HsJSONPB.object ["nestedMessage" .= f1])+ toEncodingPB (WithNesting f1)+ = (HsJSONPB.pairs ["nestedMessage" .= f1])+ +instance HsJSONPB.FromJSONPB WithNesting where+ parseJSONPB+ = (HsJSONPB.withObject "WithNesting"+ (\ obj -> (Hs.pure WithNesting) <*> obj .: "nestedMessage"))+ +instance HsJSONPB.ToJSON WithNesting where+ toJSON = HsJSONPB.toAesonValue+ toEncoding = HsJSONPB.toAesonEncoding+ +instance HsJSONPB.FromJSON WithNesting where+ parseJSON = HsJSONPB.parseJSONPB+ +instance HsJSONPB.ToSchema WithNesting where+ declareNamedSchema _+ = do let declare_nestedMessage = HsJSONPB.declareSchemaRef+ withNestingNestedMessage <- declare_nestedMessage Proxy.Proxy+ let _ = Hs.pure WithNesting <*>+ HsJSONPB.asProxy declare_nestedMessage+ Hs.return+ (HsJSONPB.NamedSchema{HsJSONPB._namedSchemaName =+ Hs.Just "WithNesting",+ HsJSONPB._namedSchemaSchema =+ Hs.mempty{HsJSONPB._schemaParamSchema =+ Hs.mempty{HsJSONPB._paramSchemaType =+ HsJSONPB.SwaggerObject},+ HsJSONPB._schemaProperties =+ HsJSONPB.insOrdFromList+ [("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)+ +instance HsProtobuf.Named WithNesting_Nested where+ nameOf _ = (Hs.fromString "WithNesting_Nested")+ +instance HsProtobuf.Message WithNesting_Nested where+ encodeMessage _+ WithNesting_Nested{withNesting_NestedNestedField1 =+ withNesting_NestedNestedField1,+ withNesting_NestedNestedField2 = withNesting_NestedNestedField2,+ withNesting_NestedNestedPacked = withNesting_NestedNestedPacked,+ withNesting_NestedNestedUnpacked =+ withNesting_NestedNestedUnpacked}+ = (Hs.mconcat+ [(HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 1)+ withNesting_NestedNestedField1),+ (HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 2)+ withNesting_NestedNestedField2),+ (HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 3)+ (HsProtobuf.PackedVec withNesting_NestedNestedPacked)),+ (HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 4)+ (HsProtobuf.UnpackedVec withNesting_NestedNestedUnpacked))])+ decodeMessage _+ = (Hs.pure WithNesting_Nested) <*>+ (HsProtobuf.at HsProtobuf.decodeMessageField+ (HsProtobuf.FieldNumber 1))+ <*>+ (HsProtobuf.at HsProtobuf.decodeMessageField+ (HsProtobuf.FieldNumber 2))+ <*>+ ((Hs.pure HsProtobuf.packedvec) <*>+ (HsProtobuf.at HsProtobuf.decodeMessageField+ (HsProtobuf.FieldNumber 3)))+ <*>+ ((Hs.pure HsProtobuf.unpackedvec) <*>+ (HsProtobuf.at HsProtobuf.decodeMessageField+ (HsProtobuf.FieldNumber 4)))+ dotProto _+ = [(HsProtobuf.DotProtoField (HsProtobuf.FieldNumber 1)+ (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)+ = (HsJSONPB.object+ ["nestedField1" .= f1, "nestedField2" .= f2, "nestedPacked" .= f3,+ "nestedUnpacked" .= f4])+ toEncodingPB (WithNesting_Nested f1 f2 f3 f4)+ = (HsJSONPB.pairs+ ["nestedField1" .= f1, "nestedField2" .= f2, "nestedPacked" .= f3,+ "nestedUnpacked" .= f4])+ +instance HsJSONPB.FromJSONPB WithNesting_Nested where+ parseJSONPB+ = (HsJSONPB.withObject "WithNesting_Nested"+ (\ obj ->+ (Hs.pure WithNesting_Nested) <*> obj .: "nestedField1" <*>+ obj .: "nestedField2"+ <*> obj .: "nestedPacked"+ <*> obj .: "nestedUnpacked"))+ +instance HsJSONPB.ToJSON WithNesting_Nested where+ toJSON = HsJSONPB.toAesonValue+ toEncoding = HsJSONPB.toAesonEncoding+ +instance HsJSONPB.FromJSON WithNesting_Nested where+ parseJSON = HsJSONPB.parseJSONPB+ +instance HsJSONPB.ToSchema WithNesting_Nested where+ declareNamedSchema _+ = do let declare_nestedField1 = HsJSONPB.declareSchemaRef+ withNesting_NestedNestedField1 <- declare_nestedField1 Proxy.Proxy+ let declare_nestedField2 = HsJSONPB.declareSchemaRef+ withNesting_NestedNestedField2 <- declare_nestedField2 Proxy.Proxy+ let declare_nestedPacked = HsJSONPB.declareSchemaRef+ withNesting_NestedNestedPacked <- declare_nestedPacked Proxy.Proxy+ let declare_nestedUnpacked = HsJSONPB.declareSchemaRef+ withNesting_NestedNestedUnpacked <- declare_nestedUnpacked+ Proxy.Proxy+ let _ = Hs.pure WithNesting_Nested <*>+ HsJSONPB.asProxy declare_nestedField1+ <*> HsJSONPB.asProxy declare_nestedField2+ <*> HsJSONPB.asProxy declare_nestedPacked+ <*> HsJSONPB.asProxy declare_nestedUnpacked+ Hs.return+ (HsJSONPB.NamedSchema{HsJSONPB._namedSchemaName =+ Hs.Just "WithNesting_Nested",+ HsJSONPB._namedSchemaSchema =+ Hs.mempty{HsJSONPB._schemaParamSchema =+ Hs.mempty{HsJSONPB._paramSchemaType =+ HsJSONPB.SwaggerObject},+ HsJSONPB._schemaProperties =+ HsJSONPB.insOrdFromList+ [("nestedField1",+ withNesting_NestedNestedField1),+ ("nestedField2",+ withNesting_NestedNestedField2),+ ("nestedPacked",+ withNesting_NestedNestedPacked),+ ("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)+ +instance HsProtobuf.Named WithNestingRepeated where+ nameOf _ = (Hs.fromString "WithNestingRepeated")+ +instance HsProtobuf.Message WithNestingRepeated where+ encodeMessage _+ WithNestingRepeated{withNestingRepeatedNestedMessages =+ withNestingRepeatedNestedMessages}+ = (Hs.mconcat+ [(HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 1)+ (HsProtobuf.NestedVec withNestingRepeatedNestedMessages))])+ decodeMessage _+ = (Hs.pure WithNestingRepeated) <*>+ ((Hs.pure HsProtobuf.nestedvec) <*>+ (HsProtobuf.at HsProtobuf.decodeMessageField+ (HsProtobuf.FieldNumber 1)))+ dotProto _+ = [(HsProtobuf.DotProtoField (HsProtobuf.FieldNumber 1)+ (HsProtobuf.Repeated+ (HsProtobuf.Named (HsProtobuf.Single "Nested")))+ (HsProtobuf.Single "nestedMessages")+ []+ Hs.Nothing)]+ +instance HsJSONPB.ToJSONPB WithNestingRepeated where+ toJSONPB (WithNestingRepeated f1)+ = (HsJSONPB.object ["nestedMessages" .= f1])+ toEncodingPB (WithNestingRepeated f1)+ = (HsJSONPB.pairs ["nestedMessages" .= f1])+ +instance HsJSONPB.FromJSONPB WithNestingRepeated where+ parseJSONPB+ = (HsJSONPB.withObject "WithNestingRepeated"+ (\ obj ->+ (Hs.pure WithNestingRepeated) <*> obj .: "nestedMessages"))+ +instance HsJSONPB.ToJSON WithNestingRepeated where+ toJSON = HsJSONPB.toAesonValue+ toEncoding = HsJSONPB.toAesonEncoding+ +instance HsJSONPB.FromJSON WithNestingRepeated where+ parseJSON = HsJSONPB.parseJSONPB+ +instance HsJSONPB.ToSchema WithNestingRepeated where+ declareNamedSchema _+ = do let declare_nestedMessages = HsJSONPB.declareSchemaRef+ withNestingRepeatedNestedMessages <- declare_nestedMessages+ Proxy.Proxy+ let _ = Hs.pure WithNestingRepeated <*>+ HsJSONPB.asProxy declare_nestedMessages+ Hs.return+ (HsJSONPB.NamedSchema{HsJSONPB._namedSchemaName =+ Hs.Just "WithNestingRepeated",+ HsJSONPB._namedSchemaSchema =+ Hs.mempty{HsJSONPB._schemaParamSchema =+ Hs.mempty{HsJSONPB._paramSchemaType =+ HsJSONPB.SwaggerObject},+ HsJSONPB._schemaProperties =+ HsJSONPB.insOrdFromList+ [("nestedMessages",+ withNestingRepeatedNestedMessages)]}})+ +instance HsDhallPb.Interpret WithNestingRepeated+ +instance HsDhallPb.Inject WithNestingRepeated+ +data WithNestingRepeated_Nested = WithNestingRepeated_Nested{withNestingRepeated_NestedNestedField1+ :: Hs.Text,+ withNestingRepeated_NestedNestedField2+ :: Hs.Int32,+ withNestingRepeated_NestedNestedPacked+ :: Hs.Vector Hs.Int32,+ withNestingRepeated_NestedNestedUnpacked+ :: Hs.Vector Hs.Int32}+ deriving (Hs.Show, Hs.Eq, Hs.Ord, Hs.Generic)+ +instance HsProtobuf.Named WithNestingRepeated_Nested where+ nameOf _ = (Hs.fromString "WithNestingRepeated_Nested")+ +instance HsProtobuf.Message WithNestingRepeated_Nested where+ encodeMessage _+ WithNestingRepeated_Nested{withNestingRepeated_NestedNestedField1 =+ withNestingRepeated_NestedNestedField1,+ withNestingRepeated_NestedNestedField2 =+ withNestingRepeated_NestedNestedField2,+ withNestingRepeated_NestedNestedPacked =+ withNestingRepeated_NestedNestedPacked,+ withNestingRepeated_NestedNestedUnpacked =+ withNestingRepeated_NestedNestedUnpacked}+ = (Hs.mconcat+ [(HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 1)+ withNestingRepeated_NestedNestedField1),+ (HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 2)+ withNestingRepeated_NestedNestedField2),+ (HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 3)+ (HsProtobuf.PackedVec withNestingRepeated_NestedNestedPacked)),+ (HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 4)+ (HsProtobuf.UnpackedVec+ withNestingRepeated_NestedNestedUnpacked))])+ decodeMessage _+ = (Hs.pure WithNestingRepeated_Nested) <*>+ (HsProtobuf.at HsProtobuf.decodeMessageField+ (HsProtobuf.FieldNumber 1))+ <*>+ (HsProtobuf.at HsProtobuf.decodeMessageField+ (HsProtobuf.FieldNumber 2))+ <*>+ ((Hs.pure HsProtobuf.packedvec) <*>+ (HsProtobuf.at HsProtobuf.decodeMessageField+ (HsProtobuf.FieldNumber 3)))+ <*>+ ((Hs.pure HsProtobuf.unpackedvec) <*>+ (HsProtobuf.at HsProtobuf.decodeMessageField+ (HsProtobuf.FieldNumber 4)))+ dotProto _+ = [(HsProtobuf.DotProtoField (HsProtobuf.FieldNumber 1)+ (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)+ = (HsJSONPB.object+ ["nestedField1" .= f1, "nestedField2" .= f2, "nestedPacked" .= f3,+ "nestedUnpacked" .= f4])+ toEncodingPB (WithNestingRepeated_Nested f1 f2 f3 f4)+ = (HsJSONPB.pairs+ ["nestedField1" .= f1, "nestedField2" .= f2, "nestedPacked" .= f3,+ "nestedUnpacked" .= f4])+ +instance HsJSONPB.FromJSONPB WithNestingRepeated_Nested where+ parseJSONPB+ = (HsJSONPB.withObject "WithNestingRepeated_Nested"+ (\ obj ->+ (Hs.pure WithNestingRepeated_Nested) <*> obj .: "nestedField1" <*>+ obj .: "nestedField2"+ <*> obj .: "nestedPacked"+ <*> obj .: "nestedUnpacked"))+ +instance HsJSONPB.ToJSON WithNestingRepeated_Nested where+ toJSON = HsJSONPB.toAesonValue+ toEncoding = HsJSONPB.toAesonEncoding+ +instance HsJSONPB.FromJSON WithNestingRepeated_Nested where+ parseJSON = HsJSONPB.parseJSONPB+ +instance HsJSONPB.ToSchema WithNestingRepeated_Nested where+ declareNamedSchema _+ = do let declare_nestedField1 = HsJSONPB.declareSchemaRef+ withNestingRepeated_NestedNestedField1 <- declare_nestedField1+ Proxy.Proxy+ let declare_nestedField2 = HsJSONPB.declareSchemaRef+ withNestingRepeated_NestedNestedField2 <- declare_nestedField2+ Proxy.Proxy+ let declare_nestedPacked = HsJSONPB.declareSchemaRef+ withNestingRepeated_NestedNestedPacked <- declare_nestedPacked+ Proxy.Proxy+ let declare_nestedUnpacked = HsJSONPB.declareSchemaRef+ withNestingRepeated_NestedNestedUnpacked <- declare_nestedUnpacked+ Proxy.Proxy+ let _ = Hs.pure WithNestingRepeated_Nested <*>+ HsJSONPB.asProxy declare_nestedField1+ <*> HsJSONPB.asProxy declare_nestedField2+ <*> HsJSONPB.asProxy declare_nestedPacked+ <*> HsJSONPB.asProxy declare_nestedUnpacked+ Hs.return+ (HsJSONPB.NamedSchema{HsJSONPB._namedSchemaName =+ Hs.Just "WithNestingRepeated_Nested",+ HsJSONPB._namedSchemaSchema =+ Hs.mempty{HsJSONPB._schemaParamSchema =+ Hs.mempty{HsJSONPB._paramSchemaType =+ HsJSONPB.SwaggerObject},+ HsJSONPB._schemaProperties =+ HsJSONPB.insOrdFromList+ [("nestedField1",+ withNestingRepeated_NestedNestedField1),+ ("nestedField2",+ withNestingRepeated_NestedNestedField2),+ ("nestedPacked",+ withNestingRepeated_NestedNestedPacked),+ ("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)+ +instance HsProtobuf.Named NestedInts where+ nameOf _ = (Hs.fromString "NestedInts")+ +instance HsProtobuf.Message NestedInts where+ encodeMessage _+ NestedInts{nestedIntsNestedInt1 = nestedIntsNestedInt1,+ nestedIntsNestedInt2 = nestedIntsNestedInt2}+ = (Hs.mconcat+ [(HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 1)+ nestedIntsNestedInt1),+ (HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 2)+ nestedIntsNestedInt2)])+ decodeMessage _+ = (Hs.pure NestedInts) <*>+ (HsProtobuf.at HsProtobuf.decodeMessageField+ (HsProtobuf.FieldNumber 1))+ <*>+ (HsProtobuf.at HsProtobuf.decodeMessageField+ (HsProtobuf.FieldNumber 2))+ dotProto _+ = [(HsProtobuf.DotProtoField (HsProtobuf.FieldNumber 1)+ (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)+ = (HsJSONPB.object ["nestedInt1" .= f1, "nestedInt2" .= f2])+ toEncodingPB (NestedInts f1 f2)+ = (HsJSONPB.pairs ["nestedInt1" .= f1, "nestedInt2" .= f2])+ +instance HsJSONPB.FromJSONPB NestedInts where+ parseJSONPB+ = (HsJSONPB.withObject "NestedInts"+ (\ obj ->+ (Hs.pure NestedInts) <*> obj .: "nestedInt1" <*>+ obj .: "nestedInt2"))+ +instance HsJSONPB.ToJSON NestedInts where+ toJSON = HsJSONPB.toAesonValue+ toEncoding = HsJSONPB.toAesonEncoding+ +instance HsJSONPB.FromJSON NestedInts where+ parseJSON = HsJSONPB.parseJSONPB+ +instance HsJSONPB.ToSchema NestedInts where+ declareNamedSchema _+ = do let declare_nestedInt1 = HsJSONPB.declareSchemaRef+ nestedIntsNestedInt1 <- declare_nestedInt1 Proxy.Proxy+ let declare_nestedInt2 = HsJSONPB.declareSchemaRef+ nestedIntsNestedInt2 <- declare_nestedInt2 Proxy.Proxy+ let _ = Hs.pure NestedInts <*> HsJSONPB.asProxy declare_nestedInt1+ <*> HsJSONPB.asProxy declare_nestedInt2+ Hs.return+ (HsJSONPB.NamedSchema{HsJSONPB._namedSchemaName =+ Hs.Just "NestedInts",+ HsJSONPB._namedSchemaSchema =+ Hs.mempty{HsJSONPB._schemaParamSchema =+ Hs.mempty{HsJSONPB._paramSchemaType =+ HsJSONPB.SwaggerObject},+ HsJSONPB._schemaProperties =+ HsJSONPB.insOrdFromList+ [("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)+ +instance HsProtobuf.Named WithNestingRepeatedInts where+ nameOf _ = (Hs.fromString "WithNestingRepeatedInts")+ +instance HsProtobuf.Message WithNestingRepeatedInts where+ encodeMessage _+ WithNestingRepeatedInts{withNestingRepeatedIntsNestedInts =+ withNestingRepeatedIntsNestedInts}+ = (Hs.mconcat+ [(HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 1)+ (HsProtobuf.NestedVec withNestingRepeatedIntsNestedInts))])+ decodeMessage _+ = (Hs.pure WithNestingRepeatedInts) <*>+ ((Hs.pure HsProtobuf.nestedvec) <*>+ (HsProtobuf.at HsProtobuf.decodeMessageField+ (HsProtobuf.FieldNumber 1)))+ dotProto _+ = [(HsProtobuf.DotProtoField (HsProtobuf.FieldNumber 1)+ (HsProtobuf.Repeated+ (HsProtobuf.Named (HsProtobuf.Single "NestedInts")))+ (HsProtobuf.Single "nestedInts")+ []+ Hs.Nothing)]+ +instance HsJSONPB.ToJSONPB WithNestingRepeatedInts where+ toJSONPB (WithNestingRepeatedInts f1)+ = (HsJSONPB.object ["nestedInts" .= f1])+ toEncodingPB (WithNestingRepeatedInts f1)+ = (HsJSONPB.pairs ["nestedInts" .= f1])+ +instance HsJSONPB.FromJSONPB WithNestingRepeatedInts where+ parseJSONPB+ = (HsJSONPB.withObject "WithNestingRepeatedInts"+ (\ obj ->+ (Hs.pure WithNestingRepeatedInts) <*> obj .: "nestedInts"))+ +instance HsJSONPB.ToJSON WithNestingRepeatedInts where+ toJSON = HsJSONPB.toAesonValue+ toEncoding = HsJSONPB.toAesonEncoding+ +instance HsJSONPB.FromJSON WithNestingRepeatedInts where+ parseJSON = HsJSONPB.parseJSONPB+ +instance HsJSONPB.ToSchema WithNestingRepeatedInts where+ declareNamedSchema _+ = do let declare_nestedInts = HsJSONPB.declareSchemaRef+ withNestingRepeatedIntsNestedInts <- declare_nestedInts Proxy.Proxy+ let _ = Hs.pure WithNestingRepeatedInts <*>+ HsJSONPB.asProxy declare_nestedInts+ Hs.return+ (HsJSONPB.NamedSchema{HsJSONPB._namedSchemaName =+ Hs.Just "WithNestingRepeatedInts",+ HsJSONPB._namedSchemaSchema =+ Hs.mempty{HsJSONPB._schemaParamSchema =+ Hs.mempty{HsJSONPB._paramSchemaType =+ HsJSONPB.SwaggerObject},+ HsJSONPB._schemaProperties =+ HsJSONPB.insOrdFromList+ [("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)+ +instance HsProtobuf.Named WithNestingInts where+ nameOf _ = (Hs.fromString "WithNestingInts")+ +instance HsProtobuf.Message WithNestingInts where+ encodeMessage _+ WithNestingInts{withNestingIntsNestedInts =+ withNestingIntsNestedInts}+ = (Hs.mconcat+ [(HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 1)+ (HsProtobuf.Nested withNestingIntsNestedInts))])+ decodeMessage _+ = (Hs.pure WithNestingInts) <*>+ ((Hs.pure HsProtobuf.nested) <*>+ (HsProtobuf.at HsProtobuf.decodeMessageField+ (HsProtobuf.FieldNumber 1)))+ dotProto _+ = [(HsProtobuf.DotProtoField (HsProtobuf.FieldNumber 1)+ (HsProtobuf.Prim+ (HsProtobuf.Named (HsProtobuf.Single "NestedInts")))+ (HsProtobuf.Single "nestedInts")+ []+ Hs.Nothing)]+ +instance HsJSONPB.ToJSONPB WithNestingInts where+ toJSONPB (WithNestingInts f1)+ = (HsJSONPB.object ["nestedInts" .= f1])+ toEncodingPB (WithNestingInts f1)+ = (HsJSONPB.pairs ["nestedInts" .= f1])+ +instance HsJSONPB.FromJSONPB WithNestingInts where+ parseJSONPB+ = (HsJSONPB.withObject "WithNestingInts"+ (\ obj -> (Hs.pure WithNestingInts) <*> obj .: "nestedInts"))+ +instance HsJSONPB.ToJSON WithNestingInts where+ toJSON = HsJSONPB.toAesonValue+ toEncoding = HsJSONPB.toAesonEncoding+ +instance HsJSONPB.FromJSON WithNestingInts where+ parseJSON = HsJSONPB.parseJSONPB+ +instance HsJSONPB.ToSchema WithNestingInts where+ declareNamedSchema _+ = do let declare_nestedInts = HsJSONPB.declareSchemaRef+ withNestingIntsNestedInts <- declare_nestedInts Proxy.Proxy+ let _ = Hs.pure WithNestingInts <*>+ HsJSONPB.asProxy declare_nestedInts+ Hs.return+ (HsJSONPB.NamedSchema{HsJSONPB._namedSchemaName =+ Hs.Just "WithNestingInts",+ HsJSONPB._namedSchemaSchema =+ Hs.mempty{HsJSONPB._schemaParamSchema =+ Hs.mempty{HsJSONPB._paramSchemaType =+ HsJSONPB.SwaggerObject},+ HsJSONPB._schemaProperties =+ HsJSONPB.insOrdFromList+ [("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)+ +instance HsProtobuf.Named WithRepetition where+ nameOf _ = (Hs.fromString "WithRepetition")+ +instance HsProtobuf.Message WithRepetition where+ encodeMessage _+ WithRepetition{withRepetitionRepeatedField1 =+ withRepetitionRepeatedField1}+ = (Hs.mconcat+ [(HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 1)+ (HsProtobuf.PackedVec withRepetitionRepeatedField1))])+ decodeMessage _+ = (Hs.pure WithRepetition) <*>+ ((Hs.pure HsProtobuf.packedvec) <*>+ (HsProtobuf.at HsProtobuf.decodeMessageField+ (HsProtobuf.FieldNumber 1)))+ dotProto _+ = [(HsProtobuf.DotProtoField (HsProtobuf.FieldNumber 1)+ (HsProtobuf.Repeated HsProtobuf.Int32)+ (HsProtobuf.Single "repeatedField1")+ []+ Hs.Nothing)]+ +instance HsJSONPB.ToJSONPB WithRepetition where+ toJSONPB (WithRepetition f1)+ = (HsJSONPB.object ["repeatedField1" .= f1])+ toEncodingPB (WithRepetition f1)+ = (HsJSONPB.pairs ["repeatedField1" .= f1])+ +instance HsJSONPB.FromJSONPB WithRepetition where+ parseJSONPB+ = (HsJSONPB.withObject "WithRepetition"+ (\ obj -> (Hs.pure WithRepetition) <*> obj .: "repeatedField1"))+ +instance HsJSONPB.ToJSON WithRepetition where+ toJSON = HsJSONPB.toAesonValue+ toEncoding = HsJSONPB.toAesonEncoding+ +instance HsJSONPB.FromJSON WithRepetition where+ parseJSON = HsJSONPB.parseJSONPB+ +instance HsJSONPB.ToSchema WithRepetition where+ declareNamedSchema _+ = do let declare_repeatedField1 = HsJSONPB.declareSchemaRef+ withRepetitionRepeatedField1 <- declare_repeatedField1 Proxy.Proxy+ let _ = Hs.pure WithRepetition <*>+ HsJSONPB.asProxy declare_repeatedField1+ Hs.return+ (HsJSONPB.NamedSchema{HsJSONPB._namedSchemaName =+ Hs.Just "WithRepetition",+ HsJSONPB._namedSchemaSchema =+ Hs.mempty{HsJSONPB._schemaParamSchema =+ Hs.mempty{HsJSONPB._paramSchemaType =+ HsJSONPB.SwaggerObject},+ HsJSONPB._schemaProperties =+ HsJSONPB.insOrdFromList+ [("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)+ +instance HsProtobuf.Named WithFixed where+ nameOf _ = (Hs.fromString "WithFixed")+ +instance HsProtobuf.Message WithFixed where+ encodeMessage _+ WithFixed{withFixedFixed1 = withFixedFixed1,+ withFixedFixed2 = withFixedFixed2,+ withFixedFixed3 = withFixedFixed3,+ withFixedFixed4 = withFixedFixed4}+ = (Hs.mconcat+ [(HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 1)+ withFixedFixed1),+ (HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 2)+ (HsProtobuf.Signed withFixedFixed2)),+ (HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 3)+ withFixedFixed3),+ (HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 4)+ (HsProtobuf.Signed withFixedFixed4))])+ decodeMessage _+ = (Hs.pure WithFixed) <*>+ (HsProtobuf.at HsProtobuf.decodeMessageField+ (HsProtobuf.FieldNumber 1))+ <*>+ ((Hs.pure HsProtobuf.signed) <*>+ (HsProtobuf.at HsProtobuf.decodeMessageField+ (HsProtobuf.FieldNumber 2)))+ <*>+ (HsProtobuf.at HsProtobuf.decodeMessageField+ (HsProtobuf.FieldNumber 3))+ <*>+ ((Hs.pure HsProtobuf.signed) <*>+ (HsProtobuf.at HsProtobuf.decodeMessageField+ (HsProtobuf.FieldNumber 4)))+ dotProto _+ = [(HsProtobuf.DotProtoField (HsProtobuf.FieldNumber 1)+ (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)+ = (HsJSONPB.object+ ["fixed1" .= f1, "fixed2" .= f2, "fixed3" .= f3, "fixed4" .= f4])+ toEncodingPB (WithFixed f1 f2 f3 f4)+ = (HsJSONPB.pairs+ ["fixed1" .= f1, "fixed2" .= f2, "fixed3" .= f3, "fixed4" .= f4])+ +instance HsJSONPB.FromJSONPB WithFixed where+ parseJSONPB+ = (HsJSONPB.withObject "WithFixed"+ (\ obj ->+ (Hs.pure WithFixed) <*> obj .: "fixed1" <*> obj .: "fixed2" <*>+ obj .: "fixed3"+ <*> obj .: "fixed4"))+ +instance HsJSONPB.ToJSON WithFixed where+ toJSON = HsJSONPB.toAesonValue+ toEncoding = HsJSONPB.toAesonEncoding+ +instance HsJSONPB.FromJSON WithFixed where+ parseJSON = HsJSONPB.parseJSONPB+ +instance HsJSONPB.ToSchema WithFixed where+ declareNamedSchema _+ = do let declare_fixed1 = HsJSONPB.declareSchemaRef+ withFixedFixed1 <- declare_fixed1 Proxy.Proxy+ let declare_fixed2 = HsJSONPB.declareSchemaRef+ withFixedFixed2 <- declare_fixed2 Proxy.Proxy+ let declare_fixed3 = HsJSONPB.declareSchemaRef+ withFixedFixed3 <- declare_fixed3 Proxy.Proxy+ let declare_fixed4 = HsJSONPB.declareSchemaRef+ withFixedFixed4 <- declare_fixed4 Proxy.Proxy+ let _ = Hs.pure WithFixed <*> HsJSONPB.asProxy declare_fixed1 <*>+ HsJSONPB.asProxy declare_fixed2+ <*> HsJSONPB.asProxy declare_fixed3+ <*> HsJSONPB.asProxy declare_fixed4+ Hs.return+ (HsJSONPB.NamedSchema{HsJSONPB._namedSchemaName =+ Hs.Just "WithFixed",+ HsJSONPB._namedSchemaSchema =+ Hs.mempty{HsJSONPB._schemaParamSchema =+ Hs.mempty{HsJSONPB._paramSchemaType =+ HsJSONPB.SwaggerObject},+ HsJSONPB._schemaProperties =+ HsJSONPB.insOrdFromList+ [("fixed1", withFixedFixed1),+ ("fixed2", withFixedFixed2),+ ("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)+ +instance HsProtobuf.Named WithBytes where+ nameOf _ = (Hs.fromString "WithBytes")+ +instance HsProtobuf.Message WithBytes where+ encodeMessage _+ WithBytes{withBytesBytes1 = withBytesBytes1,+ withBytesBytes2 = withBytesBytes2}+ = (Hs.mconcat+ [(HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 1)+ withBytesBytes1),+ (HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 2)+ (HsProtobuf.UnpackedVec withBytesBytes2))])+ decodeMessage _+ = (Hs.pure WithBytes) <*>+ (HsProtobuf.at HsProtobuf.decodeMessageField+ (HsProtobuf.FieldNumber 1))+ <*>+ ((Hs.pure HsProtobuf.unpackedvec) <*>+ (HsProtobuf.at HsProtobuf.decodeMessageField+ (HsProtobuf.FieldNumber 2)))+ dotProto _+ = [(HsProtobuf.DotProtoField (HsProtobuf.FieldNumber 1)+ (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)+ = (HsJSONPB.object ["bytes1" .= f1, "bytes2" .= f2])+ toEncodingPB (WithBytes f1 f2)+ = (HsJSONPB.pairs ["bytes1" .= f1, "bytes2" .= f2])+ +instance HsJSONPB.FromJSONPB WithBytes where+ parseJSONPB+ = (HsJSONPB.withObject "WithBytes"+ (\ obj ->+ (Hs.pure WithBytes) <*> obj .: "bytes1" <*> obj .: "bytes2"))+ +instance HsJSONPB.ToJSON WithBytes where+ toJSON = HsJSONPB.toAesonValue+ toEncoding = HsJSONPB.toAesonEncoding+ +instance HsJSONPB.FromJSON WithBytes where+ parseJSON = HsJSONPB.parseJSONPB+ +instance HsJSONPB.ToSchema WithBytes where+ declareNamedSchema _+ = do let declare_bytes1 = HsJSONPB.declareSchemaRef+ withBytesBytes1 <- declare_bytes1 Proxy.Proxy+ let declare_bytes2 = HsJSONPB.declareSchemaRef+ withBytesBytes2 <- declare_bytes2 Proxy.Proxy+ let _ = Hs.pure WithBytes <*> HsJSONPB.asProxy declare_bytes1 <*>+ HsJSONPB.asProxy declare_bytes2+ Hs.return+ (HsJSONPB.NamedSchema{HsJSONPB._namedSchemaName =+ Hs.Just "WithBytes",+ HsJSONPB._namedSchemaSchema =+ Hs.mempty{HsJSONPB._schemaParamSchema =+ Hs.mempty{HsJSONPB._paramSchemaType =+ HsJSONPB.SwaggerObject},+ HsJSONPB._schemaProperties =+ HsJSONPB.insOrdFromList+ [("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)+ +instance HsProtobuf.Named WithPacking where+ nameOf _ = (Hs.fromString "WithPacking")+ +instance HsProtobuf.Message WithPacking where+ encodeMessage _+ WithPacking{withPackingPacking1 = withPackingPacking1,+ withPackingPacking2 = withPackingPacking2}+ = (Hs.mconcat+ [(HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 1)+ (HsProtobuf.UnpackedVec withPackingPacking1)),+ (HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 2)+ (HsProtobuf.PackedVec withPackingPacking2))])+ decodeMessage _+ = (Hs.pure WithPacking) <*>+ ((Hs.pure HsProtobuf.unpackedvec) <*>+ (HsProtobuf.at HsProtobuf.decodeMessageField+ (HsProtobuf.FieldNumber 1)))+ <*>+ ((Hs.pure HsProtobuf.packedvec) <*>+ (HsProtobuf.at HsProtobuf.decodeMessageField+ (HsProtobuf.FieldNumber 2)))+ dotProto _+ = [(HsProtobuf.DotProtoField (HsProtobuf.FieldNumber 1)+ (HsProtobuf.Repeated HsProtobuf.Int32)+ (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)+ = (HsJSONPB.object ["packing1" .= f1, "packing2" .= f2])+ toEncodingPB (WithPacking f1 f2)+ = (HsJSONPB.pairs ["packing1" .= f1, "packing2" .= f2])+ +instance HsJSONPB.FromJSONPB WithPacking where+ parseJSONPB+ = (HsJSONPB.withObject "WithPacking"+ (\ obj ->+ (Hs.pure WithPacking) <*> obj .: "packing1" <*> obj .: "packing2"))+ +instance HsJSONPB.ToJSON WithPacking where+ toJSON = HsJSONPB.toAesonValue+ toEncoding = HsJSONPB.toAesonEncoding+ +instance HsJSONPB.FromJSON WithPacking where+ parseJSON = HsJSONPB.parseJSONPB+ +instance HsJSONPB.ToSchema WithPacking where+ declareNamedSchema _+ = do let declare_packing1 = HsJSONPB.declareSchemaRef+ withPackingPacking1 <- declare_packing1 Proxy.Proxy+ let declare_packing2 = HsJSONPB.declareSchemaRef+ withPackingPacking2 <- declare_packing2 Proxy.Proxy+ let _ = Hs.pure WithPacking <*> HsJSONPB.asProxy declare_packing1+ <*> HsJSONPB.asProxy declare_packing2+ Hs.return+ (HsJSONPB.NamedSchema{HsJSONPB._namedSchemaName =+ Hs.Just "WithPacking",+ HsJSONPB._namedSchemaSchema =+ Hs.mempty{HsJSONPB._schemaParamSchema =+ Hs.mempty{HsJSONPB._paramSchemaType =+ HsJSONPB.SwaggerObject},+ HsJSONPB._schemaProperties =+ HsJSONPB.insOrdFromList+ [("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)+ +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 HsJSONPB.ToJSONPB E where+ toJSONPB x _ = HsJSONPB.enumFieldString x+ toEncodingPB x _ = HsJSONPB.enumFieldEncoding x+ +instance HsJSONPB.FromJSONPB E where+ parseJSONPB (HsJSONPB.String "FLD0") = Hs.pure EFLD0+ parseJSONPB (HsJSONPB.String "FLD1") = Hs.pure EFLD1+ parseJSONPB v = (HsJSONPB.typeMismatch "E" v)+ +instance HsJSONPB.ToJSON E where+ toJSON = HsJSONPB.toAesonValue+ toEncoding = HsJSONPB.toAesonEncoding+ +instance HsJSONPB.FromJSON E where+ parseJSON = HsJSONPB.parseJSONPB+ +instance HsDhallPb.Interpret E+ +instance HsDhallPb.Inject E+ +instance HsProtobuf.Finite E+ +data AllPackedTypes = AllPackedTypes{allPackedTypesPackedWord32 ::+ Hs.Vector Hs.Word32,+ 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),+ allPackedTypesPackedFloat :: Hs.Vector Hs.Float,+ allPackedTypesPackedDouble :: Hs.Vector Hs.Double,+ allPackedTypesPackedSFixed32 ::+ Hs.Vector (HsProtobuf.Fixed Hs.Int32),+ allPackedTypesPackedSFixed64 ::+ Hs.Vector (HsProtobuf.Fixed 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)+ +instance HsProtobuf.Named AllPackedTypes where+ nameOf _ = (Hs.fromString "AllPackedTypes")+ +instance HsProtobuf.Message AllPackedTypes where+ encodeMessage _+ AllPackedTypes{allPackedTypesPackedWord32 =+ allPackedTypesPackedWord32,+ allPackedTypesPackedWord64 = allPackedTypesPackedWord64,+ allPackedTypesPackedInt32 = allPackedTypesPackedInt32,+ allPackedTypesPackedInt64 = allPackedTypesPackedInt64,+ allPackedTypesPackedFixed32 = allPackedTypesPackedFixed32,+ allPackedTypesPackedFixed64 = allPackedTypesPackedFixed64,+ allPackedTypesPackedFloat = allPackedTypesPackedFloat,+ allPackedTypesPackedDouble = allPackedTypesPackedDouble,+ allPackedTypesPackedSFixed32 = allPackedTypesPackedSFixed32,+ allPackedTypesPackedSFixed64 = allPackedTypesPackedSFixed64,+ allPackedTypesPackedBool = allPackedTypesPackedBool,+ allPackedTypesPackedEnum = allPackedTypesPackedEnum,+ allPackedTypesUnpackedEnum = allPackedTypesUnpackedEnum}+ = (Hs.mconcat+ [(HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 1)+ (HsProtobuf.PackedVec allPackedTypesPackedWord32)),+ (HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 2)+ (HsProtobuf.PackedVec allPackedTypesPackedWord64)),+ (HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 3)+ (HsProtobuf.PackedVec allPackedTypesPackedInt32)),+ (HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 4)+ (HsProtobuf.PackedVec allPackedTypesPackedInt64)),+ (HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 5)+ (HsProtobuf.PackedVec allPackedTypesPackedFixed32)),+ (HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 6)+ (HsProtobuf.PackedVec allPackedTypesPackedFixed64)),+ (HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 7)+ (HsProtobuf.PackedVec allPackedTypesPackedFloat)),+ (HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 8)+ (HsProtobuf.PackedVec allPackedTypesPackedDouble)),+ (HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 9)+ (HsProtobuf.PackedVec+ (Hs.fmap HsProtobuf.Signed allPackedTypesPackedSFixed32))),+ (HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 10)+ (HsProtobuf.PackedVec+ (Hs.fmap HsProtobuf.Signed allPackedTypesPackedSFixed64))),+ (HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 11)+ (HsProtobuf.PackedVec allPackedTypesPackedBool)),+ (HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 12)+ (HsProtobuf.PackedVec allPackedTypesPackedEnum)),+ (HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 13)+ (HsProtobuf.UnpackedVec allPackedTypesUnpackedEnum))])+ decodeMessage _+ = (Hs.pure AllPackedTypes) <*>+ ((Hs.pure HsProtobuf.packedvec) <*>+ (HsProtobuf.at HsProtobuf.decodeMessageField+ (HsProtobuf.FieldNumber 1)))+ <*>+ ((Hs.pure HsProtobuf.packedvec) <*>+ (HsProtobuf.at HsProtobuf.decodeMessageField+ (HsProtobuf.FieldNumber 2)))+ <*>+ ((Hs.pure HsProtobuf.packedvec) <*>+ (HsProtobuf.at HsProtobuf.decodeMessageField+ (HsProtobuf.FieldNumber 3)))+ <*>+ ((Hs.pure HsProtobuf.packedvec) <*>+ (HsProtobuf.at HsProtobuf.decodeMessageField+ (HsProtobuf.FieldNumber 4)))+ <*>+ ((Hs.pure HsProtobuf.packedvec) <*>+ (HsProtobuf.at HsProtobuf.decodeMessageField+ (HsProtobuf.FieldNumber 5)))+ <*>+ ((Hs.pure HsProtobuf.packedvec) <*>+ (HsProtobuf.at HsProtobuf.decodeMessageField+ (HsProtobuf.FieldNumber 6)))+ <*>+ ((Hs.pure HsProtobuf.packedvec) <*>+ (HsProtobuf.at HsProtobuf.decodeMessageField+ (HsProtobuf.FieldNumber 7)))+ <*>+ ((Hs.pure HsProtobuf.packedvec) <*>+ (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.pure (Hs.fmap HsProtobuf.signed)) <*>+ ((Hs.pure HsProtobuf.packedvec) <*>+ (HsProtobuf.at HsProtobuf.decodeMessageField+ (HsProtobuf.FieldNumber 10))))+ <*>+ ((Hs.pure HsProtobuf.packedvec) <*>+ (HsProtobuf.at HsProtobuf.decodeMessageField+ (HsProtobuf.FieldNumber 11)))+ <*>+ ((Hs.pure HsProtobuf.packedvec) <*>+ (HsProtobuf.at HsProtobuf.decodeMessageField+ (HsProtobuf.FieldNumber 12)))+ <*>+ ((Hs.pure HsProtobuf.unpackedvec) <*>+ (HsProtobuf.at HsProtobuf.decodeMessageField+ (HsProtobuf.FieldNumber 13)))+ dotProto _+ = [(HsProtobuf.DotProtoField (HsProtobuf.FieldNumber 1)+ (HsProtobuf.Repeated HsProtobuf.UInt32)+ (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+ (AllPackedTypes f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 f12 f13)+ = (HsJSONPB.object+ ["packedWord32" .= f1, "packedWord64" .= f2, "packedInt32" .= f3,+ "packedInt64" .= f4, "packedFixed32" .= f5, "packedFixed64" .= f6,+ "packedFloat" .= f7, "packedDouble" .= f8, "packedSFixed32" .= f9,+ "packedSFixed64" .= f10, "packedBool" .= f11, "packedEnum" .= f12,+ "unpackedEnum" .= f13])+ toEncodingPB+ (AllPackedTypes f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 f12 f13)+ = (HsJSONPB.pairs+ ["packedWord32" .= f1, "packedWord64" .= f2, "packedInt32" .= f3,+ "packedInt64" .= f4, "packedFixed32" .= f5, "packedFixed64" .= f6,+ "packedFloat" .= f7, "packedDouble" .= f8, "packedSFixed32" .= f9,+ "packedSFixed64" .= f10, "packedBool" .= f11, "packedEnum" .= f12,+ "unpackedEnum" .= f13])+ +instance HsJSONPB.FromJSONPB AllPackedTypes where+ parseJSONPB+ = (HsJSONPB.withObject "AllPackedTypes"+ (\ obj ->+ (Hs.pure AllPackedTypes) <*> obj .: "packedWord32" <*>+ obj .: "packedWord64"+ <*> obj .: "packedInt32"+ <*> obj .: "packedInt64"+ <*> obj .: "packedFixed32"+ <*> obj .: "packedFixed64"+ <*> obj .: "packedFloat"+ <*> obj .: "packedDouble"+ <*> obj .: "packedSFixed32"+ <*> obj .: "packedSFixed64"+ <*> obj .: "packedBool"+ <*> obj .: "packedEnum"+ <*> obj .: "unpackedEnum"))+ +instance HsJSONPB.ToJSON AllPackedTypes where+ toJSON = HsJSONPB.toAesonValue+ toEncoding = HsJSONPB.toAesonEncoding+ +instance HsJSONPB.FromJSON AllPackedTypes where+ parseJSON = HsJSONPB.parseJSONPB+ +instance HsJSONPB.ToSchema AllPackedTypes where+ declareNamedSchema _+ = do let declare_packedWord32 = HsJSONPB.declareSchemaRef+ allPackedTypesPackedWord32 <- declare_packedWord32 Proxy.Proxy+ let declare_packedWord64 = HsJSONPB.declareSchemaRef+ allPackedTypesPackedWord64 <- declare_packedWord64 Proxy.Proxy+ let declare_packedInt32 = HsJSONPB.declareSchemaRef+ allPackedTypesPackedInt32 <- declare_packedInt32 Proxy.Proxy+ let declare_packedInt64 = HsJSONPB.declareSchemaRef+ allPackedTypesPackedInt64 <- declare_packedInt64 Proxy.Proxy+ let declare_packedFixed32 = HsJSONPB.declareSchemaRef+ allPackedTypesPackedFixed32 <- declare_packedFixed32 Proxy.Proxy+ let declare_packedFixed64 = HsJSONPB.declareSchemaRef+ allPackedTypesPackedFixed64 <- declare_packedFixed64 Proxy.Proxy+ let declare_packedFloat = HsJSONPB.declareSchemaRef+ allPackedTypesPackedFloat <- declare_packedFloat Proxy.Proxy+ let declare_packedDouble = HsJSONPB.declareSchemaRef+ allPackedTypesPackedDouble <- declare_packedDouble Proxy.Proxy+ let declare_packedSFixed32 = HsJSONPB.declareSchemaRef+ allPackedTypesPackedSFixed32 <- declare_packedSFixed32 Proxy.Proxy+ let declare_packedSFixed64 = HsJSONPB.declareSchemaRef+ allPackedTypesPackedSFixed64 <- declare_packedSFixed64 Proxy.Proxy+ let declare_packedBool = HsJSONPB.declareSchemaRef+ allPackedTypesPackedBool <- declare_packedBool Proxy.Proxy+ let declare_packedEnum = HsJSONPB.declareSchemaRef+ allPackedTypesPackedEnum <- declare_packedEnum Proxy.Proxy+ let declare_unpackedEnum = HsJSONPB.declareSchemaRef+ allPackedTypesUnpackedEnum <- declare_unpackedEnum Proxy.Proxy+ let _ = Hs.pure AllPackedTypes <*>+ HsJSONPB.asProxy declare_packedWord32+ <*> HsJSONPB.asProxy declare_packedWord64+ <*> HsJSONPB.asProxy declare_packedInt32+ <*> HsJSONPB.asProxy declare_packedInt64+ <*> HsJSONPB.asProxy declare_packedFixed32+ <*> HsJSONPB.asProxy declare_packedFixed64+ <*> HsJSONPB.asProxy declare_packedFloat+ <*> HsJSONPB.asProxy declare_packedDouble+ <*> HsJSONPB.asProxy declare_packedSFixed32+ <*> HsJSONPB.asProxy declare_packedSFixed64+ <*> HsJSONPB.asProxy declare_packedBool+ <*> HsJSONPB.asProxy declare_packedEnum+ <*> HsJSONPB.asProxy declare_unpackedEnum+ Hs.return+ (HsJSONPB.NamedSchema{HsJSONPB._namedSchemaName =+ Hs.Just "AllPackedTypes",+ HsJSONPB._namedSchemaSchema =+ Hs.mempty{HsJSONPB._schemaParamSchema =+ Hs.mempty{HsJSONPB._paramSchemaType =+ HsJSONPB.SwaggerObject},+ HsJSONPB._schemaProperties =+ HsJSONPB.insOrdFromList+ [("packedWord32",+ allPackedTypesPackedWord32),+ ("packedWord64",+ allPackedTypesPackedWord64),+ ("packedInt32", allPackedTypesPackedInt32),+ ("packedInt64", allPackedTypesPackedInt64),+ ("packedFixed32",+ allPackedTypesPackedFixed32),+ ("packedFixed64",+ allPackedTypesPackedFixed64),+ ("packedFloat", allPackedTypesPackedFloat),+ ("packedDouble",+ allPackedTypesPackedDouble),+ ("packedSFixed32",+ allPackedTypesPackedSFixed32),+ ("packedSFixed64",+ allPackedTypesPackedSFixed64),+ ("packedBool", allPackedTypesPackedBool),+ ("packedEnum", allPackedTypesPackedEnum),+ ("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)+ +instance HsProtobuf.Named OutOfOrderFields where+ nameOf _ = (Hs.fromString "OutOfOrderFields")+ +instance HsProtobuf.Message OutOfOrderFields where+ encodeMessage _+ OutOfOrderFields{outOfOrderFieldsField1 = outOfOrderFieldsField1,+ outOfOrderFieldsField2 = outOfOrderFieldsField2,+ outOfOrderFieldsField3 = outOfOrderFieldsField3,+ outOfOrderFieldsField4 = outOfOrderFieldsField4}+ = (Hs.mconcat+ [(HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 2001)+ (HsProtobuf.PackedVec outOfOrderFieldsField1)),+ (HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 101)+ outOfOrderFieldsField2),+ (HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 30)+ outOfOrderFieldsField3),+ (HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 1002)+ (HsProtobuf.UnpackedVec outOfOrderFieldsField4))])+ decodeMessage _+ = (Hs.pure OutOfOrderFields) <*>+ ((Hs.pure HsProtobuf.packedvec) <*>+ (HsProtobuf.at HsProtobuf.decodeMessageField+ (HsProtobuf.FieldNumber 2001)))+ <*>+ (HsProtobuf.at HsProtobuf.decodeMessageField+ (HsProtobuf.FieldNumber 101))+ <*>+ (HsProtobuf.at HsProtobuf.decodeMessageField+ (HsProtobuf.FieldNumber 30))+ <*>+ ((Hs.pure HsProtobuf.unpackedvec) <*>+ (HsProtobuf.at HsProtobuf.decodeMessageField+ (HsProtobuf.FieldNumber 1002)))+ dotProto _+ = [(HsProtobuf.DotProtoField (HsProtobuf.FieldNumber 2001)+ (HsProtobuf.Repeated HsProtobuf.UInt32)+ (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)+ = (HsJSONPB.object+ ["field1" .= f2001, "field2" .= f101, "field3" .= f30,+ "field4" .= f1002])+ toEncodingPB (OutOfOrderFields f2001 f101 f30 f1002)+ = (HsJSONPB.pairs+ ["field1" .= f2001, "field2" .= f101, "field3" .= f30,+ "field4" .= f1002])+ +instance HsJSONPB.FromJSONPB OutOfOrderFields where+ parseJSONPB+ = (HsJSONPB.withObject "OutOfOrderFields"+ (\ obj ->+ (Hs.pure OutOfOrderFields) <*> obj .: "field1" <*> obj .: "field2"+ <*> obj .: "field3"+ <*> obj .: "field4"))+ +instance HsJSONPB.ToJSON OutOfOrderFields where+ toJSON = HsJSONPB.toAesonValue+ toEncoding = HsJSONPB.toAesonEncoding+ +instance HsJSONPB.FromJSON OutOfOrderFields where+ parseJSON = HsJSONPB.parseJSONPB+ +instance HsJSONPB.ToSchema OutOfOrderFields where+ declareNamedSchema _+ = do let declare_field1 = HsJSONPB.declareSchemaRef+ outOfOrderFieldsField1 <- declare_field1 Proxy.Proxy+ let declare_field2 = HsJSONPB.declareSchemaRef+ outOfOrderFieldsField2 <- declare_field2 Proxy.Proxy+ let declare_field3 = HsJSONPB.declareSchemaRef+ outOfOrderFieldsField3 <- declare_field3 Proxy.Proxy+ let declare_field4 = HsJSONPB.declareSchemaRef+ outOfOrderFieldsField4 <- declare_field4 Proxy.Proxy+ let _ = Hs.pure OutOfOrderFields <*>+ HsJSONPB.asProxy declare_field1+ <*> HsJSONPB.asProxy declare_field2+ <*> HsJSONPB.asProxy declare_field3+ <*> HsJSONPB.asProxy declare_field4+ Hs.return+ (HsJSONPB.NamedSchema{HsJSONPB._namedSchemaName =+ Hs.Just "OutOfOrderFields",+ HsJSONPB._namedSchemaSchema =+ Hs.mempty{HsJSONPB._schemaParamSchema =+ Hs.mempty{HsJSONPB._paramSchemaType =+ HsJSONPB.SwaggerObject},+ HsJSONPB._schemaProperties =+ HsJSONPB.insOrdFromList+ [("field1", outOfOrderFieldsField1),+ ("field2", outOfOrderFieldsField2),+ ("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)+ +instance HsProtobuf.Named ShadowedMessage where+ nameOf _ = (Hs.fromString "ShadowedMessage")+ +instance HsProtobuf.Message ShadowedMessage where+ encodeMessage _+ ShadowedMessage{shadowedMessageName = shadowedMessageName,+ shadowedMessageValue = shadowedMessageValue}+ = (Hs.mconcat+ [(HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 2)+ shadowedMessageName),+ (HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 1)+ shadowedMessageValue)])+ decodeMessage _+ = (Hs.pure ShadowedMessage) <*>+ (HsProtobuf.at HsProtobuf.decodeMessageField+ (HsProtobuf.FieldNumber 2))+ <*>+ (HsProtobuf.at HsProtobuf.decodeMessageField+ (HsProtobuf.FieldNumber 1))+ dotProto _+ = [(HsProtobuf.DotProtoField (HsProtobuf.FieldNumber 2)+ (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)+ = (HsJSONPB.object ["name" .= f2, "value" .= f1])+ toEncodingPB (ShadowedMessage f2 f1)+ = (HsJSONPB.pairs ["name" .= f2, "value" .= f1])+ +instance HsJSONPB.FromJSONPB ShadowedMessage where+ parseJSONPB+ = (HsJSONPB.withObject "ShadowedMessage"+ (\ obj ->+ (Hs.pure ShadowedMessage) <*> obj .: "name" <*> obj .: "value"))+ +instance HsJSONPB.ToJSON ShadowedMessage where+ toJSON = HsJSONPB.toAesonValue+ toEncoding = HsJSONPB.toAesonEncoding+ +instance HsJSONPB.FromJSON ShadowedMessage where+ parseJSON = HsJSONPB.parseJSONPB+ +instance HsJSONPB.ToSchema ShadowedMessage where+ declareNamedSchema _+ = do let declare_name = HsJSONPB.declareSchemaRef+ shadowedMessageName <- declare_name Proxy.Proxy+ let declare_value = HsJSONPB.declareSchemaRef+ shadowedMessageValue <- declare_value Proxy.Proxy+ let _ = Hs.pure ShadowedMessage <*> HsJSONPB.asProxy declare_name+ <*> HsJSONPB.asProxy declare_value+ Hs.return+ (HsJSONPB.NamedSchema{HsJSONPB._namedSchemaName =+ Hs.Just "ShadowedMessage",+ HsJSONPB._namedSchemaSchema =+ Hs.mempty{HsJSONPB._schemaParamSchema =+ Hs.mempty{HsJSONPB._paramSchemaType =+ HsJSONPB.SwaggerObject},+ HsJSONPB._schemaProperties =+ HsJSONPB.insOrdFromList+ [("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)+ +instance HsProtobuf.Named MessageShadower where+ nameOf _ = (Hs.fromString "MessageShadower")+ +instance HsProtobuf.Message MessageShadower where+ encodeMessage _+ MessageShadower{messageShadowerShadowedMessage =+ messageShadowerShadowedMessage,+ messageShadowerName = messageShadowerName}+ = (Hs.mconcat+ [(HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 1)+ (HsProtobuf.Nested messageShadowerShadowedMessage)),+ (HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 2)+ messageShadowerName)])+ decodeMessage _+ = (Hs.pure MessageShadower) <*>+ ((Hs.pure HsProtobuf.nested) <*>+ (HsProtobuf.at HsProtobuf.decodeMessageField+ (HsProtobuf.FieldNumber 1)))+ <*>+ (HsProtobuf.at HsProtobuf.decodeMessageField+ (HsProtobuf.FieldNumber 2))+ dotProto _+ = [(HsProtobuf.DotProtoField (HsProtobuf.FieldNumber 1)+ (HsProtobuf.Prim+ (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)+ = (HsJSONPB.object ["shadowed_message" .= f1, "name" .= f2])+ toEncodingPB (MessageShadower f1 f2)+ = (HsJSONPB.pairs ["shadowed_message" .= f1, "name" .= f2])+ +instance HsJSONPB.FromJSONPB MessageShadower where+ parseJSONPB+ = (HsJSONPB.withObject "MessageShadower"+ (\ obj ->+ (Hs.pure MessageShadower) <*> obj .: "shadowed_message" <*>+ obj .: "name"))+ +instance HsJSONPB.ToJSON MessageShadower where+ toJSON = HsJSONPB.toAesonValue+ toEncoding = HsJSONPB.toAesonEncoding+ +instance HsJSONPB.FromJSON MessageShadower where+ parseJSON = HsJSONPB.parseJSONPB+ +instance HsJSONPB.ToSchema MessageShadower where+ declareNamedSchema _+ = do let declare_shadowed_message = HsJSONPB.declareSchemaRef+ messageShadowerShadowedMessage <- declare_shadowed_message+ Proxy.Proxy+ let declare_name = HsJSONPB.declareSchemaRef+ messageShadowerName <- declare_name Proxy.Proxy+ let _ = Hs.pure MessageShadower <*>+ HsJSONPB.asProxy declare_shadowed_message+ <*> HsJSONPB.asProxy declare_name+ Hs.return+ (HsJSONPB.NamedSchema{HsJSONPB._namedSchemaName =+ Hs.Just "MessageShadower",+ HsJSONPB._namedSchemaSchema =+ Hs.mempty{HsJSONPB._schemaParamSchema =+ Hs.mempty{HsJSONPB._paramSchemaType =+ HsJSONPB.SwaggerObject},+ HsJSONPB._schemaProperties =+ HsJSONPB.insOrdFromList+ [("shadowed_message",+ 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)+ +instance HsProtobuf.Named MessageShadower_ShadowedMessage where+ nameOf _ = (Hs.fromString "MessageShadower_ShadowedMessage")+ +instance HsProtobuf.Message MessageShadower_ShadowedMessage where+ encodeMessage _+ MessageShadower_ShadowedMessage{messageShadower_ShadowedMessageName+ = messageShadower_ShadowedMessageName,+ messageShadower_ShadowedMessageValue =+ messageShadower_ShadowedMessageValue}+ = (Hs.mconcat+ [(HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 1)+ messageShadower_ShadowedMessageName),+ (HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 2)+ messageShadower_ShadowedMessageValue)])+ decodeMessage _+ = (Hs.pure MessageShadower_ShadowedMessage) <*>+ (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 "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)+ = (HsJSONPB.object ["name" .= f1, "value" .= f2])+ toEncodingPB (MessageShadower_ShadowedMessage f1 f2)+ = (HsJSONPB.pairs ["name" .= f1, "value" .= f2])+ +instance HsJSONPB.FromJSONPB MessageShadower_ShadowedMessage where+ parseJSONPB+ = (HsJSONPB.withObject "MessageShadower_ShadowedMessage"+ (\ obj ->+ (Hs.pure MessageShadower_ShadowedMessage) <*> obj .: "name" <*>+ obj .: "value"))+ +instance HsJSONPB.ToJSON MessageShadower_ShadowedMessage where+ toJSON = HsJSONPB.toAesonValue+ toEncoding = HsJSONPB.toAesonEncoding+ +instance HsJSONPB.FromJSON MessageShadower_ShadowedMessage where+ parseJSON = HsJSONPB.parseJSONPB+ +instance HsJSONPB.ToSchema MessageShadower_ShadowedMessage where+ declareNamedSchema _+ = do let declare_name = HsJSONPB.declareSchemaRef+ messageShadower_ShadowedMessageName <- declare_name Proxy.Proxy+ let declare_value = HsJSONPB.declareSchemaRef+ messageShadower_ShadowedMessageValue <- declare_value Proxy.Proxy+ let _ = Hs.pure MessageShadower_ShadowedMessage <*>+ HsJSONPB.asProxy declare_name+ <*> HsJSONPB.asProxy declare_value+ Hs.return+ (HsJSONPB.NamedSchema{HsJSONPB._namedSchemaName =+ Hs.Just "MessageShadower_ShadowedMessage",+ HsJSONPB._namedSchemaSchema =+ Hs.mempty{HsJSONPB._schemaParamSchema =+ Hs.mempty{HsJSONPB._paramSchemaType =+ HsJSONPB.SwaggerObject},+ HsJSONPB._schemaProperties =+ HsJSONPB.insOrdFromList+ [("name",+ messageShadower_ShadowedMessageName),+ ("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)+ +instance HsProtobuf.Named WithQualifiedName where+ nameOf _ = (Hs.fromString "WithQualifiedName")+ +instance HsProtobuf.Message WithQualifiedName where+ encodeMessage _+ WithQualifiedName{withQualifiedNameQname1 =+ withQualifiedNameQname1,+ withQualifiedNameQname2 = withQualifiedNameQname2}+ = (Hs.mconcat+ [(HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 100)+ (HsProtobuf.Nested withQualifiedNameQname1)),+ (HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 200)+ (HsProtobuf.Nested withQualifiedNameQname2))])+ decodeMessage _+ = (Hs.pure WithQualifiedName) <*>+ ((Hs.pure HsProtobuf.nested) <*>+ (HsProtobuf.at HsProtobuf.decodeMessageField+ (HsProtobuf.FieldNumber 100)))+ <*>+ ((Hs.pure HsProtobuf.nested) <*>+ (HsProtobuf.at HsProtobuf.decodeMessageField+ (HsProtobuf.FieldNumber 200)))+ dotProto _+ = [(HsProtobuf.DotProtoField (HsProtobuf.FieldNumber 100)+ (HsProtobuf.Prim+ (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.Single "qname2")+ []+ Hs.Nothing)]+ +instance HsJSONPB.ToJSONPB WithQualifiedName where+ toJSONPB (WithQualifiedName f100 f200)+ = (HsJSONPB.object ["qname1" .= f100, "qname2" .= f200])+ toEncodingPB (WithQualifiedName f100 f200)+ = (HsJSONPB.pairs ["qname1" .= f100, "qname2" .= f200])+ +instance HsJSONPB.FromJSONPB WithQualifiedName where+ parseJSONPB+ = (HsJSONPB.withObject "WithQualifiedName"+ (\ obj ->+ (Hs.pure WithQualifiedName) <*> obj .: "qname1" <*>+ obj .: "qname2"))+ +instance HsJSONPB.ToJSON WithQualifiedName where+ toJSON = HsJSONPB.toAesonValue+ toEncoding = HsJSONPB.toAesonEncoding+ +instance HsJSONPB.FromJSON WithQualifiedName where+ parseJSON = HsJSONPB.parseJSONPB+ +instance HsJSONPB.ToSchema WithQualifiedName where+ declareNamedSchema _+ = do let declare_qname1 = HsJSONPB.declareSchemaRef+ withQualifiedNameQname1 <- declare_qname1 Proxy.Proxy+ let declare_qname2 = HsJSONPB.declareSchemaRef+ withQualifiedNameQname2 <- declare_qname2 Proxy.Proxy+ let _ = Hs.pure WithQualifiedName <*>+ HsJSONPB.asProxy declare_qname1+ <*> HsJSONPB.asProxy declare_qname2+ Hs.return+ (HsJSONPB.NamedSchema{HsJSONPB._namedSchemaName =+ Hs.Just "WithQualifiedName",+ HsJSONPB._namedSchemaSchema =+ Hs.mempty{HsJSONPB._schemaParamSchema =+ Hs.mempty{HsJSONPB._paramSchemaType =+ HsJSONPB.SwaggerObject},+ HsJSONPB._schemaProperties =+ HsJSONPB.insOrdFromList+ [("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)+ +instance HsProtobuf.Named UsingImported where+ nameOf _ = (Hs.fromString "UsingImported")+ +instance HsProtobuf.Message UsingImported where+ encodeMessage _+ UsingImported{usingImportedImportedNesting =+ usingImportedImportedNesting,+ usingImportedLocalNesting = usingImportedLocalNesting}+ = (Hs.mconcat+ [(HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 100)+ (HsProtobuf.Nested usingImportedImportedNesting)),+ (HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 200)+ (HsProtobuf.Nested usingImportedLocalNesting))])+ decodeMessage _+ = (Hs.pure UsingImported) <*>+ ((Hs.pure HsProtobuf.nested) <*>+ (HsProtobuf.at HsProtobuf.decodeMessageField+ (HsProtobuf.FieldNumber 100)))+ <*>+ ((Hs.pure HsProtobuf.nested) <*>+ (HsProtobuf.at HsProtobuf.decodeMessageField+ (HsProtobuf.FieldNumber 200)))+ dotProto _+ = [(HsProtobuf.DotProtoField (HsProtobuf.FieldNumber 100)+ (HsProtobuf.Prim+ (HsProtobuf.Named+ (HsProtobuf.Dots+ (HsProtobuf.Path ["TestProtoImport", "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)+ = (HsJSONPB.object+ ["importedNesting" .= f100, "localNesting" .= f200])+ toEncodingPB (UsingImported f100 f200)+ = (HsJSONPB.pairs+ ["importedNesting" .= f100, "localNesting" .= f200])+ +instance HsJSONPB.FromJSONPB UsingImported where+ parseJSONPB+ = (HsJSONPB.withObject "UsingImported"+ (\ obj ->+ (Hs.pure UsingImported) <*> obj .: "importedNesting" <*>+ obj .: "localNesting"))+ +instance HsJSONPB.ToJSON UsingImported where+ toJSON = HsJSONPB.toAesonValue+ toEncoding = HsJSONPB.toAesonEncoding+ +instance HsJSONPB.FromJSON UsingImported where+ parseJSON = HsJSONPB.parseJSONPB+ +instance HsJSONPB.ToSchema UsingImported where+ declareNamedSchema _+ = do let declare_importedNesting = HsJSONPB.declareSchemaRef+ usingImportedImportedNesting <- declare_importedNesting Proxy.Proxy+ let declare_localNesting = HsJSONPB.declareSchemaRef+ usingImportedLocalNesting <- declare_localNesting Proxy.Proxy+ let _ = Hs.pure UsingImported <*>+ HsJSONPB.asProxy declare_importedNesting+ <*> HsJSONPB.asProxy declare_localNesting+ Hs.return+ (HsJSONPB.NamedSchema{HsJSONPB._namedSchemaName =+ Hs.Just "UsingImported",+ HsJSONPB._namedSchemaSchema =+ Hs.mempty{HsJSONPB._schemaParamSchema =+ Hs.mempty{HsJSONPB._paramSchemaType =+ HsJSONPB.SwaggerObject},+ HsJSONPB._schemaProperties =+ HsJSONPB.insOrdFromList+ [("importedNesting",+ usingImportedImportedNesting),+ ("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)+ +instance HsProtobuf.Named Wrapped where+ nameOf _ = (Hs.fromString "Wrapped")+ +instance HsProtobuf.Message Wrapped where+ encodeMessage _ Wrapped{wrappedWrapped = wrappedWrapped}+ = (Hs.mconcat+ [(HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 1)+ (HsProtobuf.Nested wrappedWrapped))])+ decodeMessage _+ = (Hs.pure Wrapped) <*>+ ((Hs.pure HsProtobuf.nested) <*>+ (HsProtobuf.at HsProtobuf.decodeMessageField+ (HsProtobuf.FieldNumber 1)))+ dotProto _+ = [(HsProtobuf.DotProtoField (HsProtobuf.FieldNumber 1)+ (HsProtobuf.Prim (HsProtobuf.Named (HsProtobuf.Single "Wrapped")))+ (HsProtobuf.Single "wrapped")+ []+ Hs.Nothing)]+ +instance HsJSONPB.ToJSONPB Wrapped where+ toJSONPB (Wrapped f1) = (HsJSONPB.object ["wrapped" .= f1])+ toEncodingPB (Wrapped f1) = (HsJSONPB.pairs ["wrapped" .= f1])+ +instance HsJSONPB.FromJSONPB Wrapped where+ parseJSONPB+ = (HsJSONPB.withObject "Wrapped"+ (\ obj -> (Hs.pure Wrapped) <*> obj .: "wrapped"))+ +instance HsJSONPB.ToJSON Wrapped where+ toJSON = HsJSONPB.toAesonValue+ toEncoding = HsJSONPB.toAesonEncoding+ +instance HsJSONPB.FromJSON Wrapped where+ parseJSON = HsJSONPB.parseJSONPB+ +instance HsJSONPB.ToSchema Wrapped where+ declareNamedSchema _+ = do let declare_wrapped = HsJSONPB.declareSchemaRef+ wrappedWrapped <- declare_wrapped Proxy.Proxy+ let _ = Hs.pure Wrapped <*> HsJSONPB.asProxy declare_wrapped+ Hs.return+ (HsJSONPB.NamedSchema{HsJSONPB._namedSchemaName =+ Hs.Just "Wrapped",+ HsJSONPB._namedSchemaSchema =+ Hs.mempty{HsJSONPB._schemaParamSchema =+ Hs.mempty{HsJSONPB._paramSchemaType =+ HsJSONPB.SwaggerObject},+ HsJSONPB._schemaProperties =+ 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)+ +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 HsJSONPB.ToJSONPB EnumAnnots where+ toJSONPB x _ = HsJSONPB.enumFieldString x+ toEncodingPB x _ = HsJSONPB.enumFieldEncoding x+ +instance HsJSONPB.FromJSONPB EnumAnnots where+ parseJSONPB (HsJSONPB.String "FOO") = Hs.pure EnumAnnotsFOO+ parseJSONPB (HsJSONPB.String "BAR") = Hs.pure EnumAnnotsBAR+ parseJSONPB v = (HsJSONPB.typeMismatch "EnumAnnots" v)+ +instance HsJSONPB.ToJSON EnumAnnots where+ toJSON = HsJSONPB.toAesonValue+ toEncoding = HsJSONPB.toAesonEncoding+ +instance HsJSONPB.FromJSON EnumAnnots where+ parseJSON = HsJSONPB.parseJSONPB+ +instance HsDhallPb.Interpret EnumAnnots+ +instance HsDhallPb.Inject EnumAnnots+ +instance HsProtobuf.Finite EnumAnnots
+ gen/TestProtoImport.hs view
@@ -0,0 +1,202 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE GADTs #-}+{-# 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!+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.JSONPB as HsJSONPB+import Proto3.Suite.JSONPB ((.=), (.:))+import qualified Proto3.Wire as HsProtobuf+import Control.Applicative ((<*>), (<|>), (<$>))+import qualified Control.Applicative 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.String as Hs (fromString)+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+ +data WithNesting = WithNesting{withNestingNestedMessage1 ::+ Hs.Maybe TestProtoImport.WithNesting_Nested,+ withNestingNestedMessage2 ::+ Hs.Maybe TestProtoImport.WithNesting_Nested}+ deriving (Hs.Show, Hs.Eq, Hs.Ord, Hs.Generic)+ +instance HsProtobuf.Named WithNesting where+ nameOf _ = (Hs.fromString "WithNesting")+ +instance HsProtobuf.Message WithNesting where+ encodeMessage _+ WithNesting{withNestingNestedMessage1 = withNestingNestedMessage1,+ withNestingNestedMessage2 = withNestingNestedMessage2}+ = (Hs.mconcat+ [(HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 1)+ (HsProtobuf.Nested withNestingNestedMessage1)),+ (HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 100)+ (HsProtobuf.Nested withNestingNestedMessage2))])+ decodeMessage _+ = (Hs.pure WithNesting) <*>+ ((Hs.pure HsProtobuf.nested) <*>+ (HsProtobuf.at HsProtobuf.decodeMessageField+ (HsProtobuf.FieldNumber 1)))+ <*>+ ((Hs.pure HsProtobuf.nested) <*>+ (HsProtobuf.at HsProtobuf.decodeMessageField+ (HsProtobuf.FieldNumber 100)))+ dotProto _+ = [(HsProtobuf.DotProtoField (HsProtobuf.FieldNumber 1)+ (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)+ = (HsJSONPB.object+ ["nestedMessage1" .= f1, "nestedMessage2" .= f100])+ toEncodingPB (WithNesting f1 f100)+ = (HsJSONPB.pairs+ ["nestedMessage1" .= f1, "nestedMessage2" .= f100])+ +instance HsJSONPB.FromJSONPB WithNesting where+ parseJSONPB+ = (HsJSONPB.withObject "WithNesting"+ (\ obj ->+ (Hs.pure WithNesting) <*> obj .: "nestedMessage1" <*>+ obj .: "nestedMessage2"))+ +instance HsJSONPB.ToJSON WithNesting where+ toJSON = HsJSONPB.toAesonValue+ toEncoding = HsJSONPB.toAesonEncoding+ +instance HsJSONPB.FromJSON WithNesting where+ parseJSON = HsJSONPB.parseJSONPB+ +instance HsJSONPB.ToSchema WithNesting where+ declareNamedSchema _+ = do let declare_nestedMessage1 = HsJSONPB.declareSchemaRef+ withNestingNestedMessage1 <- declare_nestedMessage1 Proxy.Proxy+ let declare_nestedMessage2 = HsJSONPB.declareSchemaRef+ withNestingNestedMessage2 <- declare_nestedMessage2 Proxy.Proxy+ let _ = Hs.pure WithNesting <*>+ HsJSONPB.asProxy declare_nestedMessage1+ <*> HsJSONPB.asProxy declare_nestedMessage2+ Hs.return+ (HsJSONPB.NamedSchema{HsJSONPB._namedSchemaName =+ Hs.Just "WithNesting",+ HsJSONPB._namedSchemaSchema =+ Hs.mempty{HsJSONPB._schemaParamSchema =+ Hs.mempty{HsJSONPB._paramSchemaType =+ HsJSONPB.SwaggerObject},+ HsJSONPB._schemaProperties =+ HsJSONPB.insOrdFromList+ [("nestedMessage1",+ withNestingNestedMessage1),+ ("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)+ +instance HsProtobuf.Named WithNesting_Nested where+ nameOf _ = (Hs.fromString "WithNesting_Nested")+ +instance HsProtobuf.Message WithNesting_Nested where+ encodeMessage _+ WithNesting_Nested{withNesting_NestedNestedField1 =+ withNesting_NestedNestedField1,+ withNesting_NestedNestedField2 = withNesting_NestedNestedField2}+ = (Hs.mconcat+ [(HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 1)+ withNesting_NestedNestedField1),+ (HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 2)+ withNesting_NestedNestedField2)])+ decodeMessage _+ = (Hs.pure WithNesting_Nested) <*>+ (HsProtobuf.at HsProtobuf.decodeMessageField+ (HsProtobuf.FieldNumber 1))+ <*>+ (HsProtobuf.at HsProtobuf.decodeMessageField+ (HsProtobuf.FieldNumber 2))+ dotProto _+ = [(HsProtobuf.DotProtoField (HsProtobuf.FieldNumber 1)+ (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)+ = (HsJSONPB.object ["nestedField1" .= f1, "nestedField2" .= f2])+ toEncodingPB (WithNesting_Nested f1 f2)+ = (HsJSONPB.pairs ["nestedField1" .= f1, "nestedField2" .= f2])+ +instance HsJSONPB.FromJSONPB WithNesting_Nested where+ parseJSONPB+ = (HsJSONPB.withObject "WithNesting_Nested"+ (\ obj ->+ (Hs.pure WithNesting_Nested) <*> obj .: "nestedField1" <*>+ obj .: "nestedField2"))+ +instance HsJSONPB.ToJSON WithNesting_Nested where+ toJSON = HsJSONPB.toAesonValue+ toEncoding = HsJSONPB.toAesonEncoding+ +instance HsJSONPB.FromJSON WithNesting_Nested where+ parseJSON = HsJSONPB.parseJSONPB+ +instance HsJSONPB.ToSchema WithNesting_Nested where+ declareNamedSchema _+ = do let declare_nestedField1 = HsJSONPB.declareSchemaRef+ withNesting_NestedNestedField1 <- declare_nestedField1 Proxy.Proxy+ let declare_nestedField2 = HsJSONPB.declareSchemaRef+ withNesting_NestedNestedField2 <- declare_nestedField2 Proxy.Proxy+ let _ = Hs.pure WithNesting_Nested <*>+ HsJSONPB.asProxy declare_nestedField1+ <*> HsJSONPB.asProxy declare_nestedField2+ Hs.return+ (HsJSONPB.NamedSchema{HsJSONPB._namedSchemaName =+ Hs.Just "WithNesting_Nested",+ HsJSONPB._namedSchemaSchema =+ Hs.mempty{HsJSONPB._schemaParamSchema =+ Hs.mempty{HsJSONPB._paramSchemaType =+ HsJSONPB.SwaggerObject},+ HsJSONPB._schemaProperties =+ HsJSONPB.insOrdFromList+ [("nestedField1",+ withNesting_NestedNestedField1),+ ("nestedField2",+ withNesting_NestedNestedField2)]}})+ +instance HsDhallPb.Interpret WithNesting_Nested+ +instance HsDhallPb.Inject WithNesting_Nested
+ gen/TestProtoOneof.hs view
@@ -0,0 +1,835 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE GADTs #-}+{-# 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!+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.JSONPB as HsJSONPB+import Proto3.Suite.JSONPB ((.=), (.:))+import qualified Proto3.Wire as HsProtobuf+import Control.Applicative ((<*>), (<|>), (<$>))+import qualified Control.Applicative 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.String as Hs (fromString)+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 TestProtoOneofImport+ +data DummyMsg = DummyMsg{dummyMsgDummy :: Hs.Int32}+ deriving (Hs.Show, Hs.Eq, Hs.Ord, Hs.Generic)+ +instance HsProtobuf.Named DummyMsg where+ nameOf _ = (Hs.fromString "DummyMsg")+ +instance HsProtobuf.Message DummyMsg where+ encodeMessage _ DummyMsg{dummyMsgDummy = dummyMsgDummy}+ = (Hs.mconcat+ [(HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 1)+ dummyMsgDummy)])+ decodeMessage _+ = (Hs.pure DummyMsg) <*>+ (HsProtobuf.at HsProtobuf.decodeMessageField+ (HsProtobuf.FieldNumber 1))+ dotProto _+ = [(HsProtobuf.DotProtoField (HsProtobuf.FieldNumber 1)+ (HsProtobuf.Prim HsProtobuf.Int32)+ (HsProtobuf.Single "dummy")+ []+ Hs.Nothing)]+ +instance HsJSONPB.ToJSONPB DummyMsg where+ toJSONPB (DummyMsg f1) = (HsJSONPB.object ["dummy" .= f1])+ toEncodingPB (DummyMsg f1) = (HsJSONPB.pairs ["dummy" .= f1])+ +instance HsJSONPB.FromJSONPB DummyMsg where+ parseJSONPB+ = (HsJSONPB.withObject "DummyMsg"+ (\ obj -> (Hs.pure DummyMsg) <*> obj .: "dummy"))+ +instance HsJSONPB.ToJSON DummyMsg where+ toJSON = HsJSONPB.toAesonValue+ toEncoding = HsJSONPB.toAesonEncoding+ +instance HsJSONPB.FromJSON DummyMsg where+ parseJSON = HsJSONPB.parseJSONPB+ +instance HsJSONPB.ToSchema DummyMsg where+ declareNamedSchema _+ = do let declare_dummy = HsJSONPB.declareSchemaRef+ dummyMsgDummy <- declare_dummy Proxy.Proxy+ let _ = Hs.pure DummyMsg <*> HsJSONPB.asProxy declare_dummy+ Hs.return+ (HsJSONPB.NamedSchema{HsJSONPB._namedSchemaName =+ Hs.Just "DummyMsg",+ HsJSONPB._namedSchemaSchema =+ Hs.mempty{HsJSONPB._schemaParamSchema =+ Hs.mempty{HsJSONPB._paramSchemaType =+ HsJSONPB.SwaggerObject},+ HsJSONPB._schemaProperties =+ 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)+ +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 HsJSONPB.ToJSONPB DummyEnum where+ toJSONPB x _ = HsJSONPB.enumFieldString x+ toEncodingPB x _ = HsJSONPB.enumFieldEncoding x+ +instance HsJSONPB.FromJSONPB DummyEnum where+ parseJSONPB (HsJSONPB.String "DUMMY0") = Hs.pure DummyEnumDUMMY0+ parseJSONPB (HsJSONPB.String "DUMMY1") = Hs.pure DummyEnumDUMMY1+ parseJSONPB v = (HsJSONPB.typeMismatch "DummyEnum" v)+ +instance HsJSONPB.ToJSON DummyEnum where+ toJSON = HsJSONPB.toAesonValue+ toEncoding = HsJSONPB.toAesonEncoding+ +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)+ +instance HsProtobuf.Named Something where+ nameOf _ = (Hs.fromString "Something")+ +instance HsProtobuf.Message Something where+ encodeMessage _+ Something{somethingValue = somethingValue,+ somethingAnother = somethingAnother,+ somethingPickOne = somethingPickOne}+ = (Hs.mconcat+ [(HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 1)+ (HsProtobuf.Signed somethingValue)),+ (HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 2)+ (HsProtobuf.Signed somethingAnother)),+ case somethingPickOne of+ Hs.Nothing -> Hs.mempty+ Hs.Just x+ -> case x of+ SomethingPickOneName y+ -> (HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 4)+ (HsProtobuf.ForceEmit y))+ SomethingPickOneSomeid y+ -> (HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 9)+ (HsProtobuf.ForceEmit y))+ SomethingPickOneDummyMsg1 y+ -> (HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 10)+ (HsProtobuf.Nested (Hs.Just y)))+ SomethingPickOneDummyMsg2 y+ -> (HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 11)+ (HsProtobuf.Nested (Hs.Just y)))+ SomethingPickOneDummyEnum y+ -> (HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 12)+ (HsProtobuf.ForceEmit y))])+ decodeMessage _+ = (Hs.pure Something) <*>+ ((Hs.pure HsProtobuf.signed) <*>+ (HsProtobuf.at HsProtobuf.decodeMessageField+ (HsProtobuf.FieldNumber 1)))+ <*>+ ((Hs.pure HsProtobuf.signed) <*>+ (HsProtobuf.at HsProtobuf.decodeMessageField+ (HsProtobuf.FieldNumber 2)))+ <*>+ (HsProtobuf.oneof Hs.Nothing+ [((HsProtobuf.FieldNumber 4),+ (Hs.pure (Hs.Just Hs.. SomethingPickOneName)) <*>+ HsProtobuf.decodeMessageField),+ ((HsProtobuf.FieldNumber 9),+ (Hs.pure (Hs.Just Hs.. SomethingPickOneSomeid)) <*>+ HsProtobuf.decodeMessageField),+ ((HsProtobuf.FieldNumber 10),+ (Hs.pure (Hs.fmap SomethingPickOneDummyMsg1)) <*>+ ((Hs.pure HsProtobuf.nested) <*> HsProtobuf.decodeMessageField)),+ ((HsProtobuf.FieldNumber 11),+ (Hs.pure (Hs.fmap SomethingPickOneDummyMsg2)) <*>+ ((Hs.pure HsProtobuf.nested) <*> HsProtobuf.decodeMessageField)),+ ((HsProtobuf.FieldNumber 12),+ (Hs.pure (Hs.Just Hs.. SomethingPickOneDummyEnum)) <*>+ HsProtobuf.decodeMessageField)])+ dotProto _+ = [(HsProtobuf.DotProtoField (HsProtobuf.FieldNumber 1)+ (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)+ = (HsJSONPB.object+ ["value" .= f1, "another" .= f2,+ (let encodePickOne+ = (case f4_or_f9_or_f10_or_f11_or_f12 of+ Hs.Just (SomethingPickOneName f4) -> (HsJSONPB.pair "name" f4)+ Hs.Just (SomethingPickOneSomeid f9) -> (HsJSONPB.pair "someid" f9)+ Hs.Just (SomethingPickOneDummyMsg1 f10)+ -> (HsJSONPB.pair "dummyMsg1" f10)+ Hs.Just (SomethingPickOneDummyMsg2 f11)+ -> (HsJSONPB.pair "dummyMsg2" f11)+ Hs.Just (SomethingPickOneDummyEnum f12)+ -> (HsJSONPB.pair "dummyEnum" f12)+ Hs.Nothing -> Hs.mempty)+ in+ \ options ->+ if HsJSONPB.optEmitNamedOneof options then+ ("pickOne" .= (HsJSONPB.objectOrNull [encodePickOne] options))+ options+ else encodePickOne options)])+ toEncodingPB (Something f1 f2 f4_or_f9_or_f10_or_f11_or_f12)+ = (HsJSONPB.pairs+ ["value" .= f1, "another" .= f2,+ (let encodePickOne+ = (case f4_or_f9_or_f10_or_f11_or_f12 of+ Hs.Just (SomethingPickOneName f4) -> (HsJSONPB.pair "name" f4)+ Hs.Just (SomethingPickOneSomeid f9) -> (HsJSONPB.pair "someid" f9)+ Hs.Just (SomethingPickOneDummyMsg1 f10)+ -> (HsJSONPB.pair "dummyMsg1" f10)+ Hs.Just (SomethingPickOneDummyMsg2 f11)+ -> (HsJSONPB.pair "dummyMsg2" f11)+ Hs.Just (SomethingPickOneDummyEnum f12)+ -> (HsJSONPB.pair "dummyEnum" f12)+ Hs.Nothing -> Hs.mempty)+ in+ \ options ->+ if HsJSONPB.optEmitNamedOneof options then+ ("pickOne" .= (HsJSONPB.pairsOrNull [encodePickOne] options))+ options+ else encodePickOne options)])+ +instance HsJSONPB.FromJSONPB Something where+ parseJSONPB+ = (HsJSONPB.withObject "Something"+ (\ obj ->+ (Hs.pure Something) <*> obj .: "value" <*> obj .: "another" <*>+ (let parsePickOne parseObj+ = Hs.msum+ [Hs.Just Hs.. SomethingPickOneName <$>+ (HsJSONPB.parseField parseObj "name"),+ Hs.Just Hs.. SomethingPickOneSomeid <$>+ (HsJSONPB.parseField parseObj "someid"),+ Hs.Just Hs.. SomethingPickOneDummyMsg1 <$>+ (HsJSONPB.parseField parseObj "dummyMsg1"),+ Hs.Just Hs.. SomethingPickOneDummyMsg2 <$>+ (HsJSONPB.parseField parseObj "dummyMsg2"),+ Hs.Just Hs.. SomethingPickOneDummyEnum <$>+ (HsJSONPB.parseField parseObj "dummyEnum"),+ Hs.pure Hs.Nothing]+ in+ ((obj .: "pickOne") Hs.>>=+ (HsJSONPB.withObject "pickOne" parsePickOne))+ <|> (parsePickOne obj))))+ +instance HsJSONPB.ToJSON Something where+ toJSON = HsJSONPB.toAesonValue+ toEncoding = HsJSONPB.toAesonEncoding+ +instance HsJSONPB.FromJSON Something where+ parseJSON = HsJSONPB.parseJSONPB+ +instance HsJSONPB.ToSchema Something where+ declareNamedSchema _+ = do let declare_value = HsJSONPB.declareSchemaRef+ somethingValue <- declare_value Proxy.Proxy+ let declare_another = HsJSONPB.declareSchemaRef+ somethingAnother <- declare_another Proxy.Proxy+ let declare_pickOne = HsJSONPB.declareSchemaRef+ somethingPickOne <- declare_pickOne Proxy.Proxy+ let _ = Hs.pure Something <*> HsJSONPB.asProxy declare_value <*>+ HsJSONPB.asProxy declare_another+ <*> HsJSONPB.asProxy declare_pickOne+ Hs.return+ (HsJSONPB.NamedSchema{HsJSONPB._namedSchemaName =+ Hs.Just "Something",+ HsJSONPB._namedSchemaSchema =+ Hs.mempty{HsJSONPB._schemaParamSchema =+ Hs.mempty{HsJSONPB._paramSchemaType =+ HsJSONPB.SwaggerObject},+ HsJSONPB._schemaProperties =+ HsJSONPB.insOrdFromList+ [("value", somethingValue),+ ("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)+ +instance HsProtobuf.Named SomethingPickOne where+ nameOf _ = (Hs.fromString "SomethingPickOne")+ +instance HsJSONPB.ToSchema SomethingPickOne where+ declareNamedSchema _+ = do let declare_name = HsJSONPB.declareSchemaRef+ somethingPickOneName <- declare_name Proxy.Proxy+ let _ = Hs.pure SomethingPickOneName <*>+ HsJSONPB.asProxy declare_name+ let declare_someid = HsJSONPB.declareSchemaRef+ somethingPickOneSomeid <- declare_someid Proxy.Proxy+ let _ = Hs.pure SomethingPickOneSomeid <*>+ HsJSONPB.asProxy declare_someid+ let declare_dummyMsg1 = HsJSONPB.declareSchemaRef+ somethingPickOneDummyMsg1 <- declare_dummyMsg1 Proxy.Proxy+ let _ = Hs.pure SomethingPickOneDummyMsg1 <*>+ HsJSONPB.asProxy declare_dummyMsg1+ let declare_dummyMsg2 = HsJSONPB.declareSchemaRef+ somethingPickOneDummyMsg2 <- declare_dummyMsg2 Proxy.Proxy+ let _ = Hs.pure SomethingPickOneDummyMsg2 <*>+ HsJSONPB.asProxy declare_dummyMsg2+ let declare_dummyEnum = HsJSONPB.declareSchemaRef+ somethingPickOneDummyEnum <- declare_dummyEnum Proxy.Proxy+ let _ = Hs.pure SomethingPickOneDummyEnum <*>+ HsJSONPB.asProxy declare_dummyEnum+ Hs.return+ (HsJSONPB.NamedSchema{HsJSONPB._namedSchemaName =+ Hs.Just "SomethingPickOne",+ HsJSONPB._namedSchemaSchema =+ Hs.mempty{HsJSONPB._schemaParamSchema =+ Hs.mempty{HsJSONPB._paramSchemaType =+ HsJSONPB.SwaggerObject},+ HsJSONPB._schemaProperties =+ HsJSONPB.insOrdFromList+ [("name", somethingPickOneName),+ ("someid", somethingPickOneSomeid),+ ("dummyMsg1", somethingPickOneDummyMsg1),+ ("dummyMsg2", somethingPickOneDummyMsg2),+ ("dummyEnum", somethingPickOneDummyEnum)],+ 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)+ +instance HsProtobuf.Named OneofFirst where+ nameOf _ = (Hs.fromString "OneofFirst")+ +instance HsProtobuf.Message OneofFirst where+ encodeMessage _+ OneofFirst{oneofFirstFirst = oneofFirstFirst,+ oneofFirstLast = oneofFirstLast}+ = (Hs.mconcat+ [case oneofFirstFirst of+ Hs.Nothing -> Hs.mempty+ Hs.Just x+ -> case x of+ OneofFirstFirstChoice1 y+ -> (HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 1)+ (HsProtobuf.ForceEmit y))+ OneofFirstFirstChoice2 y+ -> (HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 2)+ (HsProtobuf.ForceEmit y)),+ (HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 3)+ oneofFirstLast)])+ decodeMessage _+ = (Hs.pure OneofFirst) <*>+ (HsProtobuf.oneof Hs.Nothing+ [((HsProtobuf.FieldNumber 1),+ (Hs.pure (Hs.Just Hs.. OneofFirstFirstChoice1)) <*>+ HsProtobuf.decodeMessageField),+ ((HsProtobuf.FieldNumber 2),+ (Hs.pure (Hs.Just Hs.. OneofFirstFirstChoice2)) <*>+ HsProtobuf.decodeMessageField)])+ <*>+ (HsProtobuf.at HsProtobuf.decodeMessageField+ (HsProtobuf.FieldNumber 3))+ dotProto _+ = [(HsProtobuf.DotProtoField (HsProtobuf.FieldNumber 3)+ (HsProtobuf.Prim HsProtobuf.Int32)+ (HsProtobuf.Single "last")+ []+ Hs.Nothing)]+ +instance HsJSONPB.ToJSONPB OneofFirst where+ toJSONPB (OneofFirst f1_or_f2 f3)+ = (HsJSONPB.object+ [(let encodeFirst+ = (case f1_or_f2 of+ Hs.Just (OneofFirstFirstChoice1 f1) -> (HsJSONPB.pair "choice1" f1)+ Hs.Just (OneofFirstFirstChoice2 f2) -> (HsJSONPB.pair "choice2" f2)+ Hs.Nothing -> Hs.mempty)+ in+ \ options ->+ if HsJSONPB.optEmitNamedOneof options then+ ("first" .= (HsJSONPB.objectOrNull [encodeFirst] options)) options+ else encodeFirst options),+ "last" .= f3])+ toEncodingPB (OneofFirst f1_or_f2 f3)+ = (HsJSONPB.pairs+ [(let encodeFirst+ = (case f1_or_f2 of+ Hs.Just (OneofFirstFirstChoice1 f1) -> (HsJSONPB.pair "choice1" f1)+ Hs.Just (OneofFirstFirstChoice2 f2) -> (HsJSONPB.pair "choice2" f2)+ Hs.Nothing -> Hs.mempty)+ in+ \ options ->+ if HsJSONPB.optEmitNamedOneof options then+ ("first" .= (HsJSONPB.pairsOrNull [encodeFirst] options)) options+ else encodeFirst options),+ "last" .= f3])+ +instance HsJSONPB.FromJSONPB OneofFirst where+ parseJSONPB+ = (HsJSONPB.withObject "OneofFirst"+ (\ obj ->+ (Hs.pure OneofFirst) <*>+ (let parseFirst parseObj+ = Hs.msum+ [Hs.Just Hs.. OneofFirstFirstChoice1 <$>+ (HsJSONPB.parseField parseObj "choice1"),+ Hs.Just Hs.. OneofFirstFirstChoice2 <$>+ (HsJSONPB.parseField parseObj "choice2"),+ Hs.pure Hs.Nothing]+ in+ ((obj .: "first") Hs.>>= (HsJSONPB.withObject "first" parseFirst))+ <|> (parseFirst obj))+ <*> obj .: "last"))+ +instance HsJSONPB.ToJSON OneofFirst where+ toJSON = HsJSONPB.toAesonValue+ toEncoding = HsJSONPB.toAesonEncoding+ +instance HsJSONPB.FromJSON OneofFirst where+ parseJSON = HsJSONPB.parseJSONPB+ +instance HsJSONPB.ToSchema OneofFirst where+ declareNamedSchema _+ = do let declare_first = HsJSONPB.declareSchemaRef+ oneofFirstFirst <- declare_first Proxy.Proxy+ let declare_last = HsJSONPB.declareSchemaRef+ oneofFirstLast <- declare_last Proxy.Proxy+ let _ = Hs.pure OneofFirst <*> HsJSONPB.asProxy declare_first <*>+ HsJSONPB.asProxy declare_last+ Hs.return+ (HsJSONPB.NamedSchema{HsJSONPB._namedSchemaName =+ Hs.Just "OneofFirst",+ HsJSONPB._namedSchemaSchema =+ Hs.mempty{HsJSONPB._schemaParamSchema =+ Hs.mempty{HsJSONPB._paramSchemaType =+ HsJSONPB.SwaggerObject},+ HsJSONPB._schemaProperties =+ HsJSONPB.insOrdFromList+ [("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)+ +instance HsProtobuf.Named OneofFirstFirst where+ nameOf _ = (Hs.fromString "OneofFirstFirst")+ +instance HsJSONPB.ToSchema OneofFirstFirst where+ declareNamedSchema _+ = do let declare_choice1 = HsJSONPB.declareSchemaRef+ oneofFirstFirstChoice1 <- declare_choice1 Proxy.Proxy+ let _ = Hs.pure OneofFirstFirstChoice1 <*>+ HsJSONPB.asProxy declare_choice1+ let declare_choice2 = HsJSONPB.declareSchemaRef+ oneofFirstFirstChoice2 <- declare_choice2 Proxy.Proxy+ let _ = Hs.pure OneofFirstFirstChoice2 <*>+ HsJSONPB.asProxy declare_choice2+ Hs.return+ (HsJSONPB.NamedSchema{HsJSONPB._namedSchemaName =+ Hs.Just "OneofFirstFirst",+ HsJSONPB._namedSchemaSchema =+ Hs.mempty{HsJSONPB._schemaParamSchema =+ Hs.mempty{HsJSONPB._paramSchemaType =+ HsJSONPB.SwaggerObject},+ HsJSONPB._schemaProperties =+ HsJSONPB.insOrdFromList+ [("choice1", oneofFirstFirstChoice1),+ ("choice2", oneofFirstFirstChoice2)],+ 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)+ +instance HsProtobuf.Named OneofMiddle where+ nameOf _ = (Hs.fromString "OneofMiddle")+ +instance HsProtobuf.Message OneofMiddle where+ encodeMessage _+ OneofMiddle{oneofMiddleFirst = oneofMiddleFirst,+ oneofMiddleMiddle = oneofMiddleMiddle,+ oneofMiddleLast = oneofMiddleLast}+ = (Hs.mconcat+ [(HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 1)+ oneofMiddleFirst),+ case oneofMiddleMiddle of+ Hs.Nothing -> Hs.mempty+ Hs.Just x+ -> case x of+ OneofMiddleMiddleChoice1 y+ -> (HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 2)+ (HsProtobuf.ForceEmit y))+ OneofMiddleMiddleChoice2 y+ -> (HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 3)+ (HsProtobuf.ForceEmit y)),+ (HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 4)+ oneofMiddleLast)])+ decodeMessage _+ = (Hs.pure OneofMiddle) <*>+ (HsProtobuf.at HsProtobuf.decodeMessageField+ (HsProtobuf.FieldNumber 1))+ <*>+ (HsProtobuf.oneof Hs.Nothing+ [((HsProtobuf.FieldNumber 2),+ (Hs.pure (Hs.Just Hs.. OneofMiddleMiddleChoice1)) <*>+ HsProtobuf.decodeMessageField),+ ((HsProtobuf.FieldNumber 3),+ (Hs.pure (Hs.Just Hs.. OneofMiddleMiddleChoice2)) <*>+ HsProtobuf.decodeMessageField)])+ <*>+ (HsProtobuf.at HsProtobuf.decodeMessageField+ (HsProtobuf.FieldNumber 4))+ dotProto _+ = [(HsProtobuf.DotProtoField (HsProtobuf.FieldNumber 1)+ (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)+ = (HsJSONPB.object+ ["first" .= f1,+ (let encodeMiddle+ = (case f2_or_f3 of+ Hs.Just (OneofMiddleMiddleChoice1 f2)+ -> (HsJSONPB.pair "choice1" f2)+ Hs.Just (OneofMiddleMiddleChoice2 f3)+ -> (HsJSONPB.pair "choice2" f3)+ Hs.Nothing -> Hs.mempty)+ in+ \ options ->+ if HsJSONPB.optEmitNamedOneof options then+ ("middle" .= (HsJSONPB.objectOrNull [encodeMiddle] options))+ options+ else encodeMiddle options),+ "last" .= f4])+ toEncodingPB (OneofMiddle f1 f2_or_f3 f4)+ = (HsJSONPB.pairs+ ["first" .= f1,+ (let encodeMiddle+ = (case f2_or_f3 of+ Hs.Just (OneofMiddleMiddleChoice1 f2)+ -> (HsJSONPB.pair "choice1" f2)+ Hs.Just (OneofMiddleMiddleChoice2 f3)+ -> (HsJSONPB.pair "choice2" f3)+ Hs.Nothing -> Hs.mempty)+ in+ \ options ->+ if HsJSONPB.optEmitNamedOneof options then+ ("middle" .= (HsJSONPB.pairsOrNull [encodeMiddle] options)) options+ else encodeMiddle options),+ "last" .= f4])+ +instance HsJSONPB.FromJSONPB OneofMiddle where+ parseJSONPB+ = (HsJSONPB.withObject "OneofMiddle"+ (\ obj ->+ (Hs.pure OneofMiddle) <*> obj .: "first" <*>+ (let parseMiddle parseObj+ = Hs.msum+ [Hs.Just Hs.. OneofMiddleMiddleChoice1 <$>+ (HsJSONPB.parseField parseObj "choice1"),+ Hs.Just Hs.. OneofMiddleMiddleChoice2 <$>+ (HsJSONPB.parseField parseObj "choice2"),+ Hs.pure Hs.Nothing]+ in+ ((obj .: "middle") Hs.>>=+ (HsJSONPB.withObject "middle" parseMiddle))+ <|> (parseMiddle obj))+ <*> obj .: "last"))+ +instance HsJSONPB.ToJSON OneofMiddle where+ toJSON = HsJSONPB.toAesonValue+ toEncoding = HsJSONPB.toAesonEncoding+ +instance HsJSONPB.FromJSON OneofMiddle where+ parseJSON = HsJSONPB.parseJSONPB+ +instance HsJSONPB.ToSchema OneofMiddle where+ declareNamedSchema _+ = do let declare_first = HsJSONPB.declareSchemaRef+ oneofMiddleFirst <- declare_first Proxy.Proxy+ let declare_middle = HsJSONPB.declareSchemaRef+ oneofMiddleMiddle <- declare_middle Proxy.Proxy+ let declare_last = HsJSONPB.declareSchemaRef+ oneofMiddleLast <- declare_last Proxy.Proxy+ let _ = Hs.pure OneofMiddle <*> HsJSONPB.asProxy declare_first <*>+ HsJSONPB.asProxy declare_middle+ <*> HsJSONPB.asProxy declare_last+ Hs.return+ (HsJSONPB.NamedSchema{HsJSONPB._namedSchemaName =+ Hs.Just "OneofMiddle",+ HsJSONPB._namedSchemaSchema =+ Hs.mempty{HsJSONPB._schemaParamSchema =+ Hs.mempty{HsJSONPB._paramSchemaType =+ HsJSONPB.SwaggerObject},+ HsJSONPB._schemaProperties =+ HsJSONPB.insOrdFromList+ [("first", oneofMiddleFirst),+ ("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)+ +instance HsProtobuf.Named OneofMiddleMiddle where+ nameOf _ = (Hs.fromString "OneofMiddleMiddle")+ +instance HsJSONPB.ToSchema OneofMiddleMiddle where+ declareNamedSchema _+ = do let declare_choice1 = HsJSONPB.declareSchemaRef+ oneofMiddleMiddleChoice1 <- declare_choice1 Proxy.Proxy+ let _ = Hs.pure OneofMiddleMiddleChoice1 <*>+ HsJSONPB.asProxy declare_choice1+ let declare_choice2 = HsJSONPB.declareSchemaRef+ oneofMiddleMiddleChoice2 <- declare_choice2 Proxy.Proxy+ let _ = Hs.pure OneofMiddleMiddleChoice2 <*>+ HsJSONPB.asProxy declare_choice2+ Hs.return+ (HsJSONPB.NamedSchema{HsJSONPB._namedSchemaName =+ Hs.Just "OneofMiddleMiddle",+ HsJSONPB._namedSchemaSchema =+ Hs.mempty{HsJSONPB._schemaParamSchema =+ Hs.mempty{HsJSONPB._paramSchemaType =+ HsJSONPB.SwaggerObject},+ HsJSONPB._schemaProperties =+ HsJSONPB.insOrdFromList+ [("choice1", oneofMiddleMiddleChoice1),+ ("choice2", oneofMiddleMiddleChoice2)],+ 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)+ +instance HsProtobuf.Named WithImported where+ nameOf _ = (Hs.fromString "WithImported")+ +instance HsProtobuf.Message WithImported where+ encodeMessage _+ WithImported{withImportedPickOne = withImportedPickOne}+ = (Hs.mconcat+ [case withImportedPickOne of+ Hs.Nothing -> Hs.mempty+ Hs.Just x+ -> case x of+ WithImportedPickOneDummyMsg1 y+ -> (HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 1)+ (HsProtobuf.Nested (Hs.Just y)))+ WithImportedPickOneWithOneof y+ -> (HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 2)+ (HsProtobuf.Nested (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)),+ ((HsProtobuf.FieldNumber 2),+ (Hs.pure (Hs.fmap WithImportedPickOneWithOneof)) <*>+ ((Hs.pure HsProtobuf.nested) <*> HsProtobuf.decodeMessageField))])+ dotProto _ = []+ +instance HsJSONPB.ToJSONPB WithImported where+ toJSONPB (WithImported f1_or_f2)+ = (HsJSONPB.object+ [(let encodePickOne+ = (case f1_or_f2 of+ Hs.Just (WithImportedPickOneDummyMsg1 f1)+ -> (HsJSONPB.pair "dummyMsg1" f1)+ Hs.Just (WithImportedPickOneWithOneof f2)+ -> (HsJSONPB.pair "withOneof" f2)+ Hs.Nothing -> Hs.mempty)+ in+ \ options ->+ if HsJSONPB.optEmitNamedOneof options then+ ("pickOne" .= (HsJSONPB.objectOrNull [encodePickOne] options))+ options+ else encodePickOne options)])+ toEncodingPB (WithImported f1_or_f2)+ = (HsJSONPB.pairs+ [(let encodePickOne+ = (case f1_or_f2 of+ Hs.Just (WithImportedPickOneDummyMsg1 f1)+ -> (HsJSONPB.pair "dummyMsg1" f1)+ Hs.Just (WithImportedPickOneWithOneof f2)+ -> (HsJSONPB.pair "withOneof" f2)+ Hs.Nothing -> Hs.mempty)+ in+ \ options ->+ if HsJSONPB.optEmitNamedOneof options then+ ("pickOne" .= (HsJSONPB.pairsOrNull [encodePickOne] options))+ options+ else encodePickOne options)])+ +instance HsJSONPB.FromJSONPB WithImported where+ parseJSONPB+ = (HsJSONPB.withObject "WithImported"+ (\ obj ->+ (Hs.pure WithImported) <*>+ (let parsePickOne parseObj+ = Hs.msum+ [Hs.Just Hs.. WithImportedPickOneDummyMsg1 <$>+ (HsJSONPB.parseField parseObj "dummyMsg1"),+ Hs.Just Hs.. WithImportedPickOneWithOneof <$>+ (HsJSONPB.parseField parseObj "withOneof"),+ Hs.pure Hs.Nothing]+ in+ ((obj .: "pickOne") Hs.>>=+ (HsJSONPB.withObject "pickOne" parsePickOne))+ <|> (parsePickOne obj))))+ +instance HsJSONPB.ToJSON WithImported where+ toJSON = HsJSONPB.toAesonValue+ toEncoding = HsJSONPB.toAesonEncoding+ +instance HsJSONPB.FromJSON WithImported where+ parseJSON = HsJSONPB.parseJSONPB+ +instance HsJSONPB.ToSchema WithImported where+ declareNamedSchema _+ = do let declare_pickOne = HsJSONPB.declareSchemaRef+ withImportedPickOne <- declare_pickOne Proxy.Proxy+ let _ = Hs.pure WithImported <*> HsJSONPB.asProxy declare_pickOne+ Hs.return+ (HsJSONPB.NamedSchema{HsJSONPB._namedSchemaName =+ Hs.Just "WithImported",+ HsJSONPB._namedSchemaSchema =+ Hs.mempty{HsJSONPB._schemaParamSchema =+ Hs.mempty{HsJSONPB._paramSchemaType =+ HsJSONPB.SwaggerObject},+ HsJSONPB._schemaProperties =+ 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)+ +instance HsProtobuf.Named WithImportedPickOne where+ nameOf _ = (Hs.fromString "WithImportedPickOne")+ +instance HsJSONPB.ToSchema WithImportedPickOne where+ declareNamedSchema _+ = do let declare_dummyMsg1 = HsJSONPB.declareSchemaRef+ withImportedPickOneDummyMsg1 <- declare_dummyMsg1 Proxy.Proxy+ let _ = Hs.pure WithImportedPickOneDummyMsg1 <*>+ HsJSONPB.asProxy declare_dummyMsg1+ let declare_withOneof = HsJSONPB.declareSchemaRef+ withImportedPickOneWithOneof <- declare_withOneof Proxy.Proxy+ let _ = Hs.pure WithImportedPickOneWithOneof <*>+ HsJSONPB.asProxy declare_withOneof+ Hs.return+ (HsJSONPB.NamedSchema{HsJSONPB._namedSchemaName =+ Hs.Just "WithImportedPickOne",+ HsJSONPB._namedSchemaSchema =+ Hs.mempty{HsJSONPB._schemaParamSchema =+ Hs.mempty{HsJSONPB._paramSchemaType =+ HsJSONPB.SwaggerObject},+ HsJSONPB._schemaProperties =+ HsJSONPB.insOrdFromList+ [("dummyMsg1", withImportedPickOneDummyMsg1),+ ("withOneof",+ withImportedPickOneWithOneof)],+ HsJSONPB._schemaMinProperties = Hs.Just 1,+ HsJSONPB._schemaMaxProperties = Hs.Just 1}})+ +instance HsDhallPb.Interpret WithImportedPickOne+ +instance HsDhallPb.Inject WithImportedPickOne
+ gen/TestProtoOneofImport.hs view
@@ -0,0 +1,166 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE GADTs #-}+{-# 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!+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.JSONPB as HsJSONPB+import Proto3.Suite.JSONPB ((.=), (.:))+import qualified Proto3.Wire as HsProtobuf+import Control.Applicative ((<*>), (<|>), (<$>))+import qualified Control.Applicative 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.String as Hs (fromString)+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+ +data WithOneof = WithOneof{withOneofPickOne ::+ Hs.Maybe WithOneofPickOne}+ deriving (Hs.Show, Hs.Eq, Hs.Ord, Hs.Generic)+ +instance HsProtobuf.Named WithOneof where+ nameOf _ = (Hs.fromString "WithOneof")+ +instance HsProtobuf.Message WithOneof where+ encodeMessage _ WithOneof{withOneofPickOne = withOneofPickOne}+ = (Hs.mconcat+ [case withOneofPickOne of+ Hs.Nothing -> Hs.mempty+ Hs.Just x+ -> case x of+ WithOneofPickOneA y+ -> (HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 1)+ (HsProtobuf.ForceEmit y))+ WithOneofPickOneB y+ -> (HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 2)+ (HsProtobuf.ForceEmit y))])+ decodeMessage _+ = (Hs.pure WithOneof) <*>+ (HsProtobuf.oneof Hs.Nothing+ [((HsProtobuf.FieldNumber 1),+ (Hs.pure (Hs.Just Hs.. WithOneofPickOneA)) <*>+ HsProtobuf.decodeMessageField),+ ((HsProtobuf.FieldNumber 2),+ (Hs.pure (Hs.Just Hs.. WithOneofPickOneB)) <*>+ HsProtobuf.decodeMessageField)])+ dotProto _ = []+ +instance HsJSONPB.ToJSONPB WithOneof where+ toJSONPB (WithOneof f1_or_f2)+ = (HsJSONPB.object+ [(let encodePickOne+ = (case f1_or_f2 of+ Hs.Just (WithOneofPickOneA f1) -> (HsJSONPB.pair "a" f1)+ Hs.Just (WithOneofPickOneB f2) -> (HsJSONPB.pair "b" f2)+ Hs.Nothing -> Hs.mempty)+ in+ \ options ->+ if HsJSONPB.optEmitNamedOneof options then+ ("pickOne" .= (HsJSONPB.objectOrNull [encodePickOne] options))+ options+ else encodePickOne options)])+ toEncodingPB (WithOneof f1_or_f2)+ = (HsJSONPB.pairs+ [(let encodePickOne+ = (case f1_or_f2 of+ Hs.Just (WithOneofPickOneA f1) -> (HsJSONPB.pair "a" f1)+ Hs.Just (WithOneofPickOneB f2) -> (HsJSONPB.pair "b" f2)+ Hs.Nothing -> Hs.mempty)+ in+ \ options ->+ if HsJSONPB.optEmitNamedOneof options then+ ("pickOne" .= (HsJSONPB.pairsOrNull [encodePickOne] options))+ options+ else encodePickOne options)])+ +instance HsJSONPB.FromJSONPB WithOneof where+ parseJSONPB+ = (HsJSONPB.withObject "WithOneof"+ (\ obj ->+ (Hs.pure WithOneof) <*>+ (let parsePickOne parseObj+ = Hs.msum+ [Hs.Just Hs.. WithOneofPickOneA <$>+ (HsJSONPB.parseField parseObj "a"),+ Hs.Just Hs.. WithOneofPickOneB <$>+ (HsJSONPB.parseField parseObj "b"),+ Hs.pure Hs.Nothing]+ in+ ((obj .: "pickOne") Hs.>>=+ (HsJSONPB.withObject "pickOne" parsePickOne))+ <|> (parsePickOne obj))))+ +instance HsJSONPB.ToJSON WithOneof where+ toJSON = HsJSONPB.toAesonValue+ toEncoding = HsJSONPB.toAesonEncoding+ +instance HsJSONPB.FromJSON WithOneof where+ parseJSON = HsJSONPB.parseJSONPB+ +instance HsJSONPB.ToSchema WithOneof where+ declareNamedSchema _+ = do let declare_pickOne = HsJSONPB.declareSchemaRef+ withOneofPickOne <- declare_pickOne Proxy.Proxy+ let _ = Hs.pure WithOneof <*> HsJSONPB.asProxy declare_pickOne+ Hs.return+ (HsJSONPB.NamedSchema{HsJSONPB._namedSchemaName =+ Hs.Just "WithOneof",+ HsJSONPB._namedSchemaSchema =+ Hs.mempty{HsJSONPB._schemaParamSchema =+ Hs.mempty{HsJSONPB._paramSchemaType =+ HsJSONPB.SwaggerObject},+ HsJSONPB._schemaProperties =+ 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)+ +instance HsProtobuf.Named WithOneofPickOne where+ nameOf _ = (Hs.fromString "WithOneofPickOne")+ +instance HsJSONPB.ToSchema WithOneofPickOne where+ declareNamedSchema _+ = do let declare_a = HsJSONPB.declareSchemaRef+ withOneofPickOneA <- declare_a Proxy.Proxy+ let _ = Hs.pure WithOneofPickOneA <*> HsJSONPB.asProxy declare_a+ let declare_b = HsJSONPB.declareSchemaRef+ withOneofPickOneB <- declare_b Proxy.Proxy+ let _ = Hs.pure WithOneofPickOneB <*> HsJSONPB.asProxy declare_b+ Hs.return+ (HsJSONPB.NamedSchema{HsJSONPB._namedSchemaName =+ Hs.Just "WithOneofPickOne",+ HsJSONPB._namedSchemaSchema =+ Hs.mempty{HsJSONPB._schemaParamSchema =+ Hs.mempty{HsJSONPB._paramSchemaType =+ HsJSONPB.SwaggerObject},+ HsJSONPB._schemaProperties =+ HsJSONPB.insOrdFromList+ [("a", withOneofPickOneA),+ ("b", withOneofPickOneB)],+ HsJSONPB._schemaMinProperties = Hs.Just 1,+ HsJSONPB._schemaMaxProperties = Hs.Just 1}})+ +instance HsDhallPb.Interpret WithOneofPickOne+ +instance HsDhallPb.Inject WithOneofPickOne
+ proto3-suite.cabal view
@@ -0,0 +1,144 @@+name: proto3-suite+version: 0.3.0.0+synopsis: A low level library for writing out data in the Protocol Buffers wire format+license: Apache-2.0+author: Awake Security+maintainer: opensource@awakesecurity.com+copyright: 2017-2018 Awake Security+category: Codec+build-type: Simple+cabal-version: >=1.10+data-files: test-files/*.bin tests/encode.sh tests/decode.sh++Flag dhall+ Description: Turn on Dhall interpret and inject codegen+ Default: False+ Manual: True++library++ if flag(dhall)+ exposed-modules: Proto3.Suite.DhallPB+ build-depends: dhall >=1.13.0 && < 1.22+ cpp-options: -DDHALL++ exposed-modules: Proto3.Suite+ Proto3.Suite.Class+ Proto3.Suite.DotProto+ Proto3.Suite.DotProto.Generate+ Proto3.Suite.DotProto.AST+ Proto3.Suite.DotProto.Parsing+ Proto3.Suite.DotProto.Rendering+ Proto3.Suite.JSONPB+ Proto3.Suite.Tutorial+ Proto3.Suite.Types++ other-modules: Proto3.Suite.DotProto.Internal+ Proto3.Suite.DotProto.Generate.Swagger+ Proto3.Suite.JSONPB.Class+ build-depends: aeson >= 1.1.1.0 && < 1.5,+ aeson-pretty,+ attoparsec >= 0.13.0.1,+ base >=4.8 && <5.0,+ base64-bytestring >= 1.0.0.1 && < 1.1,+ binary >=0.8.3,+ bytestring >=0.10.6.0 && <0.11.0,+ deepseq ==1.4.*,+ cereal >= 0.5.1 && <0.6,+ containers >=0.5 && < 0.7,+ contravariant >=1.4 && <1.6,+ filepath,+ foldl,+ hashable,+ haskell-src ==1.0.*,+ insert-ordered-containers,+ lens,+ mtl ==2.2.*,+ neat-interpolation,+ parsec >= 3.1.9 && <3.2.0,+ parsers >= 0.12 && <0.13,+ pretty ==1.1.*,+ pretty-show >= 1.6.12 && < 2.0,+ proto3-wire == 1.0.*,+ QuickCheck >=2.10 && <2.13,+ quickcheck-instances < 0.4,+ safe ==0.3.*,+ semigroups ==0.18.*,+ swagger2 >=2.1.6 && <2.4,+ system-filepath,+ text >= 0.2 && <1.3,+ transformers >=0.4 && <0.6,+ turtle,+ vector >=0.11 && < 0.13++ hs-source-dirs: src+ default-language: Haskell2010+ ghc-options: -O2 -Wall++test-suite tests+ type: exitcode-stdio-1.0+ main-is: Main.hs++ if flag(dhall)+ other-modules: TestDhall+ build-depends: dhall >=1.13.0 && < 1.22+ cpp-options: -DDHALL++ other-modules: ArbitraryGeneratedTestTypes+ TestProto+ TestCodeGen+ TestProtoImport+ TestProtoOneof+ TestProtoOneofImport++ hs-source-dirs: tests gen+ default-language: Haskell2010+ build-depends: base >=4.8 && <5.0,+ QuickCheck >=2.10 && <2.13,+ aeson >= 1.1.1.0 && < 1.5,+ attoparsec >= 0.13.0.1,+ base >=4.8 && <5.0,+ base64-bytestring >= 1.0.0.1 && < 1.1,+ bytestring >=0.10.6.0 && <0.11.0,+ cereal >= 0.5.1 && <0.6,+ containers >=0.5 && < 0.7,+ doctest,+ pretty-show >= 1.6.12 && < 2.0,+ proto3-suite,+ proto3-wire == 1.0.*,+ semigroups ==0.18.*,+ swagger2,+ tasty >= 0.11 && <1.2,+ tasty-hunit >= 0.9 && <0.11,+ tasty-quickcheck >= 0.8.4 && <0.11,+ text >= 0.2 && <1.3,+ transformers >=0.4 && <0.6,+ turtle,+ vector >=0.11 && < 0.13+ ghc-options: -O2 -Wall++executable compile-proto-file+ main-is: Main.hs+ hs-source-dirs: tools/compile-proto-file+ default-language: Haskell2010+ build-depends: base >=4.8 && <5.0+ , optparse-generic+ , proto3-suite+ , system-filepath+ , text+ , turtle+ ghc-options: -O2 -Wall++executable canonicalize-proto-file+ main-is: Main.hs+ hs-source-dirs: tools/canonicalize-proto-file+ default-language: Haskell2010+ build-depends: base >=4.8 && <5.0+ , containers >=0.5 && <0.7+ , optparse-generic+ , proto3-suite+ , proto3-wire == 1.0.*+ , range-set-list >=0.1.2 && <0.2+ , system-filepath+ , turtle+ ghc-options: -O2 -Wall
+ src/Proto3/Suite.hs view
@@ -0,0 +1,57 @@+-- |+-- = Protocol Buffers v3 for Haskell+--+-- This package defines tools for working with protocol buffers version 3 in+-- Haskell.+--+-- Specifically, it provides:+--+-- * Low-level functions for encoding and decoding messages+-- * Type classes for encoding and decoding messages, and instances for all+-- wire formats identified in the specification+-- * A higher-level approach to encoding and decoding, based on "GHC.Generics"+-- * A way of creating .proto files from Haskell types.+--+-- See the "Proto3.Suite.Tutorial" module for more details.+{-# LANGUAGE ExplicitNamespaces #-}++module Proto3.Suite+ (+ -- * Message Encoding/Decoding+ toLazyByteString+ , fromByteString+ , fromB64+ , Message(..)+ , MessageField(..)+ , Primitive(..)+ , HasDefault(..)+ , FieldNumber(..)+ , fieldNumber++ -- * Documentation+ , message+ , enum+ , RenderingOptions(..)+ , Named(..)+ , Finite(..)++ -- * Wire Formats+ , Fixed(..)+ , Signed(..)+ , Enumerated(..)+ , Nested(..)+ , UnpackedVec(..)+ , PackedVec(..)+ , NestedVec(..)+ , Commented(..)+ , type (//)()++ -- * AST+ , module DotProto+ ) where++import Proto3.Suite.Class+import Proto3.Suite.DotProto as DotProto+import Proto3.Suite.Types++import Proto3.Wire.Types
+ src/Proto3/Suite/Class.hs view
@@ -0,0 +1,739 @@+-- | This module provides type classes for encoding and decoding protocol+-- buffers message, as well as a safer alternative to the raw 'Proto3.Wire'+-- library based on 'GHC.Generics'.+--+-- = Classes+--+-- The 'Primitive' class captures those types which correspond to primitive field+-- types, as defined by the protocol buffers specification. A 'Primitive' type is+-- one which can always be encoded as a single key/value pair in the wire format.+--+-- The 'MessageField' class captures those types which are encoded under a single+-- key in the wire format, i.e. primitives, packed and unpacked lists, and+-- embedded messages.+--+-- The 'Message' class captures types which correspond to protocol buffers messages.+-- Instances of 'Message' can be written by hand for your types by using the+-- functions in the 'Proto3.Suite.Encode' and 'Proto3.Suite.Decode'+-- modules. In the case where the message format is determined by your Haskell code,+-- you might prefer to derive your 'Message' instances using generic deriving.+--+-- = Generic Instances+--+-- Using the 'GHC.Generics' approach, instead of generating Haskell code from a+-- .proto file, we write our message formats as Haskell types, and generate a+-- serializer/deserializer pair.+--+-- To use this library, simply derive a 'Generic' instance for your type(s), and+-- use the default `Message` instance.+--+-- For generic 'Message' instances, field numbers are automatically generated,+-- starting at 1. Therefore, adding new fields is a compatible change only at the+-- end of a record. Renaming fields is also safe. You should not use the generic+-- instances if you are starting from an existing .proto file.+--+-- = Strings+--+-- Use 'TL.Text' instead of 'String' for string types inside messages.+--+-- = Example+--+-- > data MultipleFields =+-- > MultipleFields { multiFieldDouble :: Double+-- > , multiFieldFloat :: Float+-- > , multiFieldInt32 :: Int32+-- > , multiFieldInt64 :: Int64+-- > , multiFieldString :: TL.Text+-- > , multiFieldBool :: Bool+-- > } deriving (Show, Generic, Eq)+-- >+-- > instance Message MultipleFields+-- >+-- > serialized = toLazyByteString $ MultipleFields 1.0 1.0 1 1 "hi" True+-- >+-- > deserialized :: MultipleFields+-- > deserialized = case parse (toStrict serialized) of+-- > Left e -> error e+-- > Right msg -> msg++{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++module Proto3.Suite.Class+ ( Primitive(..)+ , MessageField(..)+ , Message(..)++ -- * Encoding+ , toLazyByteString++ -- * Decoding+ , HasDefault(..)+ , fromByteString+ , fromB64++ -- * Documentation+ , Named(..)+ , Finite(..)+ , message+ , Proto3.Suite.Class.enum++ -- * Generic Classes+ , GenericMessage(..)+ ) where++import Control.Applicative+import Control.Monad+import qualified Data.ByteString as B+import qualified Data.ByteString.Base64 as B64+import qualified Data.ByteString.Lazy as BL+import Data.Coerce (coerce)+import Data.Functor (($>))+import Data.Int (Int32, Int64)+import qualified Data.Map as M+import Data.Maybe (fromMaybe, isNothing)+import Data.Monoid ((<>))+import Data.Proxy (Proxy (..))+import Data.String (IsString (..))+import qualified Data.Text as T+import qualified Data.Text.Lazy as TL+import qualified Data.Traversable as TR+import Data.Vector (Vector)+import Data.Word (Word32, Word64)+import GHC.Exts (fromList, Proxy#, proxy#)+import GHC.Generics+import GHC.TypeLits+import Proto3.Suite.DotProto as DotProto+import Proto3.Suite.Types as Wire+import Proto3.Wire+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++ isDefault :: a -> Bool++ default isDefault :: Eq a => a -> Bool+ isDefault = (== def)++-- | Do not encode the default value+omittingDefault+ :: HasDefault a+ => (a -> Encode.MessageBuilder)+ -> a+ -> Encode.MessageBuilder+omittingDefault f p+ | 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++instance HasDefault Bool where+ def = False++instance HasDefault T.Text where+ def = mempty++instance HasDefault TL.Text where+ def = mempty++instance HasDefault B.ByteString where+ def = mempty++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 HasDefault (UnpackedVec a) where+ def = mempty+ isDefault = null . unpackedvec++instance HasDefault (PackedVec a) where+ def = mempty+ isDefault = null . packedvec++instance HasDefault (NestedVec a) where+ def = mempty+ isDefault = null . nestedvec++instance HasDefault (Nested a) where+ def = Nested Nothing+ isDefault = isNothing . nested++instance (HasDefault a) => HasDefault (ForceEmit a) where+ def = ForceEmit def+ isDefault = isDefault . forceEmit++-- | Used in fields of generated records to represent an unwrapped+-- 'PackedVec'/'UnpackedVec'+instance HasDefault (Vector a) where+ def = mempty+ isDefault = null++-- | Used in generated records to represent an unwrapped 'Nested'+instance HasDefault (Maybe a) where+ def = Nothing+ isDefault = isNothing++instance HasDefault (M.Map k v) where+ 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)++-- | This class captures those types whose names need to appear in .proto files.+--+-- It has a default implementation for any data type which is an instance of the+-- 'Generic' class, which will extract the name of the type constructor.+class Named a where+ -- | Get the name of a type constructor+ nameOf :: IsString string => Proxy# a -> string++ default nameOf :: (IsString string, GenericNamed (Rep a)) => Proxy# a -> string+ nameOf _ = genericNameOf (proxy# :: Proxy# (Rep a))++class GenericNamed (f :: * -> *) where+ genericNameOf :: IsString string => Proxy# f -> string++instance Datatype d => GenericNamed (M1 D d f) where+ genericNameOf _ = fromString (datatypeName (undefined :: M1 D d f ()))++-- | Enumerable types with finitely many values.+--+-- 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+--+-- > map (toEnum . fst) enumerate+--+-- should enumerate all values of the type without runtime errors.+class Enum a => Finite a where+ -- | Enumerate values of a finite type, along with names of constructors.+ enumerate :: IsString string => Proxy# a -> [(string, Int)]++ default enumerate :: (IsString string, GenericFinite (Rep a))+ => Proxy# a -> [(string, Int)]+ enumerate _ = snd (genericEnumerate (proxy# :: Proxy# (Rep a)) 0)++-- | Generate metadata for an enum type.+enum :: (Finite e, Named e) => Proxy# e -> DotProtoDefinition+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)])++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)++instance Constructor c => GenericFinite (M1 C c f) where+ genericEnumerate _ i = (i + 1, [ (fromString name, i) ])+ 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)++-- | This class captures those types which correspond to primitives in+-- the protocol buffers specification.+--+-- It should be possible to fully reconstruct values of these types from+-- a single 'RawPrimitive'. Notably, then, `Nested` is not `Primitive` even+-- though it can be 'embedded', since a nested message may by split up over+-- multiple 'embedded' fields.+class Primitive a where+ -- | Encode a primitive value+ encodePrimitive :: FieldNumber -> a -> Encode.MessageBuilder+ -- | Decode a primitive value+ decodePrimitive :: Parser RawPrimitive a+ -- | Get the type which represents this type inside another message.+ primType :: Proxy# a -> DotProtoPrimType++ default primType :: Named a => Proxy# a -> DotProtoPrimType+ primType pr = Named (Single (nameOf pr))++-- | Serialize a message as a lazy 'BL.ByteString'.+toLazyByteString :: Message a => a -> BL.ByteString+toLazyByteString = Encode.toLazyByteString . encodeMessage (fieldNumber 1)++-- | Parse any message that can be decoded.+fromByteString :: Message a => B.ByteString -> Either ParseError a+fromByteString = Decode.parse (decodeMessage (fieldNumber 1))++-- | As 'fromByteString', except the input bytestring is base64-encoded.+fromB64 :: Message a => B.ByteString -> Either ParseError a+fromB64 = fromByteString . B64.decodeLenient++instance Primitive Int32 where+ encodePrimitive = Encode.int32+ decodePrimitive = Decode.int32+ primType _ = Int32++instance Primitive Int64 where+ encodePrimitive = Encode.int64+ decodePrimitive = Decode.int64+ primType _ = Int64++instance Primitive Word32 where+ encodePrimitive = Encode.uint32+ decodePrimitive = Decode.uint32+ primType _ = UInt32++instance Primitive Word64 where+ encodePrimitive = Encode.uint64+ decodePrimitive = Decode.uint64+ primType _ = UInt64++instance Primitive (Signed Int32) where+ encodePrimitive num = Encode.sint32 num . coerce+ decodePrimitive = coerce Decode.sint32+ primType _ = SInt32++instance Primitive (Signed Int64) where+ encodePrimitive num = Encode.sint64 num . coerce+ decodePrimitive = coerce Decode.sint64+ primType _ = SInt64++instance Primitive (Fixed Word32) where+ encodePrimitive num = Encode.fixed32 num . coerce+ decodePrimitive = coerce Decode.fixed32+ primType _ = DotProto.Fixed32++instance Primitive (Fixed Word64) where+ encodePrimitive num = Encode.fixed64 num . coerce+ decodePrimitive = coerce Decode.fixed64+ primType _ = DotProto.Fixed64++instance Primitive (Signed (Fixed Int32)) where+ encodePrimitive num = Encode.sfixed32 num . coerce+ decodePrimitive = coerce Decode.sfixed32+ primType _ = SFixed32++instance Primitive (Signed (Fixed Int64)) where+ encodePrimitive num = Encode.sfixed64 num . coerce+ decodePrimitive = coerce Decode.sfixed64+ primType _ = SFixed64++instance Primitive Bool where+ encodePrimitive = Encode.enum+ decodePrimitive = Decode.bool+ primType _ = Bool++instance Primitive Float where+ encodePrimitive = Encode.float+ decodePrimitive = Decode.float+ primType _ = Float++instance Primitive Double where+ encodePrimitive = Encode.double+ decodePrimitive = Decode.double+ primType _ = Double++instance Primitive T.Text where+ encodePrimitive fn = Encode.text fn . TL.fromStrict+ decodePrimitive = fmap TL.toStrict Decode.text+ primType _ = String++instance Primitive TL.Text where+ encodePrimitive = Encode.text+ decodePrimitive = Decode.text+ primType _ = String++instance Primitive B.ByteString where+ encodePrimitive = Encode.byteString+ decodePrimitive = Decode.byteString+ primType _ = Bytes++instance Primitive BL.ByteString where+ encodePrimitive = Encode.lazyByteString+ 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+ primType _ = Named (Single (nameOf (proxy# :: Proxy# e)))++instance (Primitive a) => Primitive (ForceEmit a) where+ encodePrimitive num = encodePrimitive num . forceEmit+ decodePrimitive = coerce @(Parser RawPrimitive a) @(Parser RawPrimitive (ForceEmit a)) decodePrimitive+ primType _ = primType (proxy# :: Proxy# a)++-- | This class captures those types which can appear as message fields in+-- the protocol buffers specification, i.e. 'Primitive' types, or lists of+-- 'Primitive' types+class MessageField a where+ -- | Encode a message field+ encodeMessageField :: FieldNumber -> a -> Encode.MessageBuilder+ -- | Decode a message field+ decodeMessageField :: Parser RawField a++ default encodeMessageField :: (HasDefault a, Primitive a)+ => FieldNumber -> a -> Encode.MessageBuilder+ encodeMessageField num x+ | isDefault x = mempty+ | otherwise = encodePrimitive num x++ default decodeMessageField :: (HasDefault a, Primitive a) => Parser RawField a+ decodeMessageField = one decodePrimitive def++ -- | Get the type which represents this type inside another message.+ protoType :: Proxy# a -> DotProtoField+ default protoType :: Primitive a => Proxy# a -> DotProtoField+ protoType p = messageField (Prim $ primType p) Nothing++messageField :: DotProtoType -> Maybe DotProto.Packing -> DotProtoField+messageField ty packing = DotProtoField+ { dotProtoFieldNumber = fieldNumber 1+ , dotProtoFieldType = ty+ , dotProtoFieldName = Anonymous+ , dotProtoFieldOptions = packingOption+ , dotProtoFieldComment = Nothing+ }+ where+ packingOption = maybe [] (toDotProtoOption . isPacked) packing++ toDotProtoOption b = [DotProtoOption (Single "packed") (BoolLit b)]++ isPacked DotProto.PackedField = True+ isPacked DotProto.UnpackedField = False++instance MessageField Int32+instance MessageField Int64+instance MessageField Word32+instance MessageField Word64+instance MessageField (Signed Int32)+instance MessageField (Signed Int64)+instance MessageField (Fixed Word32)+instance MessageField (Fixed Word64)+instance MessageField (Signed (Fixed Int32))+instance MessageField (Signed (Fixed Int64))+instance MessageField Bool+instance MessageField Float+instance MessageField Double+instance MessageField T.Text+instance MessageField TL.Text+instance MessageField B.ByteString+instance MessageField BL.ByteString+instance (Bounded e, Named e, Enum 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++ -- Data.Map.fromList will retain the last key/value mapping. From the spec:+ --+ -- > When parsing from the wire or when merging, if there are duplicate map+ -- > keys the last key seen is used.+ decodeMessageField = M.fromList . fromList+ <$> repeated (Decode.embedded' (decodeMessage (fieldNumber 1)))+ protoType _ = messageField (Map (primType (proxy# :: Proxy# k)) (primType (proxy# :: Proxy# v))) Nothing++instance {-# OVERLAPS #-} (Ord k, Primitive k, Named v, Message v, MessageField k) => MessageField (M.Map k (Nested v)) where+ encodeMessageField num = foldMap (Encode.embedded num . encodeMessage (fieldNumber 1)) . M.toList++ -- Data.Map.fromList will retain the last key/value mapping. From the spec:+ --+ -- > When parsing from the wire or when merging, if there are duplicate map+ -- > keys the last key seen is used.+ decodeMessageField = M.fromList . fromList+ <$> repeated (Decode.embedded' (decodeMessage (fieldNumber 1)))+ protoType _ = messageField (Map (primType (proxy# :: Proxy# k)) (Named . Single $ nameOf (proxy# :: Proxy# v))) Nothing++instance (HasDefault a, Primitive a) => MessageField (ForceEmit a) where+ encodeMessageField = encodePrimitive++instance (Named a, Message a) => MessageField (Nested a) where+ encodeMessageField num = foldMap (Encode.embedded num . encodeMessage (fieldNumber 1))+ . coerce @(Nested a) @(Maybe a)+ decodeMessageField = coerce @(Parser RawField (Maybe a)) @(Parser RawField (Nested a))+ (Decode.embedded (decodeMessage (fieldNumber 1)))+ protoType _ = messageField (Prim . Named . Single $ nameOf (proxy# :: Proxy# a)) Nothing++instance Primitive a => MessageField (UnpackedVec a) where+ encodeMessageField = foldMap . encodePrimitive+ decodeMessageField = UnpackedVec . fromList <$> 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))+ 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+ 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 _ = 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+ protoType _ = messageField (Repeated . Named . Single $ nameOf (proxy# :: Proxy# e)) (Just DotProto.PackedField)++instance MessageField (PackedVec Bool) where+ encodeMessageField fn = omittingDefault (Encode.packedVarints fn) . fmap fromBool+ where+ fromBool False = 0+ fromBool True = 1+ decodeMessageField = fmap (fmap toBool) (decodePacked Decode.packedVarints)+ where+ toBool :: Word64 -> Bool+ toBool 1 = True+ toBool _ = False+ protoType _ = messageField (Repeated Bool) (Just DotProto.PackedField)++instance MessageField (PackedVec Word32) where+ encodeMessageField fn = omittingDefault (Encode.packedVarints fn) . fmap fromIntegral+ decodeMessageField = decodePacked Decode.packedVarints+ protoType _ = messageField (Repeated UInt32) (Just DotProto.PackedField)++instance MessageField (PackedVec Word64) where+ encodeMessageField fn = omittingDefault (Encode.packedVarints fn) . fmap fromIntegral+ decodeMessageField = decodePacked Decode.packedVarints+ protoType _ = messageField (Repeated UInt64) (Just DotProto.PackedField)++instance MessageField (PackedVec Int32) where+ encodeMessageField fn = omittingDefault (Encode.packedVarints fn) . fmap fromIntegral+ decodeMessageField = decodePacked Decode.packedVarints+ protoType _ = messageField (Repeated Int32) (Just DotProto.PackedField)++instance MessageField (PackedVec Int64) where+ encodeMessageField fn = omittingDefault (Encode.packedVarints fn) . fmap fromIntegral+ decodeMessageField = decodePacked Decode.packedVarints+ protoType _ = messageField (Repeated Int64) (Just DotProto.PackedField)++instance MessageField (PackedVec (Fixed Word32)) where+ encodeMessageField fn = omittingDefault (Encode.packedFixed32 fn) . coerce @_ @(PackedVec Word32)+ decodeMessageField = coerce @(Parser RawField (PackedVec Word32))+ @(Parser RawField (PackedVec (Fixed Word32)))+ (decodePacked Decode.packedFixed32)+ protoType _ = messageField (Repeated DotProto.Fixed32) (Just DotProto.PackedField)++instance MessageField (PackedVec (Fixed Word64)) where+ encodeMessageField fn = omittingDefault (Encode.packedFixed64 fn) . coerce @_ @(PackedVec Word64)+ decodeMessageField = coerce @(Parser RawField (PackedVec Word64))+ @(Parser RawField (PackedVec (Fixed Word64)))+ (decodePacked Decode.packedFixed64)+ protoType _ = messageField (Repeated DotProto.Fixed64) (Just DotProto.PackedField)++instance MessageField (PackedVec (Signed (Fixed Int32))) where+ encodeMessageField fn = omittingDefault (Encode.packedFixed32 fn) . fmap (fromIntegral . coerce @_ @Int32)+ decodeMessageField = coerce @(Parser RawField (PackedVec Int32))+ @(Parser RawField (PackedVec (Signed (Fixed Int32))))+ (decodePacked Decode.packedFixed32)+ protoType _ = messageField (Repeated SFixed32) (Just DotProto.PackedField)++instance MessageField (PackedVec (Signed (Fixed Int64))) where+ encodeMessageField fn = omittingDefault (Encode.packedFixed64 fn) . fmap (fromIntegral . coerce @_ @Int64)+ decodeMessageField = coerce @(Parser RawField (PackedVec Int64))+ @(Parser RawField (PackedVec (Signed (Fixed Int64))))+ (decodePacked Decode.packedFixed64)+ protoType _ = messageField (Repeated SFixed64) (Just DotProto.PackedField)++instance MessageField (PackedVec Float) where+ encodeMessageField fn = omittingDefault (Encode.packedFloats fn)+ decodeMessageField = decodePacked Decode.packedFloats+ protoType _ = messageField (Repeated Float) (Just DotProto.PackedField)++instance MessageField (PackedVec Double) where+ encodeMessageField fn = omittingDefault (Encode.packedDoubles fn)+ decodeMessageField = decodePacked Decode.packedDoubles+ protoType _ = messageField (Repeated Double) (Just DotProto.PackedField)++instance (MessageField e, KnownSymbol comments) => MessageField (e // comments) where+ encodeMessageField fn = encodeMessageField fn . unCommented+ decodeMessageField = coerce @(Parser RawField e)+ @(Parser RawField (Commented comments e))+ decodeMessageField+ protoType p = (protoType (lowerProxy1 p))+ { dotProtoFieldComment = Just (symbolVal (lowerProxy2 p)) }+ where+ lowerProxy1 :: forall f (a :: k). Proxy# (f a) -> Proxy# a+ lowerProxy1 _ = proxy#++ lowerProxy2 :: forall f (a :: k) b. Proxy# (f a b) -> Proxy a+ lowerProxy2 _ = Proxy++decodePacked+ :: Parser RawPrimitive [a]+ -> Parser RawField (PackedVec a)+decodePacked = Parser+ . fmap (fmap pack)+ . TR.traverse+ . runParser+ where+ pack :: forall a. [[a]] -> PackedVec a+ pack = fromList . join . reverse+++-- | This class captures those types which correspond to protocol buffer messages.+class Message a where+ -- | Encode a message+ encodeMessage :: FieldNumber -> a -> Encode.MessageBuilder+ -- | Decode a message+ decodeMessage :: FieldNumber -> Parser RawMessage a+ -- | Generate a .proto message from the type information.+ dotProto :: Proxy# a -> [DotProtoField]++ default encodeMessage :: (Generic a, GenericMessage (Rep a))+ => FieldNumber -> a -> Encode.MessageBuilder+ encodeMessage num = genericEncodeMessage num . from++ default decodeMessage :: (Generic a, GenericMessage (Rep a))+ => FieldNumber -> Parser RawMessage a+ decodeMessage = fmap to . genericDecodeMessage++ default dotProto :: GenericMessage (Rep a)+ => Proxy# a -> [DotProtoField]+ dotProto _ = genericDotProto (proxy# :: Proxy# (Rep a))++instance (MessageField k, MessageField v) => Message (k, v)++-- | Generate metadata for a message type.+message :: (Message a, Named a) => Proxy# a -> DotProtoDefinition+message proxy = DotProtoMessage (Single $ nameOf proxy)+ (DotProtoMessageField <$> dotProto proxy)++-- * Generic Instances++class GenericMessage (f :: * -> *) where+ type GenericFieldCount f :: Nat++ genericEncodeMessage :: FieldNumber -> f a -> Encode.MessageBuilder+ genericDecodeMessage :: FieldNumber -> Parser RawMessage (f a)+ genericDotProto :: Proxy# f -> [DotProtoField]++instance GenericMessage U1 where+ type GenericFieldCount U1 = 0+ genericEncodeMessage _ = mempty+ genericDecodeMessage _ = pure U1+ genericDotProto _ = mempty++instance (KnownNat (GenericFieldCount f), GenericMessage f, GenericMessage g)+ => GenericMessage (f :*: g)+ where+ type GenericFieldCount (f :*: g) = GenericFieldCount f + GenericFieldCount g+ genericEncodeMessage num (x :*: y) =+ genericEncodeMessage num x <>+ genericEncodeMessage (FieldNumber (getFieldNumber num + offset)) y+ where+ offset = fromIntegral $ natVal (Proxy @(GenericFieldCount f))++ genericDecodeMessage num =+ liftA2 (:*:) (genericDecodeMessage num)+ (genericDecodeMessage num2)+ where+ num2 = FieldNumber $ getFieldNumber num + offset+ offset = fromIntegral $ natVal (Proxy @(GenericFieldCount f))++ genericDotProto _ =+ genericDotProto (proxy# :: Proxy# f) <>+ adjust (genericDotProto (proxy# :: Proxy# g))+ where+ offset = fromIntegral $ natVal (Proxy @(GenericFieldCount f))+ adjust = map adjustPart+ adjustPart part = part+ { dotProtoFieldNumber = FieldNumber . (offset +)+ . getFieldNumber . dotProtoFieldNumber+ $ part+ }++instance MessageField c => GenericMessage (K1 i c) where+ type GenericFieldCount (K1 i c) = 1+ genericEncodeMessage num (K1 x) = encodeMessageField num x+ genericDecodeMessage num = K1 <$> at decodeMessageField num+ genericDotProto _ = [protoType (proxy# :: Proxy# c)]++instance (Selector s, GenericMessage f) => GenericMessage (M1 S s f) where+ type GenericFieldCount (M1 S s f) = GenericFieldCount f+ genericEncodeMessage num (M1 x) = genericEncodeMessage num x+ genericDecodeMessage num = M1 <$> genericDecodeMessage num+ genericDotProto _ = map applyName $ genericDotProto (proxy# :: Proxy# f)+ where+ applyName :: DotProtoField -> DotProtoField+ applyName mp = mp { dotProtoFieldName = fromMaybe Anonymous newName}+ -- [issue] this probably doesn't match the intended name generating semantics++ newName :: Maybe DotProtoIdentifier+ newName = guard (not (null name)) $> Single name+ where+ name = selName (undefined :: S1 s f ())++instance GenericMessage f => GenericMessage (M1 C t f) where+ type GenericFieldCount (M1 C t f) = GenericFieldCount f+ genericEncodeMessage num (M1 x) = genericEncodeMessage num x+ genericDecodeMessage num = M1 <$> genericDecodeMessage num+ genericDotProto _ = genericDotProto (proxy# :: Proxy# f)++instance GenericMessage f => GenericMessage (M1 D t f) where+ type GenericFieldCount (M1 D t f) = GenericFieldCount f+ genericEncodeMessage num (M1 x) = genericEncodeMessage num x+ genericDecodeMessage num = M1 <$> genericDecodeMessage num+ genericDotProto _ = genericDotProto (proxy# :: Proxy# f)
+ src/Proto3/Suite/DhallPB.hs view
@@ -0,0 +1,177 @@+{-# LANGUAGE FlexibleInstances #-}++{-# OPTIONS_GHC -fno-warn-orphans #-}++module Proto3.Suite.DhallPB+ ( -- * Modules+ module Dhall+ )+where+import Data.Functor.Contravariant (contramap)+import Data.Int (Int32, Int64)+import Data.Word (Word32, Word64)+import Dhall (Inject (..), Interpret (..))+import GHC.Float (double2Float, float2Double)+import Proto3.Suite.Types (Enumerated (..), Fixed (..))++import qualified Data.ByteString+import qualified Data.ByteString.Base64+import qualified Data.ByteString.Base64.Lazy+import qualified Data.ByteString.Lazy+import qualified Data.Map+import qualified Data.Text.Encoding+import qualified Data.Text.Lazy.Encoding+import qualified Dhall++--------------------------------------------------------------------------------+-- Interpret the special 'Enumerated' type++instance Dhall.Interpret a => Dhall.Interpret (Enumerated a)++instance Dhall.Interpret a => Dhall.Interpret (Either Int a)++--------------------------------------------------------------------------------+-- Interpret the strict and lazy ByteString types+--+-- We must base-64 decode a 'ByteString' after encoding it from a Text+-- because it may contain invalid UTF-8 data and Dhall does not have a+-- native type for bytes.++instance Dhall.Interpret Data.ByteString.Lazy.ByteString where+ autoWith _ = fmap b64Decode Dhall.lazyText+ where+ b64Decode = Data.ByteString.Base64.Lazy.decodeLenient . Data.Text.Lazy.Encoding.encodeUtf8++instance Dhall.Interpret Data.ByteString.ByteString where+ autoWith _ = fmap b64Decode Dhall.strictText+ where+ b64Decode = Data.ByteString.Base64.decodeLenient . Data.Text.Encoding.encodeUtf8++--------------------------------------------------------------------------------+-- Interpret integer scalar types++-- Lossy interpretation and integer overflow can happen with the+-- following instances because the 'Dhall.Integer' (Dhall's only+-- integer type) equals Haskell's Integer type. We don't expect these+-- instances to introduce integer overflow because they should only+-- interpret Dhall rendered from protobuf messages created with+-- generated code.+--+-- TODO: we should perform run-time bounds-checking to at least hint+-- to the user that we interpreted something bad.++instance Dhall.Interpret Int where+ autoWith _ = fmap fromInteger Dhall.integer++instance Dhall.Interpret Int32 where+ autoWith _ = fmap fromInteger Dhall.integer++instance Dhall.Interpret Int64 where+ autoWith _ = fmap fromInteger Dhall.integer++instance Dhall.Interpret Word32 where+ autoWith _ = fmap fromIntegral Dhall.integer++instance Dhall.Interpret Word64 where+ autoWith _ = fmap fromIntegral Dhall.integer++instance Dhall.Interpret (Fixed Int32) where+ autoWith = fmap Fixed . Dhall.autoWith++instance Dhall.Interpret (Fixed Int64) where+ autoWith = fmap Fixed . Dhall.autoWith++instance Dhall.Interpret (Fixed Word32) where+ autoWith = fmap Fixed . Dhall.autoWith++instance Dhall.Interpret (Fixed Word64) where+ autoWith = fmap Fixed . Dhall.autoWith++--------------------------------------------------------------------------------+-- Interpret floating point scalar types+--+-- Loss of precision can happen when converting a 'Double' to a+-- 'Float'. We don't expect this instance to introduce loss of+-- precision because it should only interpret Dhall rendered from+-- protobuf messages created with generated code. The Dhall rendering+-- converts from a 'Float' to the 'Dhall.Double' type.++instance Dhall.Interpret Float where+ autoWith _ = fmap double2Float Dhall.double++--------------------------------------------------------------------------------+-- Interpret maps+--+-- Dhall has no map type. We resort to an association list,+-- though that is not safe because keys may be repeated.++instance (Dhall.Interpret k, Dhall.Interpret v, Ord k) =>+ Dhall.Interpret (Data.Map.Map k v) where+ autoWith = fmap (fmap Data.Map.fromList) Dhall.autoWith++--------------------------------------------------------------------------------+-- Inject the special 'Enumerated' type++instance Dhall.Inject a => Dhall.Inject (Enumerated a)++instance Dhall.Inject a => Dhall.Inject (Either Int a)++--------------------------------------------------------------------------------+-- Inject integer scalar types++instance Dhall.Inject Int32 where+ injectWith = fmap (contramap toInteger) Dhall.injectWith++instance Dhall.Inject Int64 where+ injectWith = fmap (contramap toInteger) Dhall.injectWith++instance Dhall.Inject (Fixed Int32) where+ injectWith = fmap (contramap fixed) Dhall.injectWith++instance Dhall.Inject (Fixed Int64) where+ injectWith = fmap (contramap fixed) Dhall.injectWith++instance Dhall.Inject (Fixed Word32) where+ injectWith = fmap (contramap fixed) Dhall.injectWith++instance Dhall.Inject (Fixed Word64) where+ injectWith = fmap (contramap fixed) Dhall.injectWith++--------------------------------------------------------------------------------+-- Inject floating point scalar types++instance Dhall.Inject Float where+ injectWith = fmap (contramap float2Double) Dhall.injectWith++--------------------------------------------------------------------------------+-- Inject strict and lazy ByteStrings+--+-- We must base-64 encode a 'ByteString' before decoding it to a Text+-- because it may contain invalid UTF-8 data and Dhall does not have a+-- native type for bytes.++instance Dhall.Inject Data.ByteString.Lazy.ByteString where+ injectWith = fmap (contramap b64Encode) Dhall.injectWith+ where+ -- 'decodeUtf8' will throw an error on any invalid UTF-8 data+ -- but we should never encounter that case with this usage+ -- because we Base64 encode the ByteString first+ b64Encode = Data.Text.Lazy.Encoding.decodeUtf8 . Data.ByteString.Base64.Lazy.encode++instance Dhall.Inject Data.ByteString.ByteString where+ injectWith = fmap (contramap b64Encode) Dhall.injectWith+ where+ -- 'decodeUtf8' will throw an error on any invalid UTF-8 data+ -- but we should never encounter that case with this usage+ -- because we Base64 encode the ByteString first+ b64Encode = Data.Text.Encoding.decodeUtf8 . Data.ByteString.Base64.encode++--------------------------------------------------------------------------------+-- Inject maps+--+-- Dhall has no map type. We resort to an association list,+-- though that is not safe because keys may be repeated.++instance (Dhall.Inject k, Dhall.Inject v) =>+ Dhall.Inject (Data.Map.Map k v) where+ injectWith = fmap (contramap Data.Map.toAscList) Dhall.injectWith
+ src/Proto3/Suite/DotProto.hs view
@@ -0,0 +1,5 @@+module Proto3.Suite.DotProto (module M) where++import Proto3.Suite.DotProto.AST as M+import Proto3.Suite.DotProto.Parsing as M+import Proto3.Suite.DotProto.Rendering as M
+ src/Proto3/Suite/DotProto/AST.hs view
@@ -0,0 +1,450 @@+-- | Fairly straightforward AST encoding of the .proto grammar++{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE RecordWildCards #-}++module Proto3.Suite.DotProto.AST+ ( -- * Types+ MessageName(..)+ , FieldName(..)+ , PackageName(..)+ , DotProtoIdentifier(..)+ , DotProtoImport(..)+ , DotProtoImportQualifier(..)+ , DotProtoPackageSpec(..)+ , DotProtoOption(..)+ , DotProtoDefinition(..)+ , DotProtoMeta(..)+ , DotProto(..)+ , DotProtoValue(..)+ , DotProtoPrimType(..)+ , Packing(..)+ , Path(..)+ , DotProtoType(..)+ , DotProtoEnumValue+ , DotProtoEnumPart(..)+ , Streaming(..)+ , DotProtoServicePart(..)+ , DotProtoMessagePart(..)+ , DotProtoField(..)+ , DotProtoReservedField(..)+ ) where++import Data.String (IsString)+import qualified Filesystem.Path.CurrentOS as FP+import Numeric.Natural+import Prelude hiding (FilePath)+import Proto3.Wire.Types (FieldNumber (..))+import Test.QuickCheck+import Test.QuickCheck.Instances ()+import Turtle (FilePath)++-- | The name of a message+newtype MessageName = MessageName+ { getMessageName :: String+ } deriving (Eq, Ord, IsString)++instance Show MessageName where+ show = show . getMessageName++-- | The name of some field+newtype FieldName = FieldName+ { getFieldName :: String+ } deriving (Eq, Ord, IsString)++instance Show FieldName where+ show = show . getFieldName++-- | The name of the package+newtype PackageName = PackageName+ { getPackageName :: String+ } deriving (Eq, Ord, IsString)++instance Show PackageName where+ show = show . getPackageName++newtype Path = Path { components :: [String] } deriving (Show, Eq, Ord)++data DotProtoIdentifier+ = Single String+ | Dots Path+ | Qualified DotProtoIdentifier DotProtoIdentifier+ | Anonymous -- [recheck] is there a better way to represent unnamed things+ deriving (Show, Eq, Ord)++-- | Top-level import declaration+data DotProtoImport = DotProtoImport+ { dotProtoImportQualifier :: DotProtoImportQualifier+ , dotProtoImportPath :: FilePath+ } deriving (Show, Eq, Ord)++instance Arbitrary DotProtoImport where+ arbitrary = do+ dotProtoImportQualifier <- arbitrary+ let dotProtoImportPath = FP.empty+ return (DotProtoImport {..})++data DotProtoImportQualifier+ = DotProtoImportPublic+ | DotProtoImportWeak+ | DotProtoImportDefault+ deriving (Show, Eq, Ord)++instance Arbitrary DotProtoImportQualifier where+ arbitrary = elements+ [ DotProtoImportDefault+ , DotProtoImportWeak+ , DotProtoImportPublic+ ]++-- | The namespace declaration+data DotProtoPackageSpec+ = DotProtoPackageSpec DotProtoIdentifier+ | DotProtoNoPackage+ deriving (Show, Eq)++instance Arbitrary DotProtoPackageSpec where+ arbitrary = oneof+ [ return DotProtoNoPackage+ , fmap DotProtoPackageSpec arbitrarySingleIdentifier+ , fmap DotProtoPackageSpec arbitraryPathIdentifier+ ]++-- | An option id/value pair, can be attached to many types of statements+data DotProtoOption = DotProtoOption+ { dotProtoOptionIdentifier :: DotProtoIdentifier+ , dotProtoOptionValue :: DotProtoValue+ } deriving (Show, Eq, Ord)++instance Arbitrary DotProtoOption where+ arbitrary = do+ dotProtoOptionIdentifier <- oneof+ [ arbitraryPathIdentifier+ , arbitraryNestedIdentifier+ ]+ dotProtoOptionValue <- arbitrary+ return (DotProtoOption {..})++-- | Top-level protocol definitions+data DotProtoDefinition+ = DotProtoMessage DotProtoIdentifier [DotProtoMessagePart]+ | DotProtoEnum DotProtoIdentifier [DotProtoEnumPart]+ | DotProtoService DotProtoIdentifier [DotProtoServicePart]+ deriving (Show, Eq)++instance Arbitrary DotProtoDefinition where+ arbitrary = oneof [arbitraryMessage, arbitraryEnum]+ where+ arbitraryMessage = do+ identifier <- arbitrarySingleIdentifier+ parts <- smallListOf arbitrary+ return (DotProtoMessage identifier parts)++ arbitraryEnum = do+ identifier <- arbitrarySingleIdentifier+ parts <- smallListOf arbitrary+ return (DotProtoEnum identifier parts)++-- | Tracks misc metadata about the AST+data DotProtoMeta = DotProtoMeta+ { metaModulePath :: Path+ -- ^ The "module path" associated with the .proto file from which this AST+ -- was parsed. The "module path" is derived from the `--includeDir`-relative+ -- .proto filename passed to 'parseProtoFile'. See+ -- 'Proto3.Suite.DotProto.Internal.toModulePath' for details on how module+ -- path values are constructed. See+ -- 'Proto3.Suite.DotProto.Generate.modulePathModName' to see how it is used+ -- during code generation.+ } deriving (Show, Eq)++instance Arbitrary DotProtoMeta where+ arbitrary = pure . DotProtoMeta . Path $ []++-- | This data structure represents a .proto file+-- The actual source order of protobuf statements isn't meaningful so+-- statements are sorted by type during parsing.+-- A .proto file with more than one package declaration is considered invalid.+data DotProto = DotProto+ { protoImports :: [DotProtoImport]+ , protoOptions :: [DotProtoOption]+ , protoPackage :: DotProtoPackageSpec+ , protoDefinitions :: [DotProtoDefinition]+ , protoMeta :: DotProtoMeta+ } deriving (Show, Eq)++instance Arbitrary DotProto where+ arbitrary = do+ protoImports <- smallListOf arbitrary+ protoOptions <- smallListOf arbitrary+ protoPackage <- arbitrary+ protoDefinitions <- smallListOf arbitrary+ protoMeta <- arbitrary+ return (DotProto {..})++-- | Matches the definition of `constant` in the proto3 language spec+-- These are only used as rvalues+data DotProtoValue+ = Identifier DotProtoIdentifier+ | StringLit String+ | IntLit Int+ | FloatLit Double+ | BoolLit Bool+ deriving (Show, Eq, Ord)++instance Arbitrary DotProtoValue where+ arbitrary = oneof+ [ fmap Identifier arbitrarySingleIdentifier+ , fmap StringLit (return "")+ , fmap IntLit arbitrary+ , fmap FloatLit arbitrary+ , fmap BoolLit arbitrary+ ]++data DotProtoPrimType+ = Int32+ | Int64+ | SInt32+ | SInt64+ | UInt32+ | UInt64+ | Fixed32+ | Fixed64+ | SFixed32+ | SFixed64+ | String+ | Bytes+ | Bool+ | Float+ | Double+ | Named DotProtoIdentifier+ -- ^ A named type, referring to another message or enum defined in the same file+ deriving (Show, Eq)++instance Arbitrary DotProtoPrimType where+ arbitrary = oneof+ [ elements+ [ Int32+ , Int64+ , SInt32+ , SInt64+ , UInt32+ , UInt64+ , Fixed32+ , Fixed64+ , SFixed32+ , SFixed64+ , String+ , Bytes+ , Bool+ , Float+ , Double+ ]+ , fmap Named arbitrarySingleIdentifier+ ]++data Packing+ = PackedField+ | UnpackedField+ deriving (Show, Eq)++instance Arbitrary Packing where+ arbitrary = elements [PackedField, UnpackedField]++-- | This type is an almagamation of the modifiers used in types.+-- It corresponds to a syntax role but not a semantic role, not all modifiers+-- are meaningful in every type context.+data DotProtoType+ = Prim DotProtoPrimType+ | Optional DotProtoPrimType+ | Repeated DotProtoPrimType+ | NestedRepeated DotProtoPrimType+ | Map DotProtoPrimType DotProtoPrimType+ deriving (Show, Eq)++instance Arbitrary DotProtoType where+ arbitrary = oneof [fmap Prim arbitrary]++type DotProtoEnumValue = Int++data DotProtoEnumPart+ = DotProtoEnumField DotProtoIdentifier DotProtoEnumValue [DotProtoOption]+ | DotProtoEnumOption DotProtoOption+ | DotProtoEnumEmpty+ deriving (Show, Eq)++instance Arbitrary DotProtoEnumPart where+ arbitrary = oneof [arbitraryField, arbitraryOption]+ where+ arbitraryField = do+ identifier <- arbitraryIdentifier+ enumValue <- arbitrary+ opts <- arbitrary+ return (DotProtoEnumField identifier enumValue opts)++ arbitraryOption = do+ option <- arbitrary+ return (DotProtoEnumOption option)++data Streaming+ = Streaming+ | NonStreaming+ deriving (Show, Eq)++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]+ | DotProtoServiceOption DotProtoOption+ | DotProtoServiceEmpty+ deriving (Show, Eq)++instance Arbitrary DotProtoServicePart where+ arbitrary = oneof+ [ arbitraryServiceRPC+ , arbitraryServiceOption+ ]+ 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 DotProtoMessagePart+ = DotProtoMessageField DotProtoField+ | DotProtoMessageOneOf+ { dotProtoOneOfName :: DotProtoIdentifier+ , dotProtoOneOfFields :: [DotProtoField]+ }+ | DotProtoMessageDefinition DotProtoDefinition+ | DotProtoMessageReserved [DotProtoReservedField]+ deriving (Show, Eq)++instance Arbitrary DotProtoMessagePart where+ arbitrary = oneof+ [ arbitraryField+ , arbitraryOneOf+ , arbitraryDefinition+ , arbitraryReserved+ ]+ where+ arbitraryField = do+ field <- arbitrary+ return (DotProtoMessageField field)++ arbitraryOneOf = do+ dotProtoOneOfName <- arbitrarySingleIdentifier+ dotProtoOneOfFields <- smallListOf arbitrary+ return (DotProtoMessageOneOf {..})++ arbitraryDefinition = do+ definition <- arbitrary+ return (DotProtoMessageDefinition definition)++ arbitraryReserved = do+ fields <- oneof [smallListOf1 arbitrary, arbitraryReservedLabels]+ return (DotProtoMessageReserved fields)++ arbitraryReservedLabels :: Gen [DotProtoReservedField]+ arbitraryReservedLabels = smallListOf1 (ReservedIdentifier <$> return "")++data DotProtoField = DotProtoField+ { dotProtoFieldNumber :: FieldNumber+ , dotProtoFieldType :: DotProtoType+ , dotProtoFieldName :: DotProtoIdentifier+ , dotProtoFieldOptions :: [DotProtoOption]+ , dotProtoFieldComment :: Maybe String+ }+ | DotProtoEmptyField+ deriving (Show, Eq)++instance Arbitrary DotProtoField where+ arbitrary = do+ dotProtoFieldNumber <- arbitrary+ dotProtoFieldType <- arbitrary+ dotProtoFieldName <- arbitraryIdentifier+ dotProtoFieldOptions <- smallListOf arbitrary+ -- TODO: Generate random comments once the parser supports comments+ dotProtoFieldComment <- pure Nothing+ return (DotProtoField {..})++data DotProtoReservedField+ = SingleField Int+ | FieldRange Int Int+ | ReservedIdentifier String+ deriving (Show, Eq)++instance Arbitrary DotProtoReservedField where+ arbitrary =+ oneof [arbitrarySingleField, arbitraryFieldRange]+ where+ arbitraryFieldNumber = do+ natural <- arbitrary+ return (fromIntegral (natural :: Natural))++ arbitrarySingleField = do+ fieldNumber <- arbitraryFieldNumber+ return (SingleField fieldNumber)++ arbitraryFieldRange = do+ begin <- arbitraryFieldNumber+ end <- arbitraryFieldNumber+ return (FieldRange begin end)++--------------------------------------------------------------------------------+-- | QC Arbitrary instance for generating random protobuf++_arbitraryService :: Gen DotProtoDefinition+_arbitraryService = do+ identifier <- arbitrarySingleIdentifier+ parts <- smallListOf arbitrary+ return (DotProtoService identifier parts)++arbitraryIdentifierName :: Gen String+arbitraryIdentifierName = do+ c <- elements (['a'..'z'] ++ ['A'..'Z'])+ cs <- smallListOf (elements (['a'..'z'] ++ ['A'..'Z'] ++ ['_']))+ return (c:cs)++arbitrarySingleIdentifier :: Gen DotProtoIdentifier+arbitrarySingleIdentifier = fmap Single arbitraryIdentifierName++arbitraryPathIdentifier :: Gen DotProtoIdentifier+arbitraryPathIdentifier = do+ name <- arbitraryIdentifierName+ names <- smallListOf1 arbitraryIdentifierName+ pure . Dots . Path $ name:names++arbitraryNestedIdentifier :: Gen DotProtoIdentifier+arbitraryNestedIdentifier = do+ identifier0 <- arbitraryIdentifier+ identifier1 <- arbitrarySingleIdentifier+ return (Qualified identifier0 identifier1)++-- these two kinds of identifiers are usually interchangeable, the others are not+arbitraryIdentifier :: Gen DotProtoIdentifier+arbitraryIdentifier = oneof [arbitrarySingleIdentifier, arbitraryPathIdentifier]++-- [note] quickcheck's default scaling generates *extremely* large asts past 20 iterations+-- the parser is not particularly slow but it does have noticeable delay on megabyte-large .proto files+smallListOf :: Gen a -> Gen [a]+smallListOf x = choose (0, 5) >>= \n -> vectorOf n x++smallListOf1 :: Gen a -> Gen [a]+smallListOf1 x = choose (1, 5) >>= \n -> vectorOf n x
+ src/Proto3/Suite/DotProto/Generate.hs view
@@ -0,0 +1,2156 @@+{-# 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++-- | For some reason, haskell-src-exts needs this 'SrcLoc' parameter+-- for some data constructors. Its value does not affect+-- pretty-printed output+l :: SrcLoc+l = SrcLoc "<generated>" 0 0++__nowarn_unused :: a+__nowarn_unused = subfieldType `undefined` subfieldOptions `undefined` oneofType
+ src/Proto3/Suite/DotProto/Generate/Swagger.hs view
@@ -0,0 +1,93 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE TypeApplications #-}++{-# OPTIONS_GHC -fno-warn-orphans #-}++-- | This module provides helper functions to generate Swagger schemas that+-- describe JSONPB encodings for protobuf types.+module Proto3.Suite.DotProto.Generate.Swagger+ ( ppSchema+ , OverrideToSchema(..)+ , asProxy+ , insOrdFromList+ )+where++import Control.Lens ((&), (.~), (?~))+import Data.Aeson (Value (String))+import Data.Aeson.Encode.Pretty (encodePretty)+import Data.ByteString (ByteString)+import qualified Data.ByteString.Lazy.Char8 as LC8+import Data.Hashable (Hashable)+import Data.HashMap.Strict.InsOrd (InsOrdHashMap)+import qualified Data.HashMap.Strict.InsOrd+import Data.Swagger+import qualified Data.Text as T+import Data.Proxy+import qualified Data.Vector as V+import GHC.Exts (Proxy#, proxy#)+import GHC.Int+import GHC.Word+import Proto3.Suite (Enumerated (..), Finite (..),+ Fixed (..), Named (..), enumerate)++-- | Convenience re-export so that users of generated code don't have to add+-- an explicit dependency on @insert-ordered-containers@+insOrdFromList :: (Eq k, Hashable k) => [(k, v)] -> InsOrdHashMap k v+insOrdFromList = Data.HashMap.Strict.InsOrd.fromList++{-| This is a hack to work around the `swagger2` library forbidding `ToSchema`+ instances for `ByteString`s+-}+newtype OverrideToSchema a = OverrideToSchema a++instance {-# OVERLAPPABLE #-} ToSchema a => ToSchema (OverrideToSchema a) where+ declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy a)++instance {-# OVERLAPPING #-} ToSchema (OverrideToSchema ByteString) where+ declareNamedSchema _ = return (NamedSchema Nothing byteSchema)++instance {-# OVERLAPPING #-} ToSchema (OverrideToSchema (V.Vector ByteString)) where+ declareNamedSchema _ = return (NamedSchema Nothing schema_)+ where+ schema_ = mempty+ & type_ .~ SwaggerArray+ & items ?~ SwaggerItemsObject (Inline byteSchema)++{-| This is a convenience function that uses type inference to select the+ correct instance of `ToSchema` to use for fields of a message+-}+asProxy :: (Proxy (OverrideToSchema a) -> b) -> Proxy a+asProxy _ = Proxy++-- | Pretty-prints a schema. Useful when playing around with schemas in the+-- REPL.+ppSchema :: ToSchema a => proxy a -> IO ()+ppSchema = LC8.putStrLn . encodePretty . toSchema++-- | JSONPB schemas for protobuf enumerations+instance (Finite e, Named e) => ToSchema (Enumerated e) where+ declareNamedSchema _ = do+ let enumName = nameOf (proxy# :: Proxy# e)+ let dropPrefix = T.drop (T.length enumName)+ let enumMemberNames = dropPrefix . fst <$> enumerate (proxy# :: Proxy# e)+ return $ NamedSchema (Just enumName)+ $ mempty+ & type_ .~ SwaggerString+ & enum_ ?~ fmap String enumMemberNames++instance ToSchema (Fixed Int32) where+ declareNamedSchema _ = declareNamedSchema (Proxy @Int32)++instance ToSchema (Fixed Int64) where+ declareNamedSchema _ = declareNamedSchema (Proxy @Int64)++instance ToSchema (Fixed Word32) where+ declareNamedSchema _ = declareNamedSchema (Proxy @Word32)++instance ToSchema (Fixed Word64) where+ declareNamedSchema _ = declareNamedSchema (Proxy @Word64)
+ src/Proto3/Suite/DotProto/Internal.hs view
@@ -0,0 +1,174 @@+-- | This module provides misc internal helpers and utilities++{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE ViewPatterns #-}++module Proto3.Suite.DotProto.Internal where++import qualified Control.Foldl as FL+import Control.Lens (over)+import Control.Lens.Cons (_head)+import Data.Char (toUpper)+import Data.Maybe (fromMaybe)+import qualified Data.Text as T+import System.FilePath (isPathSeparator)+import qualified Filesystem.Path.CurrentOS as FP+import Filesystem.Path.CurrentOS ((</>))+import qualified NeatInterpolation as Neat+import Prelude hiding (FilePath)+import Proto3.Suite.DotProto+import Text.Parsec (ParseError)+import Turtle (ExitCode (..), FilePath, MonadIO,+ Text)+import qualified Turtle+import Turtle.Format ((%))+import qualified Turtle.Format as F++-- $setup+-- >>> :set -XOverloadedStrings++dieLines :: MonadIO m => Text -> m a+dieLines (Turtle.textToLines -> msg) = do+ mapM_ Turtle.err msg+ Turtle.exit (ExitFailure 1)++-- | toModulePath takes an include-relative path to a .proto file and produces a+-- "module path" which is used during code generation.+--+-- Note that, with the exception of the '.proto' portion of the input filepath,+-- this function interprets '.' in the filename components as if they were+-- additional slashes (assuming that the '.' is not the first character, which+-- is merely ignored). So e.g. "google/protobuf/timestamp.proto" and+-- "google.protobuf.timestamp.proto" map to the same module path.+--+-- >>> toModulePath "/absolute/path/fails.proto"+-- Left "expected include-relative path"+--+-- >>> toModulePath "relative/path/to/file_without_proto_suffix_fails"+-- Left "expected .proto suffix"+--+-- >>> toModulePath "relative/path/to/file_without_proto_suffix_fails.txt"+-- Left "expected .proto suffix"+--+-- >>> toModulePath "../foo.proto"+-- Left "expected include-relative path, but the path started with ../"+--+-- >>> toModulePath "foo..proto"+-- Left "path contained unexpected .. after canonicalization, please use form x.y.z.proto"+--+-- >>> toModulePath "foo/bar/baz..proto"+-- Left "path contained unexpected .. after canonicalization, please use form x.y.z.proto"+--+-- >>> toModulePath "foo.bar../baz.proto"+-- Left "path contained unexpected .. after canonicalization, please use form x.y.z.proto"+--+-- >>> toModulePath "google/protobuf/timestamp.proto"+-- Right (Path {components = ["Google","Protobuf","Timestamp"]})+--+-- >>> toModulePath "a/b/c/google.protobuf.timestamp.proto"+-- 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"]})+--+-- >>> toModulePath "foo/bar/././baz/../boggle.proto"+-- Right (Path {components = ["Foo","Bar","Boggle"]})+--+-- >>> toModulePath "./foo.proto"+-- Right (Path {components = ["Foo"]})+--+-- NB: We ignore preceding single '.' characters+-- >>> toModulePath ".foo.proto"+-- Right (Path {components = ["Foo"]})+toModulePath :: FilePath -> Either String Path+toModulePath fp0@(fromMaybe fp0 . FP.stripPrefix "./" -> fp)+ | Turtle.absolute fp+ = Left "expected include-relative path"+ | Turtle.extension fp /= Just "proto"+ = Left "expected .proto suffix"+ | otherwise+ = 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)+ -> Left "path contained unexpected .. after canonicalization, please use form x.y.z.proto"+ | otherwise+ -> Right+ . Path+ . 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"].+ . fmap (T.unpack . over _head toUpper)+ . concatMap (T.splitOn ".")+ . T.split isPathSeparator+ . Turtle.format F.fp+ . FP.collapse+ . 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 =+ findProto paths protoFP >>= \case+ Found mp fp -> parseProtoFile mp fp+ BadModulePath e -> fatalBadModulePath protoFP e+ NotFound -> dieLines [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)):++ $pathsText+ |]+ where+ pathsText = T.unlines (Turtle.format (" "%F.fp) . (</> protoFP) <$> paths)+ protoFPText = Turtle.format F.fp protoFP++data FindProtoResult+ = Found Path FilePath+ | NotFound+ | BadModulePath String+ deriving (Eq, Show)++-- | 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.++ 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)
+ src/Proto3/Suite/DotProto/Parsing.hs view
@@ -0,0 +1,344 @@+-- | This module contains a near-direct translation of the proto3 grammar+-- It uses String for easier compatibility with DotProto.Generator, which needs it for not very good reasons++{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# OPTIONS_GHC -fno-warn-unused-do-bind #-}++module Proto3.Suite.DotProto.Parsing+ ( parseProto+ , parseProtoFile+ ) where++import Control.Applicative hiding (empty)+import Control.Monad+import Data.Functor+import qualified Data.Text as T+import qualified Filesystem.Path.CurrentOS as FP+import Proto3.Suite.DotProto.AST+import Proto3.Wire.Types (FieldNumber(..))+import Text.Parsec (parse, ParseError)+import Text.Parsec.String (Parser)+import Text.Parser.Char+import Text.Parser.Combinators+import Text.Parser.LookAhead+import Text.Parser.Token+import qualified Text.Parser.Token.Style as TokenStyle+import qualified Turtle++----------------------------------------+-- interfaces++-- | @parseProto mp inp@ attempts to parse @inp@ as a 'DotProto'. @mp@ is the+-- module path to be injected into the AST as part of 'DotProtoMeta' metadata on+-- a successful parse.+parseProto :: Path -> String -> Either ParseError DotProto+parseProto modulePath = parse (runProtoParser (topLevel modulePath)) ""++-- | @parseProtoFile mp fp@ reads and parses the .proto file found at @fp@. @mp@+-- is used downstream during code generation when we need to generate names+-- which are a function of the source .proto file's filename and its path+-- relative to some @--includeDir@.+parseProtoFile :: Turtle.MonadIO m+ => Path -> Turtle.FilePath -> m (Either ParseError DotProto)+parseProtoFile modulePath =+ fmap (parseProto modulePath) . Turtle.liftIO . readFile . FP.encodeString++----------------------------------------+-- convenience++-- | Wrapper around @Text.Parsec.String.Parser@, overriding whitespace lexing.+newtype ProtoParser a = ProtoParser { runProtoParser :: Parser a }+ deriving ( Functor, Applicative, Alternative, Monad, MonadPlus+ , Parsing, CharParsing, LookAheadParsing)++instance TokenParsing ProtoParser where+ someSpace = TokenStyle.buildSomeSpaceParser+ (ProtoParser someSpace)+ TokenStyle.javaCommentStyle+ -- use the default implementation for other methods:+ -- nesting, semi, highlight, token++empty :: ProtoParser ()+empty = textSymbol ";" >> return ()++fieldNumber :: ProtoParser FieldNumber+fieldNumber = FieldNumber . fromInteger <$> integer++----------------------------------------+-- identifiers++identifierName :: ProtoParser String+identifierName = do h <- letter+ t <- many (alphaNum <|> char '_')+ return $ h:t++-- Parses a full identifier, without consuming trailing space.+_identifier :: ProtoParser DotProtoIdentifier+_identifier = do is <- identifierName `sepBy1` string "."+ return $ case is of+ [i] -> Single i+ _ -> Dots (Path is)++singleIdentifier :: ProtoParser DotProtoIdentifier+singleIdentifier = Single <$> token identifierName++-- Parses a full identifier, consuming trailing space.+identifier :: ProtoParser DotProtoIdentifier+identifier = token _identifier++-- [note] message and enum types are defined by the proto3 spec to have an optional leading period (messageType and enumType in the spec)+-- what this indicates is, as far as i can tell, not documented, and i haven't found this syntax used in practice+-- it's ommitted but can be fairly easily added if there is in fact a use for it++-- [update] the leading dot denotes that the identifier path starts in global scope+-- i still haven't seen a use case for this but i can add it upon request++-- Parses a nested identifier, consuming trailing space.+nestedIdentifier :: ProtoParser DotProtoIdentifier+nestedIdentifier = token $ do+ h <- parens _identifier+ string "."+ t <- _identifier+ return $ Qualified h t++----------------------------------------+-- values++-- [issue] these string parsers are weak to \" and \000 octal codes+stringLit :: ProtoParser String+stringLit = stringLiteral <|> stringLiteral'++bool :: ProtoParser Bool+bool = token $ lit "true" True <|> lit "false" False+ where+ -- used to distinguish "true_" (Identifier) from "true" (BoolLit)+ lit s c = string s >> notFollowedBy (alphaNum <|> char '_') >> pure c++-- the `parsers` package actually does not expose a parser for signed fractional values+floatLit :: ProtoParser Double+floatLit = do sign <- char '-' $> negate <|> char '+' $> id <|> pure id+ sign <$> double++value :: ProtoParser DotProtoValue+value = try (BoolLit <$> bool)+ <|> try (StringLit <$> stringLit)+ <|> try (FloatLit <$> floatLit)+ <|> try (IntLit . fromInteger <$> integer)+ <|> try (Identifier <$> identifier)++----------------------------------------+-- types++primType :: ProtoParser DotProtoPrimType+primType = try (symbol "double" $> Double)+ <|> try (symbol "float" $> Float)+ <|> try (symbol "int32" $> Int32)+ <|> try (symbol "int64" $> Int64)+ <|> try (symbol "sint32" $> SInt32)+ <|> try (symbol "sint64" $> SInt64)+ <|> try (symbol "uint32" $> UInt32)+ <|> try (symbol "uint64" $> UInt64)+ <|> try (symbol "fixed32" $> Fixed32)+ <|> try (symbol "fixed64" $> Fixed64)+ <|> try (symbol "sfixed32" $> SFixed32)+ <|> try (symbol "sfixed64" $> SFixed64)+ <|> try (symbol "string" $> String)+ <|> try (symbol "bytes" $> Bytes)+ <|> try (symbol "bool" $> Bool)+ <|> Named <$> identifier++--------------------------------------------------------------------------------+-- top-level parser and version annotation++syntaxSpec :: ProtoParser ()+syntaxSpec = void $ do+ symbol "syntax"+ symbol "="+ symbol "'proto3'" <|> symbol "\"proto3\""+ semi++data DotProtoStatement+ = DPSOption DotProtoOption+ | DPSPackage DotProtoPackageSpec+ | DPSImport DotProtoImport+ | DPSDefinition DotProtoDefinition+ | DPSEmpty+ deriving Show++sortStatements :: Path -> [DotProtoStatement] -> DotProto+sortStatements modulePath statements+ = DotProto { protoOptions = [ x | DPSOption x <- statements]+ , protoImports = [ x | DPSImport x <- statements]+ , protoPackage = adapt [ x | DPSPackage x <- statements]+ , protoDefinitions = [ x | DPSDefinition x <- statements]+ , protoMeta = DotProtoMeta modulePath+ }+ where+ adapt (x:_) = x+ adapt _ = DotProtoNoPackage++topLevel :: Path -> ProtoParser DotProto+topLevel modulePath = do whiteSpace+ syntaxSpec+ sortStatements modulePath <$> many topStatement++--------------------------------------------------------------------------------+-- top-level statements++topStatement :: ProtoParser DotProtoStatement+topStatement = DPSImport <$> import_+ <|> DPSPackage <$> package+ <|> DPSOption <$> topOption+ <|> DPSDefinition <$> definition+ <|> DPSEmpty <$ empty++import_ :: ProtoParser DotProtoImport+import_ = do symbol "import"+ qualifier <- option DotProtoImportDefault $+ symbol "weak" $> DotProtoImportWeak+ <|> symbol "public" $> DotProtoImportPublic+ target <- FP.fromText . T.pack <$> stringLit+ semi+ return $ DotProtoImport qualifier target++package :: ProtoParser DotProtoPackageSpec+package = do symbol "package"+ p <- identifier+ semi+ return $ DotProtoPackageSpec p++definition :: ProtoParser DotProtoDefinition+definition = message+ <|> enum+ <|> service++--------------------------------------------------------------------------------+-- options++inlineOption :: ProtoParser DotProtoOption+inlineOption = DotProtoOption <$> (optionName <* symbol "=") <*> value+ where+ optionName = nestedIdentifier <|> identifier++optionAnnotation :: ProtoParser [DotProtoOption]+optionAnnotation = brackets (commaSep1 inlineOption) <|> pure []++topOption :: ProtoParser DotProtoOption+topOption = symbol "option" *> inlineOption <* semi++--------------------------------------------------------------------------------+-- service statements++servicePart :: ProtoParser DotProtoServicePart+servicePart = rpc+ <|> (DotProtoServiceOption <$> topOption)+ <|> empty $> DotProtoServiceEmpty++rpcOptions :: ProtoParser [DotProtoOption]+rpcOptions = braces $ many topOption++rpcClause :: ProtoParser (DotProtoIdentifier, Streaming)+rpcClause = do+ let sid ctx = (,ctx) <$> identifier+ -- NB: Distinguish "stream stream.foo" from "stream.foo"+ try (symbol "stream" *> sid Streaming) <|> sid NonStreaming++rpc :: ProtoParser DotProtoServicePart+rpc = do symbol "rpc"+ name <- singleIdentifier+ subjecttype <- parens rpcClause+ symbol "returns"+ returntype <- parens rpcClause+ options <- rpcOptions <|> (semi $> [])+ return $ DotProtoServiceRPC name subjecttype returntype options++service :: ProtoParser DotProtoDefinition+service = do symbol "service"+ name <- singleIdentifier+ statements <- braces (many servicePart)+ return $ DotProtoService name statements++--------------------------------------------------------------------------------+-- message definitions++message :: ProtoParser DotProtoDefinition+message = do symbol "message"+ name <- singleIdentifier+ body <- braces (many messagePart)+ return $ DotProtoMessage name body++messageOneOf :: ProtoParser DotProtoMessagePart+messageOneOf = do symbol "oneof"+ name <- singleIdentifier+ body <- braces $ many (messageField <|> empty $> DotProtoEmptyField)+ return $ DotProtoMessageOneOf name body++messagePart :: ProtoParser DotProtoMessagePart+messagePart = try (DotProtoMessageDefinition <$> enum)+ <|> try (DotProtoMessageReserved <$> reservedField)+ <|> try (DotProtoMessageDefinition <$> message)+ <|> try messageOneOf+ <|> try (DotProtoMessageField <$> messageField)++messageType :: ProtoParser DotProtoType+messageType = try mapType <|> try repType <|> (Prim <$> primType)+ where+ mapType = do symbol "map"+ angles $ Map <$> (primType <* comma)+ <*> primType++ repType = do symbol "repeated"+ Repeated <$> primType++messageField :: ProtoParser DotProtoField+messageField = do mtype <- messageType+ mname <- identifier+ symbol "="+ mnumber <- fieldNumber+ moptions <- optionAnnotation+ semi+ return $ DotProtoField mnumber mtype mname moptions Nothing++--------------------------------------------------------------------------------+-- enumerations++enumField :: ProtoParser DotProtoEnumPart+enumField = do fname <- identifier+ symbol "="+ fpos <- fromInteger <$> integer+ opts <- optionAnnotation+ semi+ return $ DotProtoEnumField fname fpos opts+++enumStatement :: ProtoParser DotProtoEnumPart+enumStatement = try (DotProtoEnumOption <$> topOption)+ <|> enumField+ <|> empty $> DotProtoEnumEmpty++enum :: ProtoParser DotProtoDefinition+enum = do symbol "enum"+ ename <- singleIdentifier+ ebody <- braces (many enumStatement)+ return $ DotProtoEnum ename ebody++--------------------------------------------------------------------------------+-- field reservations++range :: ProtoParser DotProtoReservedField+range = do lookAhead (integer >> symbol "to") -- [note] parsec commits to this parser too early without this lookahead+ s <- fromInteger <$> integer+ symbol "to"+ e <- fromInteger <$> integer+ return $ FieldRange s e++ranges :: ProtoParser [DotProtoReservedField]+ranges = commaSep1 (try range <|> (SingleField . fromInteger <$> integer))++reservedField :: ProtoParser [DotProtoReservedField]+reservedField = do symbol "reserved"+ v <- ranges <|> commaSep1 (ReservedIdentifier <$> stringLit)+ semi+ return v
+ src/Proto3/Suite/DotProto/Rendering.hs view
@@ -0,0 +1,221 @@+-- | This module provides types and functions to generate .proto files.++{-# LANGUAGE CPP #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module Proto3.Suite.DotProto.Rendering+ ( renderDotProto+ , defRenderingOptions+ , defSelectorName+ , defEnumMemberName+ , packageFromDefs+ , toProtoFile+ , toProtoFileDef+ , RenderingOptions(..)+ , Pretty(..)+ ) where++import Data.Char+import qualified Data.Text as T+import Filesystem.Path.CurrentOS (toText)+#if (MIN_VERSION_base(4,11,0))+import Prelude hiding ((<>))+#endif+import Proto3.Suite.DotProto.AST+import Proto3.Wire.Types (FieldNumber (..))+import Text.PrettyPrint (($$), (<+>), (<>))+import qualified Text.PrettyPrint as PP+import Text.PrettyPrint.HughesPJClass (Pretty(..))++-- | Options for rendering a @.proto@ file.+data RenderingOptions = RenderingOptions+ { roSelectorName :: DotProtoIdentifier -> DotProtoIdentifier -> FieldNumber -> PP.Doc+ -- ^ This function will be applied to each+ -- record selector name to turn it into a protobuf+ -- field name (default: uses the selector name, unchanged).+ , roEnumMemberName :: DotProtoIdentifier -> DotProtoIdentifier -> PP.Doc+ -- ^ This function will be applied to each+ -- enum member name to turn it into a protobuf+ -- field name (default: uses the field name, unchanged).+ }++-- | Default rendering options.+defRenderingOptions :: RenderingOptions+defRenderingOptions =+ RenderingOptions { roSelectorName = defSelectorName+ , roEnumMemberName = defEnumMemberName+ }++-- | The default choice of field name for a selector.+defSelectorName :: DotProtoIdentifier -> DotProtoIdentifier -> FieldNumber -> PP.Doc+defSelectorName _ fieldName _ = pPrint fieldName++-- | The default choice of enum member name for an enum+defEnumMemberName :: DotProtoIdentifier -> DotProtoIdentifier -> PP.Doc+defEnumMemberName = const pPrint++-- | Traverses a DotProto AST and generates a .proto file from it+renderDotProto :: RenderingOptions -> DotProto -> PP.Doc+renderDotProto opts DotProto{..}+ = PP.text "syntax = \"proto3\";"+ $$ pPrint protoPackage+ $$ (PP.vcat $ pPrint <$> protoImports)+ $$ (PP.vcat $ topOption <$> protoOptions)+ $$ (PP.vcat $ prettyPrintProtoDefinition opts <$> protoDefinitions)++instance Pretty DotProtoPackageSpec where+ pPrint (DotProtoPackageSpec p) = PP.text "package" <+> pPrint p <> PP.text ";"+ pPrint (DotProtoNoPackage) = PP.empty++instance Pretty DotProtoImport where+ pPrint (DotProtoImport q i) =+ PP.text "import" <+> pPrint q <+> PP.text fp <> PP.text ";"+ where+ fp = case T.unpack . either id id . toText $ i of+ [] -> show ("" :: String)+ x -> x++instance Pretty DotProtoImportQualifier where+ pPrint DotProtoImportDefault = PP.empty+ pPrint DotProtoImportPublic = PP.text "public"+ pPrint DotProtoImportWeak = PP.text "weak"++optionAnnotation :: [DotProtoOption] -> PP.Doc+optionAnnotation [] = PP.empty+optionAnnotation os = PP.brackets+ . PP.hcat+ . PP.punctuate (PP.text ", ")+ $ pPrint <$> os++topOption :: DotProtoOption -> PP.Doc+topOption o = PP.text "option" <+> pPrint o <> PP.text ";"++instance Pretty DotProtoOption where+ pPrint (DotProtoOption key value) = pPrint key <+> PP.text "=" <+> pPrint value++prettyPrintProtoDefinition :: RenderingOptions -> DotProtoDefinition -> PP.Doc+prettyPrintProtoDefinition opts = defn where+ defn :: DotProtoDefinition -> PP.Doc+ defn (DotProtoMessage name parts) = PP.text "message" <+> pPrint name <+> (braces $ PP.vcat $ msgPart name <$> parts)+ defn (DotProtoEnum name parts) = PP.text "enum" <+> pPrint name <+> (PP.braces $ PP.vcat $ enumPart name <$> parts)+ defn (DotProtoService name parts) = PP.text "service" <+> pPrint name <+> (PP.braces $ PP.vcat $ pPrint <$> parts)++ -- Put the final closing brace on the next line.+ -- This is important, since the final field might have a comment, and+ -- the brace cannot be part of the comment.+ -- We could use block comments instead, once the parser/lexer supports them.+ braces :: PP.Doc -> PP.Doc+ braces = ($$ PP.text "}") . (PP.text "{" <+>)++ msgPart :: DotProtoIdentifier -> DotProtoMessagePart -> PP.Doc+ msgPart msgName (DotProtoMessageField f) = field msgName f+ msgPart _ (DotProtoMessageDefinition definition) = defn definition+ msgPart _ (DotProtoMessageReserved reservations)+ = PP.text "reserved"+ <+> (PP.hcat . PP.punctuate (PP.text ", ") $ pPrint <$> reservations)+ <> PP.text ";"+ msgPart msgName (DotProtoMessageOneOf name fields) = PP.text "oneof" <+> pPrint name <+> (PP.braces $ PP.vcat $ field msgName <$> fields)++ field :: DotProtoIdentifier -> DotProtoField -> PP.Doc+ field msgName (DotProtoField number mtype name options comments)+ = pPrint mtype+ <+> roSelectorName opts msgName name number+ <+> PP.text "="+ <+> pPrint number+ <+> optionAnnotation options+ <> PP.text ";"+ <> maybe PP.empty (PP.text . (" // " ++)) comments+ field _ DotProtoEmptyField = PP.empty++ enumPart :: DotProtoIdentifier -> DotProtoEnumPart -> PP.Doc+ enumPart msgName (DotProtoEnumField name value options)+ = roEnumMemberName opts msgName name+ <+> PP.text "="+ <+> pPrint value+ <+> optionAnnotation options+ <> PP.text ";"+ enumPart _ (DotProtoEnumOption opt)+ = PP.text "option" <+> pPrint opt <> PP.text ";"+ enumPart _ DotProtoEnumEmpty+ = PP.empty++instance Pretty DotProtoServicePart where+ pPrint (DotProtoServiceRPC name (callname, callstrm) (retname, retstrm) options)+ = PP.text "rpc"+ <+> pPrint name+ <+> PP.parens (pPrint callstrm <+> pPrint callname)+ <+> PP.text "returns"+ <+> PP.parens (pPrint retstrm <+> pPrint retname)+ <+> case options of+ [] -> PP.text ";"+ _ -> PP.braces . PP.vcat $ topOption <$> options+ pPrint (DotProtoServiceOption option) = topOption option+ pPrint DotProtoServiceEmpty = PP.empty++instance Pretty Streaming where+ pPrint Streaming = PP.text "stream"+ pPrint NonStreaming = PP.empty++instance Pretty DotProtoIdentifier where+ pPrint (Single name) = PP.text name+ pPrint (Dots (Path names)) = PP.hcat . PP.punctuate (PP.text ".") $ PP.text <$> names+ pPrint (Qualified qualifier identifier) = PP.parens (pPrint qualifier) <> PP.text "." <> pPrint identifier+ pPrint Anonymous = PP.empty++instance Pretty DotProtoValue where+ pPrint (Identifier value) = pPrint value+ pPrint (StringLit value) = PP.text $ show value+ pPrint (IntLit value) = PP.text $ show value+ pPrint (FloatLit value) = PP.text $ show value+ pPrint (BoolLit value) = PP.text $ toLower <$> show value++instance Pretty DotProtoType where+ pPrint (Prim ty) = pPrint ty+ pPrint (Optional ty) = pPrint ty+ pPrint (Repeated ty) = PP.text "repeated" <+> pPrint ty+ pPrint (NestedRepeated ty) = PP.text "repeated" <+> pPrint ty+ pPrint (Map keyty valuety) = PP.text "map<" <> pPrint keyty <> PP.text ", " <> pPrint valuety <> PP.text ">"++instance Pretty DotProtoPrimType where+ pPrint (Named i) = pPrint i+ pPrint Int32 = PP.text "int32"+ pPrint Int64 = PP.text "int64"+ pPrint SInt32 = PP.text "sint32"+ pPrint SInt64 = PP.text "sint64"+ pPrint UInt32 = PP.text "uint32"+ pPrint UInt64 = PP.text "uint64"+ pPrint Fixed32 = PP.text "fixed32"+ pPrint Fixed64 = PP.text "fixed64"+ pPrint SFixed32 = PP.text "sfixed32"+ pPrint SFixed64 = PP.text "sfixed64"+ pPrint String = PP.text "string"+ pPrint Bytes = PP.text "bytes"+ pPrint Bool = PP.text "bool"+ pPrint Float = PP.text "float"+ pPrint Double = PP.text "double"++instance Pretty FieldNumber where+ pPrint = PP.text . show . getFieldNumber++instance Pretty DotProtoReservedField where+ pPrint (SingleField num) = PP.text $ show num+ pPrint (FieldRange start end) = (PP.text $ show start) <+> PP.text "to" <+> (PP.text $ show end)+ pPrint (ReservedIdentifier i) = PP.text $ show i++-- | Render protobufs metadata as a .proto file stringy+toProtoFile :: RenderingOptions -> DotProto -> String+toProtoFile opts = PP.render . renderDotProto opts++-- | Render protobufs metadata as a .proto file string,+-- using the default rendering options.++toProtoFileDef :: DotProto -> String+toProtoFileDef = toProtoFile defRenderingOptions++packageFromDefs :: String -> [DotProtoDefinition] -> DotProto+packageFromDefs package defs =+ DotProto [] [] (DotProtoPackageSpec $ Single package) defs (DotProtoMeta $ Path [])
+ src/Proto3/Suite/JSONPB.hs view
@@ -0,0 +1,50 @@+module Proto3.Suite.JSONPB+ ( -- * Typeclasses+ FromJSONPB(..)+ , ToJSONPB(..)+ -- * Operators+ , (.:)+ , (.=)+ -- * Options for controlling codec behavior (e.g., emitting default-valued+ -- fields in JSON payloads)+ , Options(..)+ , defaultOptions+ , jsonPBOptions+ -- * JSONPB codec entry points+ , eitherDecode+ , encode+ -- * Helper functions+ , enumFieldEncoding+ , enumFieldString+ , object+ , objectOrNull+ , pair+ , pairs+ , pairsOrNull+ , parseField+ , toAesonEncoding+ , toAesonValue+ -- * Aeson re-exports+ , A.Value(..)+ , A.ToJSON(..)+ , A.FromJSON(..)+ , A.typeMismatch+ , A.withObject+ -- * Swagger schema helpers+ , Swagger.ToSchema(..)+ , Swagger.NamedSchema(..)+ , Swagger.Schema(..)+ , Swagger.ParamSchema(..)+ , Swagger.SwaggerType(..)+ , Swagger.declareSchemaRef+ , Proto3.Suite.DotProto.Generate.Swagger.OverrideToSchema(..)+ , Proto3.Suite.DotProto.Generate.Swagger.asProxy+ , Proto3.Suite.DotProto.Generate.Swagger.insOrdFromList+ )+where++import qualified Data.Aeson as A+import qualified Data.Aeson.Types as A+import qualified Data.Swagger as Swagger+import Proto3.Suite.DotProto.Generate.Swagger+import Proto3.Suite.JSONPB.Class
+ src/Proto3/Suite/JSONPB/Class.hs view
@@ -0,0 +1,522 @@+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE ViewPatterns #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++-- | Support for the "JSONPB" canonical JSON encoding described at+-- https://developers.google.com/protocol-buffers/docs/proto3#json.+--+-- This modules provides 'Data.Aeson'-like helper functions, typeclasses, and+-- instances for converting to and from values of types which have a JSONPB+-- representation and equivalent underlying 'Data.Aeson' representations.+--+-- This module also presents a (very minimal) surface syntax for Aeson-like+-- operations; the idea is that we can write 'ToJSONPB' and 'FromJSONPB'+-- instances in a very similar manner to 'A.ToJSON' and 'A.FromJSON' instances,+-- except that doing so specifies JSONPB codecs instead of vanilla JSON codecs.+--+-- Example use:+--+-- @+-- message Scalar32 {+-- int32 i32 = 1;+-- uint32 u32 = 2;+-- sint32 s32 = 3;+-- fixed32 f32 = 4;+-- sfixed32 sf32 = 5;+-- }+--+-- instance ToJSONPB Scalar32 where+-- toJSONPB (Scalar32 i32 u32 s32 f32 sf32) = object+-- [ "i32" .= i32+-- , "u32" .= u32+-- , "s32" .= s32+-- , "f32" .= f32+-- , "sf32" .= sf32+-- ]+-- toEncodingPB (Scalar32 i32 u32 s32 f32 sf32) = pairs+-- [ "i32" .= i32+-- , "u32" .= u32+-- , "s32" .= s32+-- , "f32" .= f32+-- , "sf32" .= sf32+-- ]+--+-- instance FromJSONPB Scalar32 where+-- parseJSONPB = withObject "Scalar32" $ \obj ->+-- pure Scalar32+-- <*> obj .: "i32"+-- <*> obj .: "u32"+-- <*> obj .: "s32"+-- <*> obj .: "f32"+-- <*> obj .: "sf32"+-- @++module Proto3.Suite.JSONPB.Class where++import qualified Data.Aeson as A (Encoding, FromJSON (..),+ FromJSONKey (..),+ FromJSONKeyFunction (..),+ ToJSON (..), Value (..),+ ToJSON1(..), FromJSON1(..),+ ToJSONKey(..),+ decode, eitherDecode, json,+ (.!=))+import qualified Data.Aeson.Encoding as E+import qualified Data.Aeson.Encoding.Internal as E+import qualified Data.Aeson.Internal as A (formatError, iparse)+import qualified Data.Aeson.Parser as A (eitherDecodeWith)+import qualified Data.Aeson.Types as A (Object, Pair, Parser,+ Series,+ explicitParseField,+ explicitParseFieldMaybe,+ object, typeMismatch)+import qualified Data.Attoparsec.ByteString as Atto (skipWhile)+import qualified Data.Attoparsec.ByteString.Char8 as Atto (Parser, endOfInput)+import qualified Data.Binary.Builder as Builder+import qualified Data.ByteString as BS+import qualified Data.ByteString.Base64 as B64+import qualified Data.ByteString.Lazy as LBS+import Data.Coerce+import Data.Maybe+import qualified Data.Map as M+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import qualified Data.Text.Lazy as TL+import qualified Data.Text.Lazy.Encoding as TL+import qualified Data.Vector as V+import GHC.Exts (Proxy#, proxy#)+import GHC.Int (Int32, Int64)+import GHC.Word (Word32, Word64)+import Proto3.Suite.Class (HasDefault (def, isDefault),+ Named (nameOf))+import Proto3.Suite.Types (Enumerated (..), Fixed (..))++-- * Typeclass definitions++-- | 'A.ToJSON' variant for JSONPB direct encoding via 'A.Encoding'+class ToJSONPB a where+ -- | 'A.toJSON' variant for JSONPB encoders.+ toJSONPB :: a -> Options -> A.Value++ -- | 'A.toEncoding' variant for JSONPB encoders. If an implementation is not+ -- provided, uses 'toJSONPB' (which is less efficient since it indirects+ -- through the 'A.Value' IR).+ toEncodingPB :: a -> Options -> A.Encoding+ toEncodingPB x = A.toEncoding . toJSONPB x++instance ToJSONPB A.Value where+ toJSONPB v _ = v+ toEncodingPB v _ = E.value v++instance ToJSONPB A.Encoding where+ toJSONPB e _ = fromMaybe A.Null . A.decode . Builder.toLazyByteString . E.fromEncoding $ e+ toEncodingPB e _ = e++-- | 'A.FromJSON' variant for JSONPB decoding from the 'A.Value' IR+class FromJSONPB a where+ -- | 'A.parseJSON' variant for JSONPB decoders.+ parseJSONPB :: A.Value -> A.Parser a++instance FromJSONPB A.Value where+ parseJSONPB = pure++-- * JSONPB codec entry points++-- | 'Data.Aeson.encode' variant for serializing a JSONPB value as a lazy+-- 'LBS.ByteString'.+encode :: ToJSONPB a => Options -> a -> LBS.ByteString+encode opts x = E.encodingToLazyByteString (toEncodingPB x opts)+{-# INLINE encode #-}++-- | 'Data.Aeson.eitherDecode' variant for deserializing a JSONPB value from a+-- lazy 'LBS.ByteString'.+eitherDecode :: FromJSONPB a => LBS.ByteString -> Either String a+eitherDecode = eitherFormatError . A.eitherDecodeWith jsonEOF (A.iparse parseJSONPB)+ where+ eitherFormatError = either (Left . uncurry A.formatError) Right+ {-# INLINE eitherFormatError #-}++ -- NB: cribbed from aeson-1.1.1.0:Data.Aeson.Parser.Internal.jsonEOF, which+ -- is not exported. It's simple, so we just inline it here. Might be worth+ -- submitting a PR to export this.+ jsonEOF :: Atto.Parser A.Value+ jsonEOF = A.json <* skipSpace <* Atto.endOfInput+ where+ skipSpace :: Atto.Parser ()+ skipSpace = Atto.skipWhile $ \w -> w == 0x20 || w == 0x0a || w == 0x0d || w == 0x09+ {-# INLINE skipSpace #-}+{-# INLINE eitherDecode #-}++-- * Operator definitions++-- | JSONPB-encoded monoidal key-value pairs+class Monoid m => KeyValuePB m where+ pair :: ToJSONPB v => Text -> v -> Options -> m++instance KeyValuePB A.Series where pair k v opts = E.pair k (toEncodingPB v opts)+instance KeyValuePB [A.Pair] where pair k v opts = pure (k, toJSONPB v opts)++-- | Construct a monoidal key-value pair, using 'mempty' to represent omission+-- of default values (unless the given 'Options' force their emission).+(.=) :: (HasDefault v, ToJSONPB v, KeyValuePB kvp) => Text -> v -> Options -> kvp+k .= v = mk+ where+ mk opts@Options{..}+ | not optEmitDefaultValuedFields && isDefault v+ = mempty+ | otherwise+ = pair k v opts+++-- | 'Data.Aeson..:' variant for JSONPB; if the given key is missing from the+-- object, or if it is present but its value is null, we produce the default+-- protobuf value for the field type+(.:) :: (FromJSONPB a, HasDefault a) => A.Object -> Text -> A.Parser a+obj .: key = obj .:? key A..!= def+ where+ (.:?) = A.explicitParseFieldMaybe parseJSONPB++parseField :: FromJSONPB a+ => A.Object -> Text -> A.Parser a+parseField = A.explicitParseField parseJSONPB++-- | >>> isDefault (def @E.Encoding)+-- True+instance HasDefault E.Encoding where+ def = E.empty+ isDefault = E.nullEncoding++-- | >>> isDefault (def @A.Value)+-- True+instance HasDefault A.Value where+ def = A.Null+ isDefault = (== A.Null)++-- * JSONPB rendering and parsing options++data Options = Options+ { optEmitDefaultValuedFields :: Bool+ , optEmitNamedOneof :: Bool+ -- ^ For compatibility with the Go JSONPB implementation.+ --+ -- If 'False', the following message+ --+ -- > message MyMessage {+ -- > oneof animal {+ -- > Cat cat = 1;+ -- > Dog dog = 2;+ -- > }+ -- > }+ --+ -- will be serialized as+ --+ -- > MyMessage (Animal (Cat "Simba")) => { "cat": "Simba" }+ --+ -- instead of+ --+ -- > MyMessage (Animal (Cat "Simba")) => { "animal": { "cat": "Simba" } }+ --+ } deriving Show++-- | Default options for JSON encoding. By default, all options are @True@.+defaultOptions :: Options+defaultOptions = Options+ { optEmitDefaultValuedFields = True+ , optEmitNamedOneof = True+ }++-- | Options for JSONPB encoding.+jsonPBOptions :: Options+jsonPBOptions = Options+ { optEmitDefaultValuedFields = False+ , optEmitNamedOneof = False+ }++-- * Helper types and functions++dropNamedPrefix :: Named a => Proxy# a -> String -> String+dropNamedPrefix p = drop (length (nameOf p :: String))++object :: [Options -> [A.Pair]] -> Options -> A.Value+object fs = A.object . mconcat fs++-- | As 'object', but produces 'A.Null' when there are no pairs to wrap (cf. the+-- empty object result of 'object)+--+-- >>> object [const []] defaultOptions+-- Object (fromList [])+-- >>> objectOrNull [const []] defaultOptions+-- Null+objectOrNull :: [Options -> [A.Pair]] -> Options -> A.Value+objectOrNull fs options = case mconcat fs options of+ [] -> A.Null+ nonEmpty -> A.object nonEmpty++pairs :: [Options -> A.Series] -> Options -> E.Encoding+pairs fs = E.pairs . mconcat fs++-- | As 'pairs', but produces the "null" when there is no series to encode+-- (cf. the empty object encoding of 'pairs')+--+-- >>> pairs [const mempty] defaultOptions+-- "{}"+-- >>> pairsOrNull [const mempty] defaultOptions+-- "null"+pairsOrNull :: [Options -> A.Series] -> Options -> E.Encoding+pairsOrNull fs options = case mconcat fs options of+ E.Empty -> E.null_+ nonEmpty -> E.pairs nonEmpty++enumFieldString :: forall a. (Named a, Show a) => a -> A.Value+enumFieldString = A.String . T.pack . dropNamedPrefix (proxy# :: Proxy# a) . show++enumFieldEncoding :: forall a. (Named a, Show a) => a -> A.Encoding+enumFieldEncoding = E.string . dropNamedPrefix (proxy# :: Proxy# a) . show++-- | A 'Data.Aeson' 'A.Value' encoder for values which can be+-- JSONPB-encoded.+toAesonValue :: ToJSONPB a => a -> A.Value+toAesonValue = flip toJSONPB defaultOptions++-- | A direct 'A.Encoding' for values which can be JSONPB-encoded.+toAesonEncoding :: ToJSONPB a => a -> A.Encoding+toAesonEncoding = flip toEncodingPB defaultOptions++-- | Parse a JSONPB floating point value; first parameter provides context for+-- type mismatches+parseFP :: (A.FromJSON a, A.FromJSONKey a) => String -> A.Value -> A.Parser a+parseFP tyDesc v = case v of+ A.Number{} -> A.parseJSON v+ A.String t -> case A.fromJSONKey of+ A.FromJSONKeyTextParser p+ -> p t+ _ -> fail "internal: parseKeyPB: unexpected FromJSONKey summand"+ _ -> A.typeMismatch tyDesc v++-- | Liberally parse an integer value (e.g. 42 or "42" as 42); first parameter+-- provides context for type mismatches+parseNumOrDecimalString :: (A.FromJSON a) => String -> A.Value -> A.Parser a+parseNumOrDecimalString tyDesc v = case v of+ A.Number{} -> A.parseJSON v+ A.String t -> either fail pure . A.eitherDecode . TL.encodeUtf8 . TL.fromStrict $ t+ _ -> A.typeMismatch tyDesc v++-- * Common instances for jsonpb codec implementations++-- ** Instances for scalar types++--------------------------------------------------------------------------------+-- Boolean scalar type++instance ToJSONPB Bool where+ toJSONPB = const . A.toJSON+ toEncodingPB = const . A.toEncoding++instance FromJSONPB Bool where+ parseJSONPB = A.parseJSON++--------------------------------------------------------------------------------+-- Integer scalar types+--+-- * 32 bit integer values render to JSON decimal numbers; either numbers or+-- strings are accepted.+--+-- * 64 bit integer values render to JSON decimal strings; either numbers+-- or strings are accepted.+--++-- int32 / sint32+instance ToJSONPB Int32 where+ toJSONPB = const . A.toJSON+ toEncodingPB = const . A.toEncoding++instance FromJSONPB Int32 where+ parseJSONPB = parseNumOrDecimalString "int32 / sint32"++-- uint32+instance ToJSONPB Word32 where+ toJSONPB = const . A.toJSON+ toEncodingPB = const . A.toEncoding++instance FromJSONPB Word32 where+ parseJSONPB = parseNumOrDecimalString "uint32"++-- int64 / sint64+instance ToJSONPB Int64 where+ toJSONPB x _ = A.String . T.pack . show $ x+ toEncodingPB x _ = E.string (show x)+instance FromJSONPB Int64 where+ parseJSONPB = parseNumOrDecimalString "int64 / sint64"++-- unit64+instance ToJSONPB Word64 where+ toJSONPB x _ = A.String . T.pack . show $ x+ toEncodingPB x _ = E.string (show x)+instance FromJSONPB Word64 where+ parseJSONPB = parseNumOrDecimalString "int64 / sint64"++-- fixed32+instance ToJSONPB (Fixed Word32) where+ toJSONPB = coerce (toJSONPB @Word32)+ toEncodingPB = coerce (toEncodingPB @Word32)+instance FromJSONPB (Fixed Word32) where+ parseJSONPB = coerce (parseJSONPB @Word32)++-- fixed64+instance ToJSONPB (Fixed Word64) where+ toJSONPB = coerce (toJSONPB @Word64)+ toEncodingPB = coerce (toEncodingPB @Word64)+instance FromJSONPB (Fixed Word64) where+ parseJSONPB = coerce (parseJSONPB @Word64)++-- sfixed32+instance ToJSONPB (Fixed Int32) where+ toJSONPB = coerce (toJSONPB @Int32)+ toEncodingPB = coerce (toEncodingPB @Int32)+instance FromJSONPB (Fixed Int32) where+ parseJSONPB = coerce (parseJSONPB @Int32)++-- sfixed64+instance ToJSONPB (Fixed Int64) where+ toJSONPB = coerce (toJSONPB @Int64)+ toEncodingPB = coerce (toEncodingPB @Int64)+instance FromJSONPB (Fixed Int64) where+ parseJSONPB = coerce (parseJSONPB @Int64)++--------------------------------------------------------------------------------+-- Floating point scalar types+--+-- JSON value will be a number or one of the special string values "NaN",+-- "Infinity", and "-Infinity". Either numbers or strings are accepted. Exponent+-- notation is also accepted.++-- float+instance ToJSONPB Float where+ toJSONPB = const . A.toJSON+ toEncodingPB = const . A.toEncoding++instance FromJSONPB Float where+ parseJSONPB = parseFP "float"++-- double+instance ToJSONPB Double where+ toJSONPB = const . A.toJSON+ toEncodingPB = const . A.toEncoding+instance FromJSONPB Double where+ parseJSONPB = parseFP "double"++--------------------------------------------------------------------------------+-- Stringly types (string and bytes)++-- string+instance ToJSONPB TL.Text where+ toJSONPB = const . A.toJSON+ toEncodingPB = const . A.toEncoding+instance FromJSONPB TL.Text where+ parseJSONPB = A.parseJSON++-- bytes++bsToJSONPB :: BS.ByteString -> A.Value+bsToJSONPB (T.decodeUtf8' . B64.encode -> ebs) = case ebs of+ Right bs -> A.toJSON bs+ Left e -> error ("internal: failed to encode B64-encoded bytestring: " ++ show e)+ -- NB: T.decodeUtf8' should never fail because we B64-encode the+ -- incoming bytestring.++instance ToJSONPB BS.ByteString where+ toJSONPB bs _ = bsToJSONPB bs+ toEncodingPB bs opts = E.value (toJSONPB bs opts)++instance FromJSONPB BS.ByteString where+ parseJSONPB (A.String b64enc) = pure . B64.decodeLenient . T.encodeUtf8 $ b64enc+ parseJSONPB v = A.typeMismatch "bytes" v++--------------------------------------------------------------------------------+-- Enumerated types++enumToJSONPB :: (e -> Options -> a) -- ^ JSONPB encoder function to use+ -> a -- ^ null value to use for out-of-range enums+ -> Enumerated e -- ^ the enumerated value to encode+ -> Options -- ^ JSONPB encoding options+ -> a -- ^ the JSONPB-encoded value+enumToJSONPB enc null_ (Enumerated e) opts = either err (\input -> enc input opts) e+ where+ err 0 = error "enumToJSONPB: The first enum value must be zero in proto3"+ -- TODO: Raise a compilation error when the first enum value in an+ -- enumeration is not zero.+ --+ -- See https://github.com/awakesecurity/proto3-suite/issues/28+ --+ -- The proto3 spec states that the default value is the first+ -- defined enum value, which must be 0. Since we currently don't+ -- raise a compilation error for this like we should, we have to+ -- handle this case.+ --+ -- For now, die horribly to mimic what should be a compilation+ -- error.+ err _ = null_+ -- From the JSONPB spec:+ --+ -- If a value is missing in the JSON-encoded data or if its value+ -- is null, it will be interpreted as the appropriate default+ -- value when parsed into a protocol buffer.+ --+ -- Thus, interpreting a wire value out of enum range as "missing",+ -- we yield null here to mean the default value.+++instance ToJSONPB e => ToJSONPB (Enumerated e) where+ toJSONPB = enumToJSONPB toJSONPB A.Null+ toEncodingPB = enumToJSONPB toEncodingPB E.null_++instance (Bounded e, Enum e, FromJSONPB e) => FromJSONPB (Enumerated e) where+ parseJSONPB A.Null = pure def -- So CG does not have to handle this case in+ -- every generated instance+ parseJSONPB v = Enumerated . Right <$> parseJSONPB v++-- ** Instances for composite types++--------------------------------------------------------------------------------+-- Instances for repeated messages+--+-- JSON value will be the vector elements encoded as a JSON array. The null+-- value is accepted as the empty list, @[]@.++instance ToJSONPB a => ToJSONPB (V.Vector a) where+ toJSONPB v opts = A.Array (V.map (\x -> toJSONPB x opts) v)+ toEncodingPB v opts = E.list (\x -> toEncodingPB x opts) (V.toList v)+instance FromJSONPB a => FromJSONPB (V.Vector a) where+ parseJSONPB (A.Array vs) = mapM parseJSONPB vs+ parseJSONPB A.Null = pure []+ parseJSONPB v = A.typeMismatch "repeated" v++--------------------------------------------------------------------------------+-- Instances for nested messages++instance ToJSONPB a => ToJSONPB (Maybe a) where+ toJSONPB mx opts = maybe A.Null (\x -> toJSONPB x opts) mx+ toEncodingPB mx opts = maybe E.null_ (\x -> toEncodingPB x opts) mx+instance FromJSONPB a => FromJSONPB (Maybe a) where+ parseJSONPB A.Null = pure Nothing+ parseJSONPB v = fmap Just (parseJSONPB v)++--------------------------------------------------------------------------------+-- Instances for map++instance (A.ToJSONKey k, ToJSONPB k, ToJSONPB v) => ToJSONPB (M.Map k v) where+ toJSONPB m opts = A.liftToJSON @(M.Map k) (`toJSONPB` opts) (A.Array . V.fromList . map (`toJSONPB` opts)) m+ toEncodingPB m opts = A.liftToEncoding @(M.Map k) (`toEncodingPB` opts) (E.list (`toEncodingPB` opts)) m++instance (Ord k, A.FromJSONKey k, FromJSONPB k, FromJSONPB v) => FromJSONPB (M.Map k v) where+ parseJSONPB = A.liftParseJSON @(M.Map k) parseJSONPB parseList+ where+ parseList (A.Array a) = traverse parseJSONPB (V.toList a)+ parseList v = A.typeMismatch "not a list" v
+ src/Proto3/Suite/Tutorial.hs view
@@ -0,0 +1,140 @@+-- |+-- = Tutorial+--+-- >>> :set -XOverloadedStrings+--+-- This module contains a worked example of encoding and decoding messages,+-- and exporting a corresponding .proto file from Haskell types.+--+-- == Setup+--+-- If you are using "GHC.Generics", you should enable the generic deriving+-- extension, and import the main module:+--+-- > {-# LANGUAGE DeriveGeneric #-}+--+-- > import Proto3.Suite+-- > import GHC.Generics+--++{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE OverloadedStrings #-}++module Proto3.Suite.Tutorial where++import Data.Int (Int32)+import Proto3.Suite (Enumerated, Nested, NestedVec, PackedVec,+ Message, Named, Finite,+ DotProtoDefinition, enum, message, packageFromDefs, toProtoFileDef)+import Data.Word (Word32)+import GHC.Exts (Proxy#, proxy#)+import GHC.Generics++-- |+-- == Defining Message Types+--+-- Define messages using Haskell record types. You can use any 'MessageField' types+-- in your records, and the correct serializer and deserializer will be generated+-- for you.+--+-- Make sure to derive a 'Generic' instance for your type, and then derive instances+-- for 'Message' and 'Named' using the default (empty) instances:+--+-- > instance Message Foo+-- > instance Named Foo+--+-- == Encoding Messages+--+-- Now we can encode a value of type 'Foo' using 'Proto3.Suite.toLazyByteString'.+--+-- For example:+--+-- >>> Proto3.Suite.toLazyByteString (Foo 42 (Proto3.Suite.PackedVec (pure 123)))+-- "\b*\DC2\SOH{"+--+-- We can also decode messages using `fromByteString`:+--+-- >>> Proto3.Suite.fromByteString "\b*\DC2\SOH{" :: Either [Proto3.Suite..Decode.Parser.ParseError] Foo+-- Right (Foo {fooX = 42, fooY = PackedVec {packedvec = [123]}})+data Foo = Foo+ { fooX :: Word32+ , fooY :: PackedVec Int32+ } deriving (Show, Eq, Generic)++instance Message Foo+instance Named Foo++-- |+-- == Nested Messages+--+-- Messages can contain other messages, by using the 'Nested' constructor, and+-- lists of nested messages using the 'NestedVec constructor'.+data Bar = Bar+ { barShape :: Enumerated Shape+ , barFoo :: Nested Foo+ , foos :: NestedVec Foo+ }+ deriving (Eq, Generic)++instance Message Bar+instance Named Bar++-- |+-- == Enumerations+--+-- Enumerated types can be used by deriving the 'Enum', 'Finite' and 'Named'+-- classes. Each of these instances are implied by a 'Generic' instance, so can+-- be derived as follows:+--+-- > data Shape+-- > = Circle+-- > | Square+-- > | Triangle+-- > deriving (Generic, Enum, Finite, Named)+data Shape+ = Circle+ | Square+ | Triangle+ deriving (Bounded, Eq, Enum, Finite, Generic, Named, Ord)++-- |+-- == Generating a .proto file+--+-- We can generate a .proto file for the 'Foo' and 'Bar' data types by+-- using the 'toProtoFileDef' function. We have to provide a package name, and+-- explicitly list the message and enumeration types as a 'DotProto' value.+--+-- >>> putStrLn protoFile+-- syntax = "proto3";+-- package examplePackageName;+-- enum Shape {+-- Circle = 0;+-- Square = 1;+-- Triangle = 2;+-- }+-- message Foo {+-- uint32 fooX = 1;+-- repeated int32 fooY = 2 [packed=true];+-- }+-- message Bar {+-- Shape barShape = 1;+-- Foo barFoo = 2;+-- repeated Foo foos = 3 [packed=false];+-- }++protoFile :: String+protoFile = toProtoFileDef $ packageFromDefs "examplePackageName"+ ([ enum (proxy# :: Proxy# Shape)+ , message (proxy# :: Proxy# Foo)+ , message (proxy# :: Proxy# Bar)+ ] :: [DotProtoDefinition])
+ src/Proto3/Suite/Types.hs view
@@ -0,0 +1,119 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE ExplicitNamespaces #-}++module Proto3.Suite.Types+ (+ -- * Integral Types+ Fixed(..)+ , Signed(..)++ -- * Enumerable Types+ , Enumerated(..)++ , ForceEmit(..)+ , Nested(..)+ , UnpackedVec(..)+ , PackedVec(..)+ , NestedVec(..)+ , Commented(..)+ , type (//)()+ ) where++import Control.Applicative+import Control.DeepSeq (NFData)+import GHC.Exts (IsList(..))+import GHC.Generics+import Data.Semigroup (Semigroup)+import qualified Data.Vector as V+import GHC.TypeLits (Symbol)+import Test.QuickCheck (Arbitrary(..))++-- | 'Fixed' provides a way to encode integers in the fixed-width wire formats.+newtype Fixed a = Fixed { fixed :: a }+ deriving (Show, Eq, Ord, Num, Generic, NFData, Arbitrary, Enum, Bounded+ , Functor, Foldable, Traversable)++-- | 'Signed' provides a way to encode integers in the signed wire formats.+newtype Signed a = Signed { signed :: a }+ deriving (Show, Eq, Ord, Num, Generic, NFData, Arbitrary, Bounded+ , Functor, Foldable, Traversable)++-- | 'Enumerated' lifts any type with an 'IsEnum' instance so that it can be encoded+-- with 'HasEncoding'.+newtype Enumerated a = Enumerated { enumerated :: Either Int a }+ deriving (Show, Eq, Ord, Generic, NFData+ , Functor, Foldable, Traversable)++instance (Bounded a, Enum a) => Arbitrary (Enumerated a) where+ arbitrary = do+ i <- arbitrary+ if i < fromEnum (minBound :: a) || i > fromEnum (maxBound :: a)+ then return $ Enumerated $ Left i+ else return $ Enumerated $ Right (toEnum i)++-- | 'PackedVec' provides a way to encode packed lists of basic protobuf types into+-- the wire format.+newtype PackedVec a = PackedVec { packedvec :: V.Vector a }+ deriving (Show, Eq, Functor, Foldable, Traversable, Ord, NFData, Applicative,+ Alternative, Monoid, Semigroup)++instance IsList (PackedVec a) where+ type Item (PackedVec a) = a+ fromList = PackedVec . V.fromList+ toList = V.toList . packedvec++instance Arbitrary a => Arbitrary (PackedVec a) where+ arbitrary = fmap (PackedVec . V.fromList) arbitrary++newtype UnpackedVec a = UnpackedVec {unpackedvec :: V.Vector a }+ deriving (Show, Eq, Functor, Foldable, Traversable, Ord, NFData, Applicative,+ Alternative, Monoid, Semigroup)++instance IsList (UnpackedVec a) where+ type Item (UnpackedVec a) = a+ fromList = UnpackedVec . V.fromList+ toList = V.toList . unpackedvec++instance Arbitrary a => Arbitrary (UnpackedVec a) where+ arbitrary = fmap (UnpackedVec . V.fromList) arbitrary++newtype NestedVec a =+ NestedVec { nestedvec :: V.Vector a }+ deriving (Show, Eq, Functor, Foldable, Traversable, Ord, NFData, Applicative,+ Alternative, Monoid, Semigroup)++instance IsList (NestedVec a) where+ type Item (NestedVec a) = a+ fromList = NestedVec . V.fromList+ toList = V.toList . nestedvec++instance Arbitrary a => Arbitrary (NestedVec a) where+ arbitrary = fmap (NestedVec . V.fromList) arbitrary++-- | 'Nested' provides a way to nest protobuf messages within protobuf messages.+newtype Nested a = Nested { nested :: Maybe a }+ deriving (Show, Eq, Ord, Generic, NFData, Monoid, Arbitrary, Functor, Foldable,+ Traversable, Applicative, Alternative, Monad, Semigroup)++-- | 'ForceEmit' provides a way to force emission of field values, even when+-- default-value semantics states otherwise. Used when serializing oneof+-- subfields.+newtype ForceEmit a = ForceEmit{ forceEmit :: a }+ deriving (Show, Eq, Ord, Generic, NFData, Monoid, Arbitrary, Functor, Foldable,+ Traversable, Semigroup)++-- | 'Commented' provides a way to add comments to generated @.proto@ files.+newtype Commented (comment :: Symbol) a = Commented { unCommented :: a }+ deriving (Show, Eq, Ord, Generic, NFData, Monoid, Arbitrary, Functor, Foldable, Traversable, Semigroup)++-- | A type operator synonym for 'Commented', so that we can write C-style+-- comments on fields.+type a // (comment :: Symbol) = Commented comment a
+ test-files/all_packed_types.bin view
binary file changed (absent → 194 bytes)
+ test-files/multiple_fields.bin view
binary file changed (absent → 39 bytes)
+ test-files/signedints.bin view
@@ -0,0 +1,1 @@+S§
+ test-files/trivial.bin view
@@ -0,0 +1,1 @@+{
+ test-files/trivial_negative.bin view
@@ -0,0 +1,1 @@+ÿÿÿÿÿÿÿÿÿ
+ test-files/with_bytes.bin view
@@ -0,0 +1,2 @@++abcabc123
+ test-files/with_enum0.bin view
+ test-files/with_enum1.bin view
@@ -0,0 +1,1 @@+
+ test-files/with_fixed.bin view
binary file changed (absent → 28 bytes)
+ test-files/with_nesting.bin view
@@ -0,0 +1,3 @@+++123abcÀÄ
+ test-files/with_nesting_ints.bin view
@@ -0,0 +1,3 @@+++
+ test-files/with_nesting_maybe.bin view
@@ -0,0 +1,3 @@+++123abcÀÄ
+ test-files/with_nesting_repeated.bin view
binary file changed (absent → 56 bytes)
+ test-files/with_packing.bin view
@@ -0,0 +1,1 @@+
+ test-files/with_repetition.bin view
@@ -0,0 +1,2 @@++
+ tests/ArbitraryGeneratedTestTypes.hs view
@@ -0,0 +1,158 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}++module ArbitraryGeneratedTestTypes where++import qualified Data.Text.Lazy as T+import qualified Data.Vector as V+import qualified Proto3.Suite.Types as DotProto+import Test.QuickCheck (Arbitrary, arbitrary,+ arbitraryBoundedEnum, listOf)+import qualified Test.QuickCheck as QC+import TestProto+import qualified TestProtoImport+import qualified TestProtoOneof+import qualified TestProtoOneofImport++instance Arbitrary Trivial where+ arbitrary = Trivial <$> arbitrary++instance Arbitrary MultipleFields where+ arbitrary =+ MultipleFields+ <$> arbitrary+ <*> arbitrary+ <*> arbitrary+ <*> arbitrary+ <*> fmap T.pack arbitrary+ <*> arbitrary++instance Arbitrary WithEnum_TestEnum where+ arbitrary = arbitraryBoundedEnum++instance Arbitrary WithEnum where+ arbitrary = WithEnum <$> arbitrary++instance Arbitrary WithNesting_Nested where+ arbitrary =+ WithNesting_Nested+ <$> fmap T.pack arbitrary+ <*> arbitrary+ <*> arbitrary+ <*> arbitrary++instance Arbitrary WithNesting where+ arbitrary = WithNesting <$> arbitrary++instance Arbitrary WithRepetition where+ arbitrary = WithRepetition <$> arbitrary++instance Arbitrary WithFixed where+ arbitrary = WithFixed <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary++instance Arbitrary WithBytes where+ arbitrary = WithBytes <$> arbitrary <*> arbitrary++instance Arbitrary AllPackedTypes where+ arbitrary = do+ AllPackedTypes+ <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary+ <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary+ <*> arbitrary <*> arbEnums <*> arbEnums+ where+ arbEnums = V.fromList <$> listOf (DotProto.Enumerated . Right <$> arbitraryBoundedEnum)++instance Arbitrary SignedInts where+ arbitrary = SignedInts <$> arbitrary <*> arbitrary++instance Arbitrary WithNestingRepeated where+ arbitrary = WithNestingRepeated <$> arbitrary++instance Arbitrary WithNestingRepeated_Nested where+ arbitrary =+ WithNestingRepeated_Nested+ <$> fmap T.pack arbitrary+ <*> arbitrary+ <*> arbitrary+ <*> arbitrary++instance Arbitrary WithNestingRepeatedInts where+ arbitrary = WithNestingRepeatedInts <$> arbitrary++instance Arbitrary NestedInts where+ arbitrary = NestedInts <$> arbitrary <*> arbitrary++instance Arbitrary OutOfOrderFields where+ arbitrary =+ OutOfOrderFields+ <$> arbitrary+ <*> fmap T.pack arbitrary+ <*> arbitrary+ <*> fmap (fmap T.pack) arbitrary++instance Arbitrary UsingImported where+ arbitrary =+ UsingImported+ <$> arbitrary+ <*> arbitrary++instance Arbitrary TestProtoImport.WithNesting where+ arbitrary =+ TestProtoImport.WithNesting+ <$> arbitrary+ <*> arbitrary++instance Arbitrary TestProtoImport.WithNesting_Nested where+ arbitrary =+ TestProtoImport.WithNesting_Nested+ <$> arbitrary+ <*> arbitrary++instance Arbitrary Wrapped where+ arbitrary = Wrapped <$> arbitrary++instance Arbitrary TestProtoOneof.DummyMsg where+ arbitrary =+ TestProtoOneof.DummyMsg+ <$> arbitrary++instance Arbitrary TestProtoOneof.Something where+ arbitrary =+ TestProtoOneof.Something+ <$> arbitrary+ <*> arbitrary+ <*> arbitrary++instance Arbitrary TestProtoOneof.SomethingPickOne where+ arbitrary =+ QC.oneof+ [ TestProtoOneof.SomethingPickOneName <$> fmap T.pack arbitrary+ , TestProtoOneof.SomethingPickOneSomeid <$> arbitrary+ , TestProtoOneof.SomethingPickOneDummyMsg1 <$> arbitrary+ , TestProtoOneof.SomethingPickOneDummyMsg2 <$> arbitrary+ , TestProtoOneof.SomethingPickOneDummyEnum . DotProto.Enumerated . Right+ <$> arbitraryBoundedEnum+ ]++instance Arbitrary TestProtoOneof.WithImported where+ arbitrary =+ TestProtoOneof.WithImported+ <$> arbitrary++instance Arbitrary TestProtoOneof.WithImportedPickOne where+ arbitrary =+ QC.oneof+ [ TestProtoOneof.WithImportedPickOneDummyMsg1 <$> arbitrary+ , TestProtoOneof.WithImportedPickOneWithOneof <$> arbitrary+ ]++instance Arbitrary TestProtoOneofImport.WithOneof where+ arbitrary =+ TestProtoOneofImport.WithOneof+ <$> arbitrary++instance Arbitrary TestProtoOneofImport.WithOneofPickOne where+ arbitrary =+ QC.oneof+ [ TestProtoOneofImport.WithOneofPickOneA <$> fmap T.pack arbitrary+ , TestProtoOneofImport.WithOneofPickOneB <$> arbitrary+ ]
+ tests/Main.hs view
@@ -0,0 +1,318 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE CPP #-}++{-# OPTIONS_GHC -fno-warn-orphans #-}++module Main where++import ArbitraryGeneratedTestTypes ()+import qualified Data.ByteString as B+import qualified Data.ByteString.Char8 as BC+import qualified Data.ByteString.Lazy as BL+import Data.Either (isRight)+import Data.String+import Data.Semigroup ((<>))+import GHC.Exts (fromList, Proxy#)+import Proto3.Suite+import Proto3.Wire.Decode (ParseError)+import qualified Proto3.Wire.Decode as Decode+import Proto3.Wire.Types as P+import qualified Test.DocTest+import Test.QuickCheck (Arbitrary, Property, arbitrary,+ counterexample, oneof)+import Test.Tasty+import Test.Tasty.HUnit (Assertion, assertBool, testCase,+ (@=?), (@?=))+import Test.Tasty.QuickCheck (testProperty, (===))+import TestCodeGen+import qualified TestProto as TP++#ifdef DHALL+import TestDhall+#endif++main :: IO ()+main = defaultMain tests++tests :: TestTree+tests = testGroup "Tests"+ [ docTests+ , qcProperties+ , encodeUnitTests+ , decodeUnitTests+ , parserUnitTests+ , dotProtoUnitTests+ , codeGenTests++#ifdef DHALL+ , dhallTests+#endif++ ]++--------------------------------------------------------------------------------+-- Doctests++docTests :: TestTree+docTests = testCase "doctests" $ do+ putStrLn "Running all doctests..."+ Test.DocTest.doctest+ [ "-isrc"+ , "-itests"+ , "-igen"+ , "src/Proto3/Suite/DotProto/Internal.hs"+ , "src/Proto3/Suite/JSONPB/Class.hs"+ , "tests/TestCodeGen.hs"+ ]++--------------------------------------------------------------------------------+-- QuickCheck properties++type MsgProp a = a -> Property++qcProperties :: TestTree+qcProperties = testGroup "QuickCheck properties"+ [ qcPropDecEncId+ ]++-- | Verifies that @decode . encode = id@ for various message types+qcPropDecEncId :: TestTree+qcPropDecEncId = testGroup "Property: (decode . encode = id) for various message types"+ [ testProperty "Trivial" (prop :: MsgProp TP.Trivial)+ , testProperty "MultipleFields" (prop :: MsgProp TP.MultipleFields)+ , testProperty "WithEnum" (prop :: MsgProp TP.WithEnum)+ , testProperty "WithNesting" (prop :: MsgProp TP.WithNesting)+ , testProperty "WithRepetition" (prop :: MsgProp TP.WithRepetition)+ , testProperty "WithFixed" (prop :: MsgProp TP.WithFixed)+ , testProperty "WithBytes" (prop :: MsgProp TP.WithBytes)+ , testProperty "AllPackedTypes" (prop :: MsgProp TP.AllPackedTypes)+ , testProperty "SignedInts" (prop :: MsgProp TP.SignedInts)+ , testProperty "WithNestingRepeated" (prop :: MsgProp TP.WithNestingRepeated)+ , deeplyNest prop 1000+ ]+ where+ prop :: (Message a, Arbitrary a, Eq a, Show a) => MsgProp a+ prop msg = msg === (dec . enc) msg+ where+ dec = either (error . ("error parsing: " <>) . show) id . fromByteString+ enc = BL.toStrict . toLazyByteString++ deeplyNest :: MsgProp TP.Wrapped -> Int -> TestTree+ deeplyNest pf 0 = testProperty "Deeply nested" pf+ deeplyNest pf n = deeplyNest (pf . TP.Wrapped . Just) (n-1)+++--------------------------------------------------------------------------------+-- Encoding++encodeUnitTests :: TestTree+encodeUnitTests = testGroup "Encoder unit tests"+ [ encoderMatchesGoldens+ ]++-- TODO: We should consider generating the reference encodings+-- (test-files/make_reference_encodings.py) as a part of running the test suite+-- rather than having them in the repository.+encoderMatchesGoldens :: TestTree+encoderMatchesGoldens = testGroup "Encoder matches golden encodings"+ [ check "trivial.bin" $ TP.Trivial 123+ , check "trivial_negative.bin" $ TP.Trivial (-1)+ , check "multiple_fields.bin" $ TP.MultipleFields 1.23 (-0.5) 123 1234567890 "Hello, world!" True+ , check "signedints.bin" $ TP.SignedInts (-42) (-84)+ , check "with_nesting.bin" $ TP.WithNesting $ Just $ TP.WithNesting_Nested "123abc" 123456 [] []+ , check "with_enum0.bin" $ TP.WithEnum $ Enumerated $ Right $ TP.WithEnum_TestEnumENUM1+ , check "with_enum1.bin" $ TP.WithEnum $ Enumerated $ Right $ TP.WithEnum_TestEnumENUM2+ , check "with_repetition.bin" $ TP.WithRepetition [1..5]+ , check "with_bytes.bin" $ TP.WithBytes (BC.pack "abc") (fromList $ map BC.pack ["abc","123"])+ , check "with_nesting_repeated.bin" $ TP.WithNestingRepeated+ [ TP.WithNestingRepeated_Nested "123abc" 123456 [1,2,3,4] [5,6,7,8]+ , TP.WithNestingRepeated_Nested "abc123" 654321 [0,9,8,7] [6,5,4,3]+ ]+ ]+ where+ check fp v = testCase fp $ do+ goldenEncoding <- BL.readFile (testFilesPfx <> fp)+ toLazyByteString v @?= goldenEncoding++--------------------------------------------------------------------------------+-- Decoding++decodeUnitTests :: TestTree+decodeUnitTests = testGroup "Decoder unit tests"+ [ decodeFromGoldens+ ]++decodeFromGoldens :: TestTree+decodeFromGoldens = testGroup "Decode golden encodings into key/value lists"+ [ check "trivial.bin"+ , check "trivial_negative.bin"+ , check "multiple_fields.bin"+ , check "signedints.bin"+ , check "with_nesting.bin"+ , check "with_enum0.bin"+ , check "with_enum1.bin"+ , check "with_repetition.bin"+ , check "with_bytes.bin"+ , check "with_nesting_repeated.bin"+ ]+ where+ check fp = testCase fp $ do+ kvs <- Decode.decodeWire <$> B.readFile (testFilesPfx <> fp)+ assertBool ("parsing " <> fp <> " into a key-value list succeeds") (isRight kvs)++--------------------------------------------------------------------------------+-- Parser++parserUnitTests :: TestTree+parserUnitTests = testGroup "Parser unit tests"+ [ parseFromGoldens+ ]++parseFromGoldens :: TestTree+parseFromGoldens = testGroup "Parse golden encodings"+ [ check "trivial.bin" $ TP.Trivial 123+ , check "multiple_fields.bin" $ TP.MultipleFields 1.23 (-0.5) 123 1234567890 "Hello, world!" True+ , check "signedints.bin" $ TP.SignedInts (-42) (-84)+ , check "with_nesting.bin" $ TP.WithNesting $ Just $ TP.WithNesting_Nested "123abc" 123456 [] []+ , check "with_enum0.bin" $ TP.WithEnum $ Enumerated $ Right $ TP.WithEnum_TestEnumENUM1+ , check "with_enum1.bin" $ TP.WithEnum $ Enumerated $ Right $ TP.WithEnum_TestEnumENUM2+ , check "with_repetition.bin" $ TP.WithRepetition [1..5]+ , check "with_fixed.bin" $ TP.WithFixed 16 (-123) 4096 (-4096)+ , check "with_bytes.bin" $ TP.WithBytes (BC.pack "abc") (fromList $ map BC.pack ["abc","123"])+ , check "with_packing.bin" $ TP.WithPacking [1,2,3] [1,2,3]+ , check "all_packed_types.bin" $ TP.AllPackedTypes+ [1,2,3]+ [1,2,3]+ [-1,-2,-3]+ [-1,-2,-3]+ (fromList [1..3])+ (fromList [1..3])+ [1.0,2.0]+ [1.0,-1.0]+ (fromList [1,2,3])+ (fromList [1,2,3])+ [False,True]+ (Enumerated . Right <$> [TP.EFLD0, TP.EFLD1])+ (Enumerated . Right <$> [TP.EFLD0, TP.EFLD1])+ , check "with_nesting_repeated.bin" $ TP.WithNestingRepeated+ [ TP.WithNestingRepeated_Nested "123abc" 123456 [1,2,3,4] [5,6,7,8]+ , TP.WithNestingRepeated_Nested "abc123" 654321 [0,9,8,7] [6,5,4,3]+ ]+ , -- Checks parsing repeated embedded messages when one is expected (i.e.,+ -- this tests correct merging; this value was encoded as a+ -- WithNestingRepeated).+ check "with_nesting_repeated.bin" $ TP.WithNesting $ Just $ TP.WithNesting_Nested "abc123" 654321 [1,2,3,4,0,9,8,7] [5,6,7,8,6,5,4,3]+ , -- Checks that embedded message merging works correctly when fields have+ -- default values; this value was encoded as a WithNestingRepeatedInts+ check "with_nesting_ints.bin" $ TP.WithNestingInts $ Just $ TP.NestedInts 2 2+ ]+ where+ check fp = testCase fp . testParser (testFilesPfx <> fp) fromByteString++testParser :: (Show a, Eq a)+ => FilePath -> (B.ByteString -> Either ParseError a) -> a -> IO ()+testParser fp p reference = do+ bs <- B.readFile fp+ case p bs of+ Left err -> error $ "Got error: " ++ show err+ Right ourResult -> ourResult @?= reference++testDotProtoParse :: FilePath -> DotProto -> Assertion+testDotProtoParse file ast = do+ contents <- readFile file+ case parseProto (Path []) contents of+ Left err -> error $ show err+ Right result -> ast @=? result++testDotProtoPrint :: DotProto -> String -> Assertion+testDotProtoPrint ast expected = expected @=? toProtoFileDef ast++testDotProtoRoundtrip :: DotProto -> Assertion+testDotProtoRoundtrip ast =+ Right ast @=? parseProto (Path []) (toProtoFileDef ast)++dotProtoUnitTests :: TestTree+dotProtoUnitTests = testGroup ".proto parsing tests"+ [ dotProtoParseTrivial+ , dotProtoPrintTrivial+ , dotProtoRoundtripTrivial+ , dotProtoRoundtripSimpleMessage+ , qcDotProtoRoundtrip+ ]++trivialDotProto :: DotProto+trivialDotProto = DotProto [] [] DotProtoNoPackage [] (DotProtoMeta (Path []))++dotProtoParseTrivial :: TestTree+dotProtoParseTrivial = testCase+ "Parse a content-less file" $+ testDotProtoParse "test-files/trivial.proto" trivialDotProto++dotProtoPrintTrivial :: TestTree+dotProtoPrintTrivial = testCase+ "Print a content-less DotProto" $+ testDotProtoPrint trivialDotProto "syntax = \"proto3\";"++dotProtoRoundtripTrivial :: TestTree+dotProtoRoundtripTrivial = testCase+ "Printing then parsing a content-less DotProto yields an empty DotProto" $+ testDotProtoRoundtrip trivialDotProto++dotProtoSimpleMessage :: DotProto+dotProtoSimpleMessage = DotProto [] [] DotProtoNoPackage+ [ DotProtoMessage (Single "MessageTest")+ [ DotProtoMessageField $+ DotProtoField (fieldNumber 1) (Prim Int32) (Single "testfield") [] Nothing+ ]+ ]+ (DotProtoMeta (Path []))++dotProtoRoundtripSimpleMessage :: TestTree+dotProtoRoundtripSimpleMessage = testCase+ "Round-trip for a single flat message" $+ testDotProtoRoundtrip dotProtoSimpleMessage++qcDotProtoRoundtrip :: TestTree+qcDotProtoRoundtrip = testProperty+ "Round-trip for a randomly-generated .proto AST" roundtrip+ where+ roundtrip :: DotProto -> Property+ roundtrip ast = let generated = toProtoFileDef ast+ in case parseProto (Path []) generated of+ Left err -> error $ formatParseError err generated+ Right result -> counterexample (formatMismatch ast generated result ) (ast == result)++ formatMismatch initial generated result = "AST changed during reparsing\n\nInitial AST:\n\n"+ ++ show initial+ ++ "\n\nGenerated .proto file:\n\n"+ ++ generated+ ++ "\n\nReparsed AST:\n\n"+ ++ show result+ ++ "\n\nRegenerated .proto file:\n\n"+ ++ (toProtoFileDef result)+ formatParseError err generated = "Parsec error:\n\n"+ ++ show err+ ++ "\n\nWhen attempting to parse:\n\n"+ ++ generated+ ++ "\n\nInitial AST:\n\n"++--------------------------------------------------------------------------------+-- Helpers++dotProtoFor :: (Named a, Message a) => Proxy# a -> DotProto+dotProtoFor proxy = DotProto [] [] DotProtoNoPackage+ [ DotProtoMessage (Single (nameOf proxy)) (DotProtoMessageField <$> dotProto proxy)+ ]+ (DotProtoMeta (Path []))++showDotProtoFor :: (Named a, Message a) => Proxy# a -> IO ()+showDotProtoFor proxy = putStrLn . toProtoFileDef $ dotProtoFor proxy++instance Arbitrary WireType where+ arbitrary = oneof $ map return [Varint, P.Fixed32, P.Fixed64, LengthDelimited]++testFilesPfx :: IsString a => a+testFilesPfx = "test-files/"
+ tests/TestCodeGen.hs view
@@ -0,0 +1,257 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}++module TestCodeGen where++import ArbitraryGeneratedTestTypes ()+import Control.Applicative+import Control.Monad+import qualified Data.Aeson+import qualified Data.ByteString.Lazy as LBS+import qualified Data.ByteString.Lazy.Char8 as LBS8+import Data.Monoid ((<>))+import Data.Proxy (Proxy(..))+import Data.String (IsString)+import Data.Swagger (ToSchema)+import qualified Data.Swagger+import qualified Data.Text as T+import Prelude hiding (FilePath)+import Proto3.Suite.DotProto.Generate+import Proto3.Suite.JSONPB (FromJSONPB (..), Options (..),+ ToJSONPB (..), eitherDecode,+ encode, defaultOptions)+import System.Exit+import Test.Tasty+import Test.Tasty.HUnit (testCase, (@?=))+import Turtle (FilePath)+import qualified Turtle+import qualified Turtle.Format as F++codeGenTests :: TestTree+codeGenTests = testGroup "Code generator unit tests"+ [ camelCaseMessageNames+ , camelCaseMessageFieldNames+ , don'tAlterEnumFieldNames+ , simpleEncodeDotProto+ , simpleDecodeDotProto+ ]++camelCaseMessageNames :: TestTree+camelCaseMessageNames = testGroup "CamelCasing of message names"+ [ testCase "Capitalizes letters after underscores" (typeLikeName "protocol_analysis" @?= Right "ProtocolAnalysis")+ , testCase "Preserves casing of interior letters" (typeLikeName "analyze_HTTP" @?= Right "AnalyzeHTTP")+ , testCase "Handles non-alphanumeric characters after underscore" (typeLikeName "analyze_http_2" @?= Right "AnalyzeHttp2")+ , testCase "Preserves one underscore in double underscore sequence" (typeLikeName "Analyze__HTTP" @?= Right "Analyze_HTTP")+ , testCase "Handles names prefixed with underscore" (typeLikeName "_message_name" @?= Right "XMessageName")+ , testCase "Preserves trailing underscore" (typeLikeName "message_name_" @?= Right "MessageName_") ]+++camelCaseMessageFieldNames :: TestTree+camelCaseMessageFieldNames = testGroup "camelCasing of field names"+ [ testCase "Preserves capitalization patterns" (fieldLikeName "IP" @?= "ip")+ , testCase "Preserves underscores" (fieldLikeName "IP_address" @?= "ip_address") ]++don'tAlterEnumFieldNames :: TestTree+don'tAlterEnumFieldNames+ = testGroup "Do not alter enumeration field names"+ $ tc <$> [ "fnord"+ , "FNORD"+ , "PascalCase"+ , "camelCase"+ , "VOCIFEROUS_SNAKE_CASE"+ , "snake_case"+ , "snake_case_"+ ]+ where+ enumName = "MyEnum"+ tc fieldName = testCase fieldName+ $ prefixedEnumFieldName enumName fieldName+ @?= (enumName <> fieldName)++setPythonPath :: IO ()+setPythonPath = Turtle.export "PYTHONPATH" =<< do+ maybe pyTmpDir ((pyTmpDir <> ":") <>) <$> Turtle.need "PYTHONPATH"++simpleEncodeDotProto :: TestTree+simpleEncodeDotProto =+ testCase "generate code for a simple .proto and then use it to encode messages"+ $ do+ compileTestDotProtos+ -- Compile our generated encoder+ (@?= ExitSuccess) =<< Turtle.proc "tests/encode.sh" [hsTmpDir] empty++ -- The python encoder test exits with a special error code to indicate+ -- all tests were successful+ setPythonPath+ let cmd = hsTmpDir <> "/simpleEncodeDotProto | python tests/check_simple_dot_proto.py"+ (@?= ExitFailure 12) =<< Turtle.shell cmd empty++ -- Not using bracket so that we can inspect the output to fix the tests+ Turtle.rmtree hsTmpDir+ Turtle.rmtree pyTmpDir++simpleDecodeDotProto :: TestTree+simpleDecodeDotProto =+ testCase "generate code for a simple .proto and then use it to decode messages"+ $ do+ compileTestDotProtos+ -- Compile our generated decoder+ (@?= ExitSuccess) =<< Turtle.proc "tests/decode.sh" [hsTmpDir] empty++ setPythonPath+ let cmd = "python tests/send_simple_dot_proto.py | " <> hsTmpDir <> "/simpleDecodeDotProto "+ (@?= ExitSuccess) =<< Turtle.shell cmd empty++ -- Not using bracket so that we can inspect the output to fix the tests+ Turtle.rmtree hsTmpDir+ Turtle.rmtree pyTmpDir++-- * Helpers++-- E.g. dumpAST ["test-files"] "test_proto.proto"+dumpAST :: [FilePath] -> FilePath -> IO ()+dumpAST incs fp = do+ Right (dp, tc) <- readDotProtoWithContext incs fp+ let Right src = renderHsModuleForDotProto mempty dp tc+ putStrLn src++hsTmpDir, pyTmpDir :: IsString a => a+hsTmpDir = "test-files/hs-tmp"+pyTmpDir = "test-files/py-tmp"++compileTestDotProtos :: IO ()+compileTestDotProtos = do+ Turtle.mktree hsTmpDir+ Turtle.mktree pyTmpDir+ forM_ protoFiles $ \protoFile -> do+ compileDotProtoFileOrDie [] hsTmpDir ["test-files"] protoFile+ (@?= ExitSuccess) =<< Turtle.shell (T.concat [ "protoc --python_out="+ , pyTmpDir+ , " --proto_path=test-files"+ , " test-files/" <> Turtle.format F.fp protoFile+ ])+ empty+ Turtle.touch (pyTmpDir Turtle.</> "__init__.py")+ where+ protoFiles =+ [ "test_proto.proto"+ , "test_proto_import.proto"+ , "test_proto_oneof.proto"+ , "test_proto_oneof_import.proto"+ ]++-- * Doctests for JSONPB++-- $setup+-- >>> import qualified Data.Text.Lazy as TL+-- >>> import qualified Data.Vector as V+-- >>> import Proto3.Suite+-- >>> import Proto3.Suite.JSONPB+-- >>> import TestProto+-- >>> import TestProtoOneof+-- >>> :set -XOverloadedStrings+-- >>> :set -XOverloadedLists+-- >>> :set -XTypeApplications+-- >>> let jsonPB = jsonPBOptions+-- >>> let json = defaultOptions++-- | Round-trip tests+-- prop> roundTrip (x :: Trivial)+-- prop> roundTrip (x :: MultipleFields)+-- prop> roundTrip (x :: SignedInts)+-- prop> roundTrip (SignedInts minBound minBound)+-- prop> roundTrip (SignedInts maxBound maxBound)+-- prop> roundTrip (WithEnum (Enumerated (Right x)))+-- prop> roundTrip (x :: WithNesting)+-- prop> roundTrip (x :: WithNestingRepeated)+-- prop> roundTrip (x :: WithNestingRepeatedInts)+-- prop> roundTrip (x :: WithBytes)+-- prop> roundTrip (x :: OutOfOrderFields)+-- prop> roundTrip (x :: UsingImported)+-- prop> roundTrip (x :: Wrapped)+-- prop> roundTrip (x :: Something)+-- prop> roundTrip (x :: WithImported)++-- | Specific encoding tests+-- prop> encodesAs jsonPB (MultipleFields 0 0 0 0 "" False) "{}"+-- prop> encodesAs json (MultipleFields 0 2.0 0 0 "" True) "{\"multiFieldDouble\":0.0,\"multiFieldFloat\":2.0,\"multiFieldInt32\":0,\"multiFieldInt64\":\"0\",\"multiFieldString\":\"\",\"multiFieldBool\":true}"+-- prop> encodesAs jsonPB (SignedInts minBound minBound) "{\"signed32\":-2147483648,\"signed64\":\"-9223372036854775808\"}"+-- prop> encodesAs jsonPB (SignedInts maxBound maxBound) "{\"signed32\":2147483647,\"signed64\":\"9223372036854775807\"}"+-- prop> encodesAs jsonPB (WithEnum (Enumerated (Right WithEnum_TestEnumENUM1))) "{}"+-- prop> encodesAs json (WithEnum (Enumerated (Right WithEnum_TestEnumENUM1))) "{\"enumField\":\"ENUM1\"}"+-- prop> encodesAs jsonPB (WithEnum (Enumerated (Right WithEnum_TestEnumENUM3))) "{\"enumField\":\"ENUM3\"}"+-- prop> encodesAs jsonPB (WithNesting $ Just $ WithNesting_Nested "" 0 [1,2] [66,99]) "{\"nestedMessage\":{\"nestedPacked\":[1,2],\"nestedUnpacked\":[66,99]}}"+-- prop> encodesAs jsonPB (Something 42 99 (Just (SomethingPickOneName ""))) "{\"value\":\"42\",\"another\":99,\"name\":\"\"}"+-- prop> encodesAs jsonPB (Something 42 99 (Just (SomethingPickOneSomeid 0))) "{\"value\":\"42\",\"another\":99,\"someid\":0}"+-- prop> encodesAs jsonPB (Something 42 99 (Just (SomethingPickOneDummyMsg1 (DummyMsg 66)))) "{\"value\":\"42\",\"another\":99,\"dummyMsg1\":{\"dummy\":66}}"+-- prop> encodesAs jsonPB (Something 42 99 (Just (SomethingPickOneDummyMsg2 (DummyMsg 67)))) "{\"value\":\"42\",\"another\":99,\"dummyMsg2\":{\"dummy\":67}}"+-- prop> encodesAs jsonPB (Something 42 99 (Just (SomethingPickOneDummyEnum (Enumerated (Right DummyEnumDUMMY0))))) "{\"value\":\"42\",\"another\":99,\"dummyEnum\":\"DUMMY0\"}"+-- prop> encodesAs jsonPB (Something 42 99 Nothing) "{\"value\":\"42\",\"another\":99}"+-- prop> encodesAs json (Something 42 99 (Just (SomethingPickOneName ""))) "{\"value\":\"42\",\"another\":99,\"pickOne\":{\"name\":\"\"}}"+-- prop> encodesAs json (Something 42 99 (Just (SomethingPickOneSomeid 0))) "{\"value\":\"42\",\"another\":99,\"pickOne\":{\"someid\":0}}"+-- prop> encodesAs json (Something 42 99 (Just (SomethingPickOneDummyMsg1 (DummyMsg 66)))) "{\"value\":\"42\",\"another\":99,\"pickOne\":{\"dummyMsg1\":{\"dummy\":66}}}"+-- prop> encodesAs json (Something 42 99 (Just (SomethingPickOneDummyMsg2 (DummyMsg 67)))) "{\"value\":\"42\",\"another\":99,\"pickOne\":{\"dummyMsg2\":{\"dummy\":67}}}"+-- prop> encodesAs json (Something 42 99 (Just (SomethingPickOneDummyEnum (Enumerated (Right DummyEnumDUMMY0))))) "{\"value\":\"42\",\"another\":99,\"pickOne\":{\"dummyEnum\":\"DUMMY0\"}}"+-- prop> encodesAs json (Something 42 99 Nothing) "{\"value\":\"42\",\"another\":99,\"pickOne\":null}"++-- | Specific decoding tests+-- prop> decodesAs "{\"signed32\":2147483647,\"signed64\":\"9223372036854775807\"}" (SignedInts 2147483647 9223372036854775807)+-- prop> decodesAs "{\"enumField\":\"ENUM3\"}" (WithEnum (Enumerated (Right WithEnum_TestEnumENUM3)))+-- prop> decodesAs "{\"enumField\":null}" (WithEnum (Enumerated (Right WithEnum_TestEnumENUM1)))+-- prop> decodesAs "{}" (WithEnum (Enumerated (Right WithEnum_TestEnumENUM1)))+-- prop> decodesAs "{\"nestedMessage\":{}}" (WithNesting $ Just $ WithNesting_Nested "" 0 [] [])+--+-- JSONPB+--+-- prop> decodesAs "{\"value\":\"42\",\"another\":99,\"someid\":66}" (Something 42 99 (Just (SomethingPickOneSomeid 66)))+-- prop> decodesAs "{\"value\":\"42\",\"another\":99,\"name\":\"foo\"}" (Something 42 99 (Just (SomethingPickOneName "foo")))+-- prop> decodesAs "{\"value\":\"42\",\"another\":99,\"dummyMsg1\":{\"dummy\":41}}" (Something 42 99 (Just (SomethingPickOneDummyMsg1 (DummyMsg 41))))+-- prop> decodesAs "{\"value\":\"42\",\"another\":99,\"dummyMsg2\":{\"dummy\":43}}" (Something 42 99 (Just (SomethingPickOneDummyMsg2 (DummyMsg 43))))+-- prop> decodesAs "{\"value\":\"42\",\"another\":99,\"dummyEnum\":\"DUMMY0\"}" (Something 42 99 (Just (SomethingPickOneDummyEnum (Enumerated (Right DummyEnumDUMMY0)))))+-- prop> decodesAs "{\"value\":\"42\",\"another\":99}" (Something 42 99 Nothing)+--+-- JSON+--+-- prop> decodesAs "{\"value\":\"42\",\"another\":99,\"pickOne\":{\"name\":\"\"}}" (Something 42 99 (Just (SomethingPickOneName "")))+-- prop> decodesAs "{\"value\":\"42\",\"another\":99,\"pickOne\":{\"someid\":0}}" (Something 42 99 (Just (SomethingPickOneSomeid 0)))+-- prop> decodesAs "{\"value\":\"42\",\"another\":99,\"pickOne\":{\"dummyMsg1\":{\"dummy\":66}}}" (Something 42 99 (Just (SomethingPickOneDummyMsg1 (DummyMsg 66))))+-- prop> decodesAs "{\"value\":\"42\",\"another\":99,\"pickOne\":{\"dummyMsg2\":{\"dummy\":67}}}" (Something 42 99 (Just (SomethingPickOneDummyMsg2 (DummyMsg 67))))+-- prop> decodesAs "{\"value\":\"42\",\"another\":99,\"pickOne\":{\"dummyEnum\":\"DUMMY0\"}}" (Something 42 99 (Just (SomethingPickOneDummyEnum (Enumerated (Right DummyEnumDUMMY0)))))+-- prop> decodesAs "{\"value\":\"42\",\"another\":99,\"pickOne\":{}}" (Something 42 99 Nothing)+-- prop> decodesAs "{\"value\":\"42\",\"another\":99,\"pickOne\":null}" (Something 42 99 Nothing)+--+-- Swagger+--+-- >>> schemaOf @Something+-- {"properties":{"value":{"maximum":9223372036854775807,"format":"int64","minimum":-9223372036854775808,"type":"integer"},"another":{"maximum":2147483647,"format":"int32","minimum":-2147483648,"type":"integer"},"pickOne":{"$ref":"#/definitions/SomethingPickOne"}},"type":"object"}+-- >>> schemaOf @SomethingPickOne+-- {"properties":{"name":{"type":"string"},"someid":{"maximum":2147483647,"format":"int32","minimum":-2147483648,"type":"integer"},"dummyMsg1":{"$ref":"#/definitions/DummyMsg"},"dummyMsg2":{"$ref":"#/definitions/DummyMsg"},"dummyEnum":{"$ref":"#/definitions/DummyEnum"}},"maxProperties":1,"minProperties":1,"type":"object"}+-- >>> schemaOf @DummyMsg+-- {"properties":{"dummy":{"maximum":2147483647,"format":"int32","minimum":-2147483648,"type":"integer"}},"type":"object"}+-- >>> schemaOf @(Enumerated DummyEnum)+-- {"type":"string","enum":["DUMMY0","DUMMY1"]}++-- * Helper quickcheck props++roundTrip :: (ToJSONPB a, FromJSONPB a, Eq a)+ => a -> Bool+roundTrip x = roundTrip' False && roundTrip' True+ where+ roundTrip' emitDefaults =+ eitherDecode (encode defaultOptions{ optEmitDefaultValuedFields = emitDefaults} x)+ ==+ Right x++encodesAs :: (ToJSONPB a)+ => Options -> a -> LBS.ByteString -> Bool+encodesAs opts x bs = encode opts x == bs++decodesAs :: (Eq a, FromJSONPB a)+ => LBS.ByteString -> a -> Bool+decodesAs bs x = eitherDecode bs == Right x++schemaOf :: forall a . ToSchema a => IO ()+schemaOf = LBS8.putStrLn (Data.Aeson.encode (Data.Swagger.toSchema (Proxy @a)))
+ tests/TestDhall.hs view
@@ -0,0 +1,23 @@+module TestDhall where++import TestProtoOneof+import Test.Tasty+import Test.Tasty.HUnit (testCase, (@?=))++import qualified Dhall+import qualified Dhall.Core++dhallTests :: TestTree+dhallTests = testGroup "Dhall to/from proto unit tests"+ [ roundTripDhall ]++roundTripDhall :: TestTree+roundTripDhall = testCase "round trip to Dhall and back" $ do+ + let hsProtoMsg = Something 42 99 (Just (SomethingPickOneSomeid 66))++ let dhProtoMsg = Dhall.Core.pretty (Dhall.embed Dhall.inject hsProtoMsg)++ hsProtoMsg2 <- Dhall.input Dhall.auto dhProtoMsg++ hsProtoMsg2 @?= hsProtoMsg
+ tests/decode.sh view
@@ -0,0 +1,15 @@+#!/usr/bin/env bash+set -eu+hsTmpDir=$1++ghc \+ --make \+ -odir $hsTmpDir \+ -hidir $hsTmpDir \+ -o $hsTmpDir/simpleDecodeDotProto \+ $hsTmpDir/TestProto.hs \+ $hsTmpDir/TestProtoImport.hs \+ $hsTmpDir/TestProtoOneof.hs \+ $hsTmpDir/TestProtoOneofImport.hs \+ tests/SimpleDecodeDotProto.hs \+ >/dev/null
+ tests/encode.sh view
@@ -0,0 +1,15 @@+#!/usr/bin/env bash+set -eu+hsTmpDir=$1++ghc \+ --make \+ -odir $hsTmpDir \+ -hidir $hsTmpDir \+ -o $hsTmpDir/simpleEncodeDotProto \+ $hsTmpDir/TestProto.hs \+ $hsTmpDir/TestProtoImport.hs \+ $hsTmpDir/TestProtoOneof.hs \+ $hsTmpDir/TestProtoOneofImport.hs \+ tests/SimpleEncodeDotProto.hs \+ >/dev/null
+ tools/canonicalize-proto-file/Main.hs view
@@ -0,0 +1,247 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}++module Main (main) where++import Data.List (sort, sortOn)+import Data.RangeSet.List (fromRangeList, toRangeList)+import Data.Semigroup (Min(..), Option(..))+import Options.Generic+import Prelude hiding (FilePath)+import Proto3.Suite.DotProto.AST+import Proto3.Suite.DotProto.Generate+import Proto3.Suite.DotProto.Rendering+import Proto3.Wire.Types (FieldNumber (..))+import Turtle (FilePath)++data Args w = Args+ { includeDir :: w ::: [FilePath] <?> "Path to search for included .proto files (can be repeated, and paths will be searched in order; the current directory is used if this option is not provided)"+ , proto :: w ::: FilePath <?> "Path to input .proto file"+ } deriving Generic+instance ParseRecord (Args Wrapped)+deriving instance Show (Args Unwrapped)++main :: IO ()+main = do+ Args{..} :: Args Unwrapped <- unwrapRecord "Dumps a canonicalized .proto file to stdout"+ readDotProtoWithContext includeDir proto >>= \case+ Left err -> fail (show err)+ Right (dp, _) -> putStr (toProtoFile defRenderingOptions (canonicalize dp))++class Canonicalize a where+ canonicalize :: a -> a++class Ord r => CanonicalRank a r | a -> r where+ canonicalRank :: a -> r+ default canonicalRank :: (Ord a, a ~ r) => a -> r+ canonicalRank = id++canonicalSort :: (CanonicalRank a r, Canonicalize a) => [a] -> [a]+canonicalSort = sortOn canonicalRank . map canonicalize++instance Canonicalize DotProto where+ canonicalize DotProto{..} = DotProto+ { protoImports = canonicalize protoImports+ , protoOptions = canonicalize protoOptions+ , protoPackage = canonicalize protoPackage+ , protoDefinitions = canonicalize protoDefinitions+ , protoMeta = protoMeta+ }++instance Canonicalize [DotProtoImport] where canonicalize = canonicalSort++instance CanonicalRank DotProtoImport DotProtoImport++instance Canonicalize DotProtoImport where canonicalize = id++instance Canonicalize [DotProtoOption] where canonicalize = canonicalSort++instance CanonicalRank DotProtoOption DotProtoOption++instance Canonicalize DotProtoOption where+ canonicalize DotProtoOption{..} = DotProtoOption+ { dotProtoOptionIdentifier = canonicalize dotProtoOptionIdentifier+ , dotProtoOptionValue = canonicalize dotProtoOptionValue+ }++instance Canonicalize DotProtoPackageSpec where+ canonicalize = \case+ DotProtoPackageSpec name -> DotProtoPackageSpec (canonicalize name)+ DotProtoNoPackage -> DotProtoNoPackage++instance Canonicalize [DotProtoDefinition] where canonicalize = canonicalSort++instance CanonicalRank DotProtoDefinition (Int, DotProtoIdentifier) where+ canonicalRank = \case+ DotProtoEnum name _ -> (1, name)+ DotProtoMessage name _ -> (2, name)+ DotProtoService name _ -> (3, name)++instance Canonicalize DotProtoDefinition where+ canonicalize = \case+ DotProtoMessage name parts ->+ DotProtoMessage (canonicalize name) (canonicalize parts)+ DotProtoEnum name parts ->+ DotProtoEnum (canonicalize name) (canonicalize parts)+ DotProtoService name parts ->+ DotProtoService (canonicalize name) (canonicalize parts)++instance Canonicalize [DotProtoMessagePart] where+ canonicalize parts = canonicalSort (resNumbers ++ resNames ++ other)+ where+ (reservations, other) = flip foldMap parts $ \case+ DotProtoMessageReserved fs -> (fs, [])+ part -> ([], [part])++ resNumbers = reserve $ filter (not . isName) reservations+ resNames = reserve $ filter isName reservations++ reserve [] = []+ reserve fs = [DotProtoMessageReserved fs]++ isName = \case+ SingleField _ -> False+ FieldRange _ _ -> False+ ReservedIdentifier _ -> True++instance CanonicalRank DotProtoMessagePart+ (Either (Either (Int, DotProtoIdentifier) ())+ (Maybe FieldNumber)) where+ canonicalRank = \case+ DotProtoMessageField f -> Right (canonicalRank f)+ DotProtoMessageOneOf _ fs -> Right (canonicalRank fs)+ DotProtoMessageDefinition d -> Left (Left (canonicalRank d))+ DotProtoMessageReserved _fs -> Left (Right ())+ -- We use '()' here because 'Canonicalize [DotProtoMessagePart]'+ -- collapses all of the 'DotProtoMessageReserved's into just one.++instance Canonicalize DotProtoMessagePart where+ canonicalize = \case+ DotProtoMessageField f ->+ DotProtoMessageField (canonicalize f)+ DotProtoMessageOneOf n fs ->+ DotProtoMessageOneOf (canonicalize n) (canonicalize fs)+ DotProtoMessageDefinition d ->+ DotProtoMessageDefinition (canonicalize d)+ DotProtoMessageReserved fs ->+ DotProtoMessageReserved (canonicalize fs)++instance CanonicalRank [DotProtoField] (Maybe FieldNumber) where+ canonicalRank =+ fmap getMin . getOption . foldMap (Option . fmap Min . canonicalRank)++instance Canonicalize [DotProtoField] where+ canonicalize = canonicalSort . filter keep+ where+ keep DotProtoEmptyField = False+ keep _ = True++instance CanonicalRank DotProtoField (Maybe FieldNumber) where+ canonicalRank = \case+ DotProtoField{..} -> Just dotProtoFieldNumber+ DotProtoEmptyField -> Nothing++instance Canonicalize DotProtoField where+ canonicalize DotProtoField{..} = DotProtoField+ { dotProtoFieldNumber = dotProtoFieldNumber+ , dotProtoFieldType = canonicalize dotProtoFieldType+ , dotProtoFieldName = canonicalize dotProtoFieldName+ , dotProtoFieldOptions = canonicalize dotProtoFieldOptions+ , dotProtoFieldComment = Nothing -- In future we might add a command-line+ -- option to preserve comments.+ }+ canonicalize DotProtoEmptyField = DotProtoEmptyField++instance Canonicalize DotProtoType where canonicalize = id++instance Canonicalize [DotProtoReservedField] where+ canonicalize fields = numbers ++ names+ where+ (rangeList, nameList) = flip foldMap fields $ \case+ SingleField number -> ([(number, number)], [])+ FieldRange lo hi -> ([(lo, hi)], [])+ ReservedIdentifier name -> ([], [name])++ names = map ReservedIdentifier (unique (sort nameList))++ unique [] = []+ unique [n] = [n]+ unique (x : xs@(y : _)) = (if x == y then id else (x :)) (unique xs)++ numbers = map reserveNumbers (toRangeList (fromRangeList rangeList))++ reserveNumbers (lo, hi) | lo == hi = SingleField lo+ | otherwise = FieldRange lo hi++instance Canonicalize [DotProtoEnumPart] where+ canonicalize = canonicalSort . filter keep+ where+ keep DotProtoEnumEmpty = False+ keep _ = True++instance CanonicalRank DotProtoEnumPart+ (Either (Maybe DotProtoOption) DotProtoEnumValue) where+ canonicalRank = \case+ DotProtoEnumField _ value _ -> Right value+ DotProtoEnumOption option -> Left (Just option)+ DotProtoEnumEmpty -> Left Nothing++instance Canonicalize DotProtoEnumPart where+ canonicalize = \case+ DotProtoEnumField name value opts ->+ DotProtoEnumField (canonicalize name) value (map canonicalize opts)+ DotProtoEnumOption option ->+ DotProtoEnumOption (canonicalize option)+ DotProtoEnumEmpty ->+ DotProtoEnumEmpty++instance Canonicalize [DotProtoServicePart] where+ canonicalize = canonicalSort . filter keep+ where+ keep DotProtoServiceEmpty = False+ keep _ = True++instance CanonicalRank DotProtoServicePart+ (Either (Maybe DotProtoOption) DotProtoIdentifier) where+ canonicalRank = \case+ DotProtoServiceRPC name _ _ _ -> Right name+ DotProtoServiceOption option -> Left (Just option)+ DotProtoServiceEmpty -> Left Nothing++instance Canonicalize DotProtoServicePart where+ canonicalize = \case+ DotProtoServiceRPC name (reqN, reqS) (rspN, rspS) options ->+ DotProtoServiceRPC (canonicalize name)+ (canonicalize reqN, reqS)+ (canonicalize rspN, rspS)+ (canonicalize options)+ DotProtoServiceOption option ->+ DotProtoServiceOption (canonicalize option)+ DotProtoServiceEmpty ->+ DotProtoServiceEmpty++instance Canonicalize DotProtoValue where+ canonicalize = \case+ Identifier name -> Identifier (canonicalize name)+ StringLit str -> StringLit str+ IntLit j -> IntLit j+ FloatLit x -> FloatLit x+ BoolLit b -> BoolLit b++instance Canonicalize DotProtoIdentifier where+ canonicalize = \case+ Single part -> Single part+ Dots (Path [part]) -> Single part+ Dots path -> Dots path+ Qualified x y -> Qualified (canonicalize x) (canonicalize y)+ Anonymous -> Anonymous
+ tools/compile-proto-file/Main.hs view
@@ -0,0 +1,28 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeOperators #-}++import Options.Generic+import Prelude hiding (FilePath)+import Proto3.Suite.DotProto.Generate+import Turtle (FilePath)++data Args w = Args+ { out :: w ::: FilePath <?> "Output directory path where generated Haskell modules will be written (directory is created if it does not exist; note that files in the output directory may be overwritten!)"+ , includeDir :: w ::: [FilePath] <?> "Path to search for included .proto files (can be repeated, and paths will be searched in order; the current directory is used if this option is not provided)"+ , proto :: w ::: FilePath <?> "Path to input .proto file"+ , extraInstanceFile :: w ::: [FilePath] <?> "Additional file to provide instances that would otherwise be generated. Can be used multiple times. Types for which instance overrides are given must be fully qualified."+ } deriving Generic+instance ParseRecord (Args Wrapped)+deriving instance Show (Args Unwrapped)++main :: IO ()+main = do+ Args{..} :: Args Unwrapped <- unwrapRecord "Compiles a .proto file to a Haskell module"+ compileDotProtoFileOrDie extraInstanceFile out includeDir proto