diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/gen/TestProto.hs b/gen/TestProto.hs new file mode 100644 --- /dev/null +++ b/gen/TestProto.hs @@ -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 diff --git a/gen/TestProtoImport.hs b/gen/TestProtoImport.hs new file mode 100644 --- /dev/null +++ b/gen/TestProtoImport.hs @@ -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 diff --git a/gen/TestProtoOneof.hs b/gen/TestProtoOneof.hs new file mode 100644 --- /dev/null +++ b/gen/TestProtoOneof.hs @@ -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 diff --git a/gen/TestProtoOneofImport.hs b/gen/TestProtoOneofImport.hs new file mode 100644 --- /dev/null +++ b/gen/TestProtoOneofImport.hs @@ -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 diff --git a/proto3-suite.cabal b/proto3-suite.cabal new file mode 100644 --- /dev/null +++ b/proto3-suite.cabal @@ -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 diff --git a/src/Proto3/Suite.hs b/src/Proto3/Suite.hs new file mode 100644 --- /dev/null +++ b/src/Proto3/Suite.hs @@ -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 diff --git a/src/Proto3/Suite/Class.hs b/src/Proto3/Suite/Class.hs new file mode 100644 --- /dev/null +++ b/src/Proto3/Suite/Class.hs @@ -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) diff --git a/src/Proto3/Suite/DhallPB.hs b/src/Proto3/Suite/DhallPB.hs new file mode 100644 --- /dev/null +++ b/src/Proto3/Suite/DhallPB.hs @@ -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 diff --git a/src/Proto3/Suite/DotProto.hs b/src/Proto3/Suite/DotProto.hs new file mode 100644 --- /dev/null +++ b/src/Proto3/Suite/DotProto.hs @@ -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 diff --git a/src/Proto3/Suite/DotProto/AST.hs b/src/Proto3/Suite/DotProto/AST.hs new file mode 100644 --- /dev/null +++ b/src/Proto3/Suite/DotProto/AST.hs @@ -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 diff --git a/src/Proto3/Suite/DotProto/Generate.hs b/src/Proto3/Suite/DotProto/Generate.hs new file mode 100644 --- /dev/null +++ b/src/Proto3/Suite/DotProto/Generate.hs @@ -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 = ( :: Options -> Value) + -- > in \option -> if optEmitNamedOneof option + -- > then ("Foo" .= (PB.objectOrNull [encodeFoo] option)) option + -- > else encodeFoo option + -- > ) + -- > , + -- > , + -- > ] + 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 = + -- 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 "" 0 0 + +__nowarn_unused :: a +__nowarn_unused = subfieldType `undefined` subfieldOptions `undefined` oneofType diff --git a/src/Proto3/Suite/DotProto/Generate/Swagger.hs b/src/Proto3/Suite/DotProto/Generate/Swagger.hs new file mode 100644 --- /dev/null +++ b/src/Proto3/Suite/DotProto/Generate/Swagger.hs @@ -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) diff --git a/src/Proto3/Suite/DotProto/Internal.hs b/src/Proto3/Suite/DotProto/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Proto3/Suite/DotProto/Internal.hs @@ -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) diff --git a/src/Proto3/Suite/DotProto/Parsing.hs b/src/Proto3/Suite/DotProto/Parsing.hs new file mode 100644 --- /dev/null +++ b/src/Proto3/Suite/DotProto/Parsing.hs @@ -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 diff --git a/src/Proto3/Suite/DotProto/Rendering.hs b/src/Proto3/Suite/DotProto/Rendering.hs new file mode 100644 --- /dev/null +++ b/src/Proto3/Suite/DotProto/Rendering.hs @@ -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 []) diff --git a/src/Proto3/Suite/JSONPB.hs b/src/Proto3/Suite/JSONPB.hs new file mode 100644 --- /dev/null +++ b/src/Proto3/Suite/JSONPB.hs @@ -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 diff --git a/src/Proto3/Suite/JSONPB/Class.hs b/src/Proto3/Suite/JSONPB/Class.hs new file mode 100644 --- /dev/null +++ b/src/Proto3/Suite/JSONPB/Class.hs @@ -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 diff --git a/src/Proto3/Suite/Tutorial.hs b/src/Proto3/Suite/Tutorial.hs new file mode 100644 --- /dev/null +++ b/src/Proto3/Suite/Tutorial.hs @@ -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]) diff --git a/src/Proto3/Suite/Types.hs b/src/Proto3/Suite/Types.hs new file mode 100644 --- /dev/null +++ b/src/Proto3/Suite/Types.hs @@ -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 diff --git a/test-files/all_packed_types.bin b/test-files/all_packed_types.bin new file mode 100644 Binary files /dev/null and b/test-files/all_packed_types.bin differ diff --git a/test-files/multiple_fields.bin b/test-files/multiple_fields.bin new file mode 100644 Binary files /dev/null and b/test-files/multiple_fields.bin differ diff --git a/test-files/signedints.bin b/test-files/signedints.bin new file mode 100644 --- /dev/null +++ b/test-files/signedints.bin @@ -0,0 +1,1 @@ +S§ diff --git a/test-files/trivial.bin b/test-files/trivial.bin new file mode 100644 --- /dev/null +++ b/test-files/trivial.bin @@ -0,0 +1,1 @@ +{ diff --git a/test-files/trivial_negative.bin b/test-files/trivial_negative.bin new file mode 100644 --- /dev/null +++ b/test-files/trivial_negative.bin @@ -0,0 +1,1 @@ +ÿÿÿÿÿÿÿÿÿ diff --git a/test-files/with_bytes.bin b/test-files/with_bytes.bin new file mode 100644 --- /dev/null +++ b/test-files/with_bytes.bin @@ -0,0 +1,2 @@ + +abcabc123 diff --git a/test-files/with_enum0.bin b/test-files/with_enum0.bin new file mode 100644 --- /dev/null +++ b/test-files/with_enum0.bin diff --git a/test-files/with_enum1.bin b/test-files/with_enum1.bin new file mode 100644 --- /dev/null +++ b/test-files/with_enum1.bin @@ -0,0 +1,1 @@ + diff --git a/test-files/with_fixed.bin b/test-files/with_fixed.bin new file mode 100644 Binary files /dev/null and b/test-files/with_fixed.bin differ diff --git a/test-files/with_nesting.bin b/test-files/with_nesting.bin new file mode 100644 --- /dev/null +++ b/test-files/with_nesting.bin @@ -0,0 +1,3 @@ + + +123abcÀÄ diff --git a/test-files/with_nesting_ints.bin b/test-files/with_nesting_ints.bin new file mode 100644 --- /dev/null +++ b/test-files/with_nesting_ints.bin @@ -0,0 +1,3 @@ + + + diff --git a/test-files/with_nesting_maybe.bin b/test-files/with_nesting_maybe.bin new file mode 100644 --- /dev/null +++ b/test-files/with_nesting_maybe.bin @@ -0,0 +1,3 @@ + + +123abcÀÄ diff --git a/test-files/with_nesting_repeated.bin b/test-files/with_nesting_repeated.bin new file mode 100644 Binary files /dev/null and b/test-files/with_nesting_repeated.bin differ diff --git a/test-files/with_packing.bin b/test-files/with_packing.bin new file mode 100644 --- /dev/null +++ b/test-files/with_packing.bin @@ -0,0 +1,1 @@ + diff --git a/test-files/with_repetition.bin b/test-files/with_repetition.bin new file mode 100644 --- /dev/null +++ b/test-files/with_repetition.bin @@ -0,0 +1,2 @@ + + diff --git a/tests/ArbitraryGeneratedTestTypes.hs b/tests/ArbitraryGeneratedTestTypes.hs new file mode 100644 --- /dev/null +++ b/tests/ArbitraryGeneratedTestTypes.hs @@ -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 + ] diff --git a/tests/Main.hs b/tests/Main.hs new file mode 100644 --- /dev/null +++ b/tests/Main.hs @@ -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/" diff --git a/tests/TestCodeGen.hs b/tests/TestCodeGen.hs new file mode 100644 --- /dev/null +++ b/tests/TestCodeGen.hs @@ -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))) diff --git a/tests/TestDhall.hs b/tests/TestDhall.hs new file mode 100644 --- /dev/null +++ b/tests/TestDhall.hs @@ -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 diff --git a/tests/decode.sh b/tests/decode.sh new file mode 100644 --- /dev/null +++ b/tests/decode.sh @@ -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 diff --git a/tests/encode.sh b/tests/encode.sh new file mode 100644 --- /dev/null +++ b/tests/encode.sh @@ -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 diff --git a/tools/canonicalize-proto-file/Main.hs b/tools/canonicalize-proto-file/Main.hs new file mode 100644 --- /dev/null +++ b/tools/canonicalize-proto-file/Main.hs @@ -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 diff --git a/tools/compile-proto-file/Main.hs b/tools/compile-proto-file/Main.hs new file mode 100644 --- /dev/null +++ b/tools/compile-proto-file/Main.hs @@ -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