diff --git a/gen/TestProto.hs b/gen/TestProto.hs --- a/gen/TestProto.hs +++ b/gen/TestProto.hs @@ -1,6 +1,8 @@ {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-unused-imports #-} {-# OPTIONS_GHC -fno-warn-name-shadowing #-} @@ -9,33 +11,39 @@ -- | Generated by Haskell protocol buffer compiler. DO NOT EDIT! module TestProto where import qualified Prelude as Hs -import qualified Proto3.Suite.DhallPB as HsDhallPb -import qualified Proto3.Suite.DotProto as HsProtobuf -import qualified Proto3.Suite.Types as HsProtobuf import qualified Proto3.Suite.Class as HsProtobuf +import qualified Proto3.Suite.DotProto as HsProtobuf import qualified Proto3.Suite.JSONPB as HsJSONPB import Proto3.Suite.JSONPB ((.=), (.:)) +import qualified Proto3.Suite.Types as HsProtobuf import qualified Proto3.Wire as HsProtobuf -import Control.Applicative ((<*>), (<|>), (<$>)) import qualified Control.Applicative as Hs +import Control.Applicative ((<*>), (<|>), (<$>)) +import qualified Control.DeepSeq as Hs import qualified Control.Monad as Hs -import qualified Data.Text.Lazy as Hs (Text) import qualified Data.ByteString as Hs +import qualified Data.Coerce as Hs +import qualified Data.Int as Hs (Int16, Int32, Int64) +import qualified Data.List.NonEmpty as Hs (NonEmpty(..)) +import qualified Data.Map as Hs (Map, mapKeysMonotonic) +import qualified Data.Proxy as Proxy import qualified Data.String as Hs (fromString) +import qualified Data.Text.Lazy as Hs (Text) import qualified Data.Vector as Hs (Vector) -import qualified Data.Int as Hs (Int16, Int32, Int64) import qualified Data.Word as Hs (Word16, Word32, Word64) -import qualified Data.Proxy as Proxy -import qualified GHC.Generics as Hs import qualified GHC.Enum as Hs +import qualified GHC.Generics as Hs +import qualified Unsafe.Coerce as Hs import qualified TestProtoImport data Trivial = Trivial{trivialTrivialField :: Hs.Int32} - deriving (Hs.Show, Hs.Eq, Hs.Ord, Hs.Generic) + deriving (Hs.Show, Hs.Eq, Hs.Ord, Hs.Generic, Hs.NFData) instance HsProtobuf.Named Trivial where nameOf _ = (Hs.fromString "Trivial") +instance HsProtobuf.HasDefault Trivial + instance HsProtobuf.Message Trivial where encodeMessage _ Trivial{trivialTrivialField = trivialTrivialField} = (Hs.mconcat @@ -50,7 +58,7 @@ (HsProtobuf.Prim HsProtobuf.Int32) (HsProtobuf.Single "trivialField") [] - Hs.Nothing)] + "")] instance HsJSONPB.ToJSONPB Trivial where toJSONPB (Trivial f1) = (HsJSONPB.object ["trivialField" .= f1]) @@ -84,10 +92,6 @@ HsJSONPB.insOrdFromList [("trivialField", trivialTrivialField)]}}) -instance HsDhallPb.Interpret Trivial - -instance HsDhallPb.Inject Trivial - data MultipleFields = MultipleFields{multipleFieldsMultiFieldDouble :: Hs.Double, multipleFieldsMultiFieldFloat :: Hs.Float, @@ -95,11 +99,13 @@ multipleFieldsMultiFieldInt64 :: Hs.Int64, multipleFieldsMultiFieldString :: Hs.Text, multipleFieldsMultiFieldBool :: Hs.Bool} - deriving (Hs.Show, Hs.Eq, Hs.Ord, Hs.Generic) + deriving (Hs.Show, Hs.Eq, Hs.Ord, Hs.Generic, Hs.NFData) instance HsProtobuf.Named MultipleFields where nameOf _ = (Hs.fromString "MultipleFields") +instance HsProtobuf.HasDefault MultipleFields + instance HsProtobuf.Message MultipleFields where encodeMessage _ MultipleFields{multipleFieldsMultiFieldDouble = @@ -146,32 +152,32 @@ (HsProtobuf.Prim HsProtobuf.Double) (HsProtobuf.Single "multiFieldDouble") [] - Hs.Nothing), + ""), (HsProtobuf.DotProtoField (HsProtobuf.FieldNumber 2) (HsProtobuf.Prim HsProtobuf.Float) (HsProtobuf.Single "multiFieldFloat") [] - Hs.Nothing), + ""), (HsProtobuf.DotProtoField (HsProtobuf.FieldNumber 3) (HsProtobuf.Prim HsProtobuf.Int32) (HsProtobuf.Single "multiFieldInt32") [] - Hs.Nothing), + ""), (HsProtobuf.DotProtoField (HsProtobuf.FieldNumber 4) (HsProtobuf.Prim HsProtobuf.Int64) (HsProtobuf.Single "multiFieldInt64") [] - Hs.Nothing), + ""), (HsProtobuf.DotProtoField (HsProtobuf.FieldNumber 5) (HsProtobuf.Prim HsProtobuf.String) (HsProtobuf.Single "multiFieldString") [] - Hs.Nothing), + ""), (HsProtobuf.DotProtoField (HsProtobuf.FieldNumber 6) (HsProtobuf.Prim HsProtobuf.Bool) (HsProtobuf.Single "multiFieldBool") [] - Hs.Nothing)] + "")] instance HsJSONPB.ToJSONPB MultipleFields where toJSONPB (MultipleFields f1 f2 f3 f4 f5 f6) @@ -251,33 +257,33 @@ ("multiFieldBool", multipleFieldsMultiFieldBool)]}}) -instance HsDhallPb.Interpret MultipleFields - -instance HsDhallPb.Inject MultipleFields - data SignedInts = SignedInts{signedIntsSigned32 :: Hs.Int32, signedIntsSigned64 :: Hs.Int64} - deriving (Hs.Show, Hs.Eq, Hs.Ord, Hs.Generic) + deriving (Hs.Show, Hs.Eq, Hs.Ord, Hs.Generic, Hs.NFData) instance HsProtobuf.Named SignedInts where nameOf _ = (Hs.fromString "SignedInts") +instance HsProtobuf.HasDefault SignedInts + instance HsProtobuf.Message SignedInts where encodeMessage _ SignedInts{signedIntsSigned32 = signedIntsSigned32, signedIntsSigned64 = signedIntsSigned64} = (Hs.mconcat [(HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 1) - (HsProtobuf.Signed signedIntsSigned32)), + (Hs.coerce @(Hs.Int32) @(HsProtobuf.Signed Hs.Int32) + signedIntsSigned32)), (HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 2) - (HsProtobuf.Signed signedIntsSigned64))]) + (Hs.coerce @(Hs.Int64) @(HsProtobuf.Signed Hs.Int64) + signedIntsSigned64))]) decodeMessage _ = (Hs.pure SignedInts) <*> - ((Hs.pure HsProtobuf.signed) <*> + (Hs.coerce @(_ (HsProtobuf.Signed Hs.Int32)) @(_ Hs.Int32) (HsProtobuf.at HsProtobuf.decodeMessageField (HsProtobuf.FieldNumber 1))) <*> - ((Hs.pure HsProtobuf.signed) <*> + (Hs.coerce @(_ (HsProtobuf.Signed Hs.Int64)) @(_ Hs.Int64) (HsProtobuf.at HsProtobuf.decodeMessageField (HsProtobuf.FieldNumber 2))) dotProto _ @@ -285,12 +291,12 @@ (HsProtobuf.Prim HsProtobuf.SInt32) (HsProtobuf.Single "signed32") [] - Hs.Nothing), + ""), (HsProtobuf.DotProtoField (HsProtobuf.FieldNumber 2) (HsProtobuf.Prim HsProtobuf.SInt64) (HsProtobuf.Single "signed64") [] - Hs.Nothing)] + "")] instance HsJSONPB.ToJSONPB SignedInts where toJSONPB (SignedInts f1 f2) @@ -331,17 +337,15 @@ [("signed32", signedIntsSigned32), ("signed64", signedIntsSigned64)]}}) -instance HsDhallPb.Interpret SignedInts - -instance HsDhallPb.Inject SignedInts - data WithEnum = WithEnum{withEnumEnumField :: HsProtobuf.Enumerated TestProto.WithEnum_TestEnum} - deriving (Hs.Show, Hs.Eq, Hs.Ord, Hs.Generic) + deriving (Hs.Show, Hs.Eq, Hs.Ord, Hs.Generic, Hs.NFData) instance HsProtobuf.Named WithEnum where nameOf _ = (Hs.fromString "WithEnum") +instance HsProtobuf.HasDefault WithEnum + instance HsProtobuf.Message WithEnum where encodeMessage _ WithEnum{withEnumEnumField = withEnumEnumField} = (Hs.mconcat @@ -356,7 +360,7 @@ (HsProtobuf.Prim (HsProtobuf.Named (HsProtobuf.Single "TestEnum"))) (HsProtobuf.Single "enumField") [] - Hs.Nothing)] + "")] instance HsJSONPB.ToJSONPB WithEnum where toJSONPB (WithEnum f1) = (HsJSONPB.object ["enumField" .= f1]) @@ -390,33 +394,34 @@ HsJSONPB.insOrdFromList [("enumField", withEnumEnumField)]}}) -instance HsDhallPb.Interpret WithEnum - -instance HsDhallPb.Inject WithEnum - data WithEnum_TestEnum = WithEnum_TestEnumENUM1 | WithEnum_TestEnumENUM2 | WithEnum_TestEnumENUM3 - deriving (Hs.Show, Hs.Bounded, Hs.Eq, Hs.Ord, Hs.Generic) + deriving (Hs.Show, Hs.Eq, Hs.Generic, Hs.NFData) instance HsProtobuf.Named WithEnum_TestEnum where nameOf _ = (Hs.fromString "WithEnum_TestEnum") -instance Hs.Enum WithEnum_TestEnum where - toEnum 0 = WithEnum_TestEnumENUM1 - toEnum 1 = WithEnum_TestEnumENUM2 - toEnum 2 = WithEnum_TestEnumENUM3 - toEnum i = (Hs.toEnumError "WithEnum_TestEnum" i (0 :: Hs.Int, 2)) - fromEnum (WithEnum_TestEnumENUM1) = 0 - fromEnum (WithEnum_TestEnumENUM2) = 1 - fromEnum (WithEnum_TestEnumENUM3) = 2 - succ (WithEnum_TestEnumENUM1) = WithEnum_TestEnumENUM2 - succ (WithEnum_TestEnumENUM2) = WithEnum_TestEnumENUM3 - succ _ = Hs.succError "WithEnum_TestEnum" - pred (WithEnum_TestEnumENUM2) = WithEnum_TestEnumENUM1 - pred (WithEnum_TestEnumENUM3) = WithEnum_TestEnumENUM2 - pred _ = Hs.predError "WithEnum_TestEnum" +instance HsProtobuf.HasDefault WithEnum_TestEnum +instance Hs.Bounded WithEnum_TestEnum where + minBound = WithEnum_TestEnumENUM1 + maxBound = WithEnum_TestEnumENUM3 + +instance Hs.Ord WithEnum_TestEnum where + compare x y + = Hs.compare (HsProtobuf.fromProtoEnum x) + (HsProtobuf.fromProtoEnum y) + +instance HsProtobuf.ProtoEnum WithEnum_TestEnum where + toProtoEnumMay 0 = Hs.Just WithEnum_TestEnumENUM1 + toProtoEnumMay 1 = Hs.Just WithEnum_TestEnumENUM2 + toProtoEnumMay 2 = Hs.Just WithEnum_TestEnumENUM3 + toProtoEnumMay _ = Hs.Nothing + fromProtoEnum (WithEnum_TestEnumENUM1) = 0 + fromProtoEnum (WithEnum_TestEnumENUM2) = 1 + fromProtoEnum (WithEnum_TestEnumENUM3) = 2 + instance HsJSONPB.ToJSONPB WithEnum_TestEnum where toJSONPB x _ = HsJSONPB.enumFieldString x toEncodingPB x _ = HsJSONPB.enumFieldEncoding x @@ -437,28 +442,29 @@ instance HsJSONPB.FromJSON WithEnum_TestEnum where parseJSON = HsJSONPB.parseJSONPB -instance HsDhallPb.Interpret WithEnum_TestEnum - -instance HsDhallPb.Inject WithEnum_TestEnum - instance HsProtobuf.Finite WithEnum_TestEnum data WithNesting = WithNesting{withNestingNestedMessage :: Hs.Maybe TestProto.WithNesting_Nested} - deriving (Hs.Show, Hs.Eq, Hs.Ord, Hs.Generic) + deriving (Hs.Show, Hs.Eq, Hs.Ord, Hs.Generic, Hs.NFData) instance HsProtobuf.Named WithNesting where nameOf _ = (Hs.fromString "WithNesting") +instance HsProtobuf.HasDefault WithNesting + instance HsProtobuf.Message WithNesting where encodeMessage _ WithNesting{withNestingNestedMessage = withNestingNestedMessage} = (Hs.mconcat [(HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 1) - (HsProtobuf.Nested withNestingNestedMessage))]) + (Hs.coerce @(Hs.Maybe TestProto.WithNesting_Nested) + @(HsProtobuf.Nested TestProto.WithNesting_Nested) + withNestingNestedMessage))]) decodeMessage _ = (Hs.pure WithNesting) <*> - ((Hs.pure HsProtobuf.nested) <*> + (Hs.coerce @(_ (HsProtobuf.Nested TestProto.WithNesting_Nested)) + @(_ (Hs.Maybe TestProto.WithNesting_Nested)) (HsProtobuf.at HsProtobuf.decodeMessageField (HsProtobuf.FieldNumber 1))) dotProto _ @@ -466,7 +472,7 @@ (HsProtobuf.Prim (HsProtobuf.Named (HsProtobuf.Single "Nested"))) (HsProtobuf.Single "nestedMessage") [] - Hs.Nothing)] + "")] instance HsJSONPB.ToJSONPB WithNesting where toJSONPB (WithNesting f1) @@ -504,20 +510,18 @@ [("nestedMessage", withNestingNestedMessage)]}}) -instance HsDhallPb.Interpret WithNesting - -instance HsDhallPb.Inject WithNesting - data WithNesting_Nested = WithNesting_Nested{withNesting_NestedNestedField1 :: Hs.Text, withNesting_NestedNestedField2 :: Hs.Int32, withNesting_NestedNestedPacked :: Hs.Vector Hs.Int32, withNesting_NestedNestedUnpacked :: Hs.Vector Hs.Int32} - deriving (Hs.Show, Hs.Eq, Hs.Ord, Hs.Generic) + deriving (Hs.Show, Hs.Eq, Hs.Ord, Hs.Generic, Hs.NFData) instance HsProtobuf.Named WithNesting_Nested where nameOf _ = (Hs.fromString "WithNesting_Nested") +instance HsProtobuf.HasDefault WithNesting_Nested + instance HsProtobuf.Message WithNesting_Nested where encodeMessage _ WithNesting_Nested{withNesting_NestedNestedField1 = @@ -532,9 +536,11 @@ (HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 2) withNesting_NestedNestedField2), (HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 3) - (HsProtobuf.PackedVec withNesting_NestedNestedPacked)), + (Hs.coerce @(Hs.Vector Hs.Int32) @(HsProtobuf.PackedVec Hs.Int32) + withNesting_NestedNestedPacked)), (HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 4) - (HsProtobuf.UnpackedVec withNesting_NestedNestedUnpacked))]) + (Hs.coerce @(Hs.Vector Hs.Int32) @(HsProtobuf.UnpackedVec Hs.Int32) + withNesting_NestedNestedUnpacked))]) decodeMessage _ = (Hs.pure WithNesting_Nested) <*> (HsProtobuf.at HsProtobuf.decodeMessageField @@ -543,11 +549,13 @@ (HsProtobuf.at HsProtobuf.decodeMessageField (HsProtobuf.FieldNumber 2)) <*> - ((Hs.pure HsProtobuf.packedvec) <*> + (Hs.coerce @(_ (HsProtobuf.PackedVec Hs.Int32)) + @(_ (Hs.Vector Hs.Int32)) (HsProtobuf.at HsProtobuf.decodeMessageField (HsProtobuf.FieldNumber 3))) <*> - ((Hs.pure HsProtobuf.unpackedvec) <*> + (Hs.coerce @(_ (HsProtobuf.UnpackedVec Hs.Int32)) + @(_ (Hs.Vector Hs.Int32)) (HsProtobuf.at HsProtobuf.decodeMessageField (HsProtobuf.FieldNumber 4))) dotProto _ @@ -555,24 +563,24 @@ (HsProtobuf.Prim HsProtobuf.String) (HsProtobuf.Single "nestedField1") [] - Hs.Nothing), + ""), (HsProtobuf.DotProtoField (HsProtobuf.FieldNumber 2) (HsProtobuf.Prim HsProtobuf.Int32) (HsProtobuf.Single "nestedField2") [] - Hs.Nothing), + ""), (HsProtobuf.DotProtoField (HsProtobuf.FieldNumber 3) (HsProtobuf.Repeated HsProtobuf.Int32) (HsProtobuf.Single "nestedPacked") [(HsProtobuf.DotProtoOption (HsProtobuf.Single "packed") (HsProtobuf.BoolLit Hs.True))] - Hs.Nothing), + ""), (HsProtobuf.DotProtoField (HsProtobuf.FieldNumber 4) (HsProtobuf.Repeated HsProtobuf.Int32) (HsProtobuf.Single "nestedUnpacked") [(HsProtobuf.DotProtoOption (HsProtobuf.Single "packed") (HsProtobuf.BoolLit Hs.False))] - Hs.Nothing)] + "")] instance HsJSONPB.ToJSONPB WithNesting_Nested where toJSONPB (WithNesting_Nested f1 f2 f3 f4) @@ -634,27 +642,29 @@ ("nestedUnpacked", withNesting_NestedNestedUnpacked)]}}) -instance HsDhallPb.Interpret WithNesting_Nested - -instance HsDhallPb.Inject WithNesting_Nested - data WithNestingRepeated = WithNestingRepeated{withNestingRepeatedNestedMessages :: Hs.Vector TestProto.WithNestingRepeated_Nested} - deriving (Hs.Show, Hs.Eq, Hs.Ord, Hs.Generic) + deriving (Hs.Show, Hs.Eq, Hs.Ord, Hs.Generic, Hs.NFData) instance HsProtobuf.Named WithNestingRepeated where nameOf _ = (Hs.fromString "WithNestingRepeated") +instance HsProtobuf.HasDefault WithNestingRepeated + instance HsProtobuf.Message WithNestingRepeated where encodeMessage _ WithNestingRepeated{withNestingRepeatedNestedMessages = withNestingRepeatedNestedMessages} = (Hs.mconcat [(HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 1) - (HsProtobuf.NestedVec withNestingRepeatedNestedMessages))]) + (Hs.coerce @(Hs.Vector TestProto.WithNestingRepeated_Nested) + @(HsProtobuf.NestedVec TestProto.WithNestingRepeated_Nested) + withNestingRepeatedNestedMessages))]) decodeMessage _ = (Hs.pure WithNestingRepeated) <*> - ((Hs.pure HsProtobuf.nestedvec) <*> + (Hs.coerce + @(_ (HsProtobuf.NestedVec TestProto.WithNestingRepeated_Nested)) + @(_ (Hs.Vector TestProto.WithNestingRepeated_Nested)) (HsProtobuf.at HsProtobuf.decodeMessageField (HsProtobuf.FieldNumber 1))) dotProto _ @@ -663,7 +673,7 @@ (HsProtobuf.Named (HsProtobuf.Single "Nested"))) (HsProtobuf.Single "nestedMessages") [] - Hs.Nothing)] + "")] instance HsJSONPB.ToJSONPB WithNestingRepeated where toJSONPB (WithNestingRepeated f1) @@ -703,10 +713,6 @@ [("nestedMessages", withNestingRepeatedNestedMessages)]}}) -instance HsDhallPb.Interpret WithNestingRepeated - -instance HsDhallPb.Inject WithNestingRepeated - data WithNestingRepeated_Nested = WithNestingRepeated_Nested{withNestingRepeated_NestedNestedField1 :: Hs.Text, withNestingRepeated_NestedNestedField2 @@ -715,11 +721,13 @@ :: Hs.Vector Hs.Int32, withNestingRepeated_NestedNestedUnpacked :: Hs.Vector Hs.Int32} - deriving (Hs.Show, Hs.Eq, Hs.Ord, Hs.Generic) + deriving (Hs.Show, Hs.Eq, Hs.Ord, Hs.Generic, Hs.NFData) instance HsProtobuf.Named WithNestingRepeated_Nested where nameOf _ = (Hs.fromString "WithNestingRepeated_Nested") +instance HsProtobuf.HasDefault WithNestingRepeated_Nested + instance HsProtobuf.Message WithNestingRepeated_Nested where encodeMessage _ WithNestingRepeated_Nested{withNestingRepeated_NestedNestedField1 = @@ -736,9 +744,10 @@ (HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 2) withNestingRepeated_NestedNestedField2), (HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 3) - (HsProtobuf.PackedVec withNestingRepeated_NestedNestedPacked)), + (Hs.coerce @(Hs.Vector Hs.Int32) @(HsProtobuf.PackedVec Hs.Int32) + withNestingRepeated_NestedNestedPacked)), (HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 4) - (HsProtobuf.UnpackedVec + (Hs.coerce @(Hs.Vector Hs.Int32) @(HsProtobuf.UnpackedVec Hs.Int32) withNestingRepeated_NestedNestedUnpacked))]) decodeMessage _ = (Hs.pure WithNestingRepeated_Nested) <*> @@ -748,11 +757,13 @@ (HsProtobuf.at HsProtobuf.decodeMessageField (HsProtobuf.FieldNumber 2)) <*> - ((Hs.pure HsProtobuf.packedvec) <*> + (Hs.coerce @(_ (HsProtobuf.PackedVec Hs.Int32)) + @(_ (Hs.Vector Hs.Int32)) (HsProtobuf.at HsProtobuf.decodeMessageField (HsProtobuf.FieldNumber 3))) <*> - ((Hs.pure HsProtobuf.unpackedvec) <*> + (Hs.coerce @(_ (HsProtobuf.UnpackedVec Hs.Int32)) + @(_ (Hs.Vector Hs.Int32)) (HsProtobuf.at HsProtobuf.decodeMessageField (HsProtobuf.FieldNumber 4))) dotProto _ @@ -760,24 +771,24 @@ (HsProtobuf.Prim HsProtobuf.String) (HsProtobuf.Single "nestedField1") [] - Hs.Nothing), + ""), (HsProtobuf.DotProtoField (HsProtobuf.FieldNumber 2) (HsProtobuf.Prim HsProtobuf.Int32) (HsProtobuf.Single "nestedField2") [] - Hs.Nothing), + ""), (HsProtobuf.DotProtoField (HsProtobuf.FieldNumber 3) (HsProtobuf.Repeated HsProtobuf.Int32) (HsProtobuf.Single "nestedPacked") [(HsProtobuf.DotProtoOption (HsProtobuf.Single "packed") (HsProtobuf.BoolLit Hs.True))] - Hs.Nothing), + ""), (HsProtobuf.DotProtoField (HsProtobuf.FieldNumber 4) (HsProtobuf.Repeated HsProtobuf.Int32) (HsProtobuf.Single "nestedUnpacked") [(HsProtobuf.DotProtoOption (HsProtobuf.Single "packed") (HsProtobuf.BoolLit Hs.False))] - Hs.Nothing)] + "")] instance HsJSONPB.ToJSONPB WithNestingRepeated_Nested where toJSONPB (WithNestingRepeated_Nested f1 f2 f3 f4) @@ -842,17 +853,15 @@ ("nestedUnpacked", withNestingRepeated_NestedNestedUnpacked)]}}) -instance HsDhallPb.Interpret WithNestingRepeated_Nested - -instance HsDhallPb.Inject WithNestingRepeated_Nested - data NestedInts = NestedInts{nestedIntsNestedInt1 :: Hs.Int32, nestedIntsNestedInt2 :: Hs.Int32} - deriving (Hs.Show, Hs.Eq, Hs.Ord, Hs.Generic) + deriving (Hs.Show, Hs.Eq, Hs.Ord, Hs.Generic, Hs.NFData) instance HsProtobuf.Named NestedInts where nameOf _ = (Hs.fromString "NestedInts") +instance HsProtobuf.HasDefault NestedInts + instance HsProtobuf.Message NestedInts where encodeMessage _ NestedInts{nestedIntsNestedInt1 = nestedIntsNestedInt1, @@ -874,12 +883,12 @@ (HsProtobuf.Prim HsProtobuf.Int32) (HsProtobuf.Single "nestedInt1") [] - Hs.Nothing), + ""), (HsProtobuf.DotProtoField (HsProtobuf.FieldNumber 2) (HsProtobuf.Prim HsProtobuf.Int32) (HsProtobuf.Single "nestedInt2") [] - Hs.Nothing)] + "")] instance HsJSONPB.ToJSONPB NestedInts where toJSONPB (NestedInts f1 f2) @@ -921,27 +930,28 @@ [("nestedInt1", nestedIntsNestedInt1), ("nestedInt2", nestedIntsNestedInt2)]}}) -instance HsDhallPb.Interpret NestedInts - -instance HsDhallPb.Inject NestedInts - data WithNestingRepeatedInts = WithNestingRepeatedInts{withNestingRepeatedIntsNestedInts :: Hs.Vector TestProto.NestedInts} - deriving (Hs.Show, Hs.Eq, Hs.Ord, Hs.Generic) + deriving (Hs.Show, Hs.Eq, Hs.Ord, Hs.Generic, Hs.NFData) instance HsProtobuf.Named WithNestingRepeatedInts where nameOf _ = (Hs.fromString "WithNestingRepeatedInts") +instance HsProtobuf.HasDefault WithNestingRepeatedInts + instance HsProtobuf.Message WithNestingRepeatedInts where encodeMessage _ WithNestingRepeatedInts{withNestingRepeatedIntsNestedInts = withNestingRepeatedIntsNestedInts} = (Hs.mconcat [(HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 1) - (HsProtobuf.NestedVec withNestingRepeatedIntsNestedInts))]) + (Hs.coerce @(Hs.Vector TestProto.NestedInts) + @(HsProtobuf.NestedVec TestProto.NestedInts) + withNestingRepeatedIntsNestedInts))]) decodeMessage _ = (Hs.pure WithNestingRepeatedInts) <*> - ((Hs.pure HsProtobuf.nestedvec) <*> + (Hs.coerce @(_ (HsProtobuf.NestedVec TestProto.NestedInts)) + @(_ (Hs.Vector TestProto.NestedInts)) (HsProtobuf.at HsProtobuf.decodeMessageField (HsProtobuf.FieldNumber 1))) dotProto _ @@ -950,7 +960,7 @@ (HsProtobuf.Named (HsProtobuf.Single "NestedInts"))) (HsProtobuf.Single "nestedInts") [] - Hs.Nothing)] + "")] instance HsJSONPB.ToJSONPB WithNestingRepeatedInts where toJSONPB (WithNestingRepeatedInts f1) @@ -989,27 +999,28 @@ [("nestedInts", withNestingRepeatedIntsNestedInts)]}}) -instance HsDhallPb.Interpret WithNestingRepeatedInts - -instance HsDhallPb.Inject WithNestingRepeatedInts - data WithNestingInts = WithNestingInts{withNestingIntsNestedInts :: Hs.Maybe TestProto.NestedInts} - deriving (Hs.Show, Hs.Eq, Hs.Ord, Hs.Generic) + deriving (Hs.Show, Hs.Eq, Hs.Ord, Hs.Generic, Hs.NFData) instance HsProtobuf.Named WithNestingInts where nameOf _ = (Hs.fromString "WithNestingInts") +instance HsProtobuf.HasDefault WithNestingInts + instance HsProtobuf.Message WithNestingInts where encodeMessage _ WithNestingInts{withNestingIntsNestedInts = withNestingIntsNestedInts} = (Hs.mconcat [(HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 1) - (HsProtobuf.Nested withNestingIntsNestedInts))]) + (Hs.coerce @(Hs.Maybe TestProto.NestedInts) + @(HsProtobuf.Nested TestProto.NestedInts) + withNestingIntsNestedInts))]) decodeMessage _ = (Hs.pure WithNestingInts) <*> - ((Hs.pure HsProtobuf.nested) <*> + (Hs.coerce @(_ (HsProtobuf.Nested TestProto.NestedInts)) + @(_ (Hs.Maybe TestProto.NestedInts)) (HsProtobuf.at HsProtobuf.decodeMessageField (HsProtobuf.FieldNumber 1))) dotProto _ @@ -1018,7 +1029,7 @@ (HsProtobuf.Named (HsProtobuf.Single "NestedInts"))) (HsProtobuf.Single "nestedInts") [] - Hs.Nothing)] + "")] instance HsJSONPB.ToJSONPB WithNestingInts where toJSONPB (WithNestingInts f1) @@ -1056,27 +1067,27 @@ [("nestedInts", withNestingIntsNestedInts)]}}) -instance HsDhallPb.Interpret WithNestingInts - -instance HsDhallPb.Inject WithNestingInts - data WithRepetition = WithRepetition{withRepetitionRepeatedField1 :: Hs.Vector Hs.Int32} - deriving (Hs.Show, Hs.Eq, Hs.Ord, Hs.Generic) + deriving (Hs.Show, Hs.Eq, Hs.Ord, Hs.Generic, Hs.NFData) instance HsProtobuf.Named WithRepetition where nameOf _ = (Hs.fromString "WithRepetition") +instance HsProtobuf.HasDefault WithRepetition + instance HsProtobuf.Message WithRepetition where encodeMessage _ WithRepetition{withRepetitionRepeatedField1 = withRepetitionRepeatedField1} = (Hs.mconcat [(HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 1) - (HsProtobuf.PackedVec withRepetitionRepeatedField1))]) + (Hs.coerce @(Hs.Vector Hs.Int32) @(HsProtobuf.PackedVec Hs.Int32) + withRepetitionRepeatedField1))]) decodeMessage _ = (Hs.pure WithRepetition) <*> - ((Hs.pure HsProtobuf.packedvec) <*> + (Hs.coerce @(_ (HsProtobuf.PackedVec Hs.Int32)) + @(_ (Hs.Vector Hs.Int32)) (HsProtobuf.at HsProtobuf.decodeMessageField (HsProtobuf.FieldNumber 1))) dotProto _ @@ -1084,7 +1095,7 @@ (HsProtobuf.Repeated HsProtobuf.Int32) (HsProtobuf.Single "repeatedField1") [] - Hs.Nothing)] + "")] instance HsJSONPB.ToJSONPB WithRepetition where toJSONPB (WithRepetition f1) @@ -1122,20 +1133,16 @@ [("repeatedField1", withRepetitionRepeatedField1)]}}) -instance HsDhallPb.Interpret WithRepetition - -instance HsDhallPb.Inject WithRepetition - -data WithFixed = WithFixed{withFixedFixed1 :: - HsProtobuf.Fixed Hs.Word32, - withFixedFixed2 :: HsProtobuf.Fixed Hs.Int32, - withFixedFixed3 :: HsProtobuf.Fixed Hs.Word64, - withFixedFixed4 :: HsProtobuf.Fixed Hs.Int64} - deriving (Hs.Show, Hs.Eq, Hs.Ord, Hs.Generic) +data WithFixed = WithFixed{withFixedFixed1 :: Hs.Word32, + withFixedFixed2 :: Hs.Int32, withFixedFixed3 :: Hs.Word64, + withFixedFixed4 :: Hs.Int64} + deriving (Hs.Show, Hs.Eq, Hs.Ord, Hs.Generic, Hs.NFData) instance HsProtobuf.Named WithFixed where nameOf _ = (Hs.fromString "WithFixed") +instance HsProtobuf.HasDefault WithFixed + instance HsProtobuf.Message WithFixed where encodeMessage _ WithFixed{withFixedFixed1 = withFixedFixed1, @@ -1144,26 +1151,36 @@ withFixedFixed4 = withFixedFixed4} = (Hs.mconcat [(HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 1) - withFixedFixed1), + (Hs.coerce @(Hs.Word32) @(HsProtobuf.Fixed Hs.Word32) + withFixedFixed1)), (HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 2) - (HsProtobuf.Signed withFixedFixed2)), + (Hs.coerce @(Hs.Int32) + @(HsProtobuf.Signed (HsProtobuf.Fixed Hs.Int32)) + withFixedFixed2)), (HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 3) - withFixedFixed3), + (Hs.coerce @(Hs.Word64) @(HsProtobuf.Fixed Hs.Word64) + withFixedFixed3)), (HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 4) - (HsProtobuf.Signed withFixedFixed4))]) + (Hs.coerce @(Hs.Int64) + @(HsProtobuf.Signed (HsProtobuf.Fixed Hs.Int64)) + withFixedFixed4))]) decodeMessage _ = (Hs.pure WithFixed) <*> - (HsProtobuf.at HsProtobuf.decodeMessageField - (HsProtobuf.FieldNumber 1)) + (Hs.coerce @(_ (HsProtobuf.Fixed Hs.Word32)) @(_ Hs.Word32) + (HsProtobuf.at HsProtobuf.decodeMessageField + (HsProtobuf.FieldNumber 1))) <*> - ((Hs.pure HsProtobuf.signed) <*> + (Hs.coerce @(_ (HsProtobuf.Signed (HsProtobuf.Fixed Hs.Int32))) + @(_ Hs.Int32) (HsProtobuf.at HsProtobuf.decodeMessageField (HsProtobuf.FieldNumber 2))) <*> - (HsProtobuf.at HsProtobuf.decodeMessageField - (HsProtobuf.FieldNumber 3)) + (Hs.coerce @(_ (HsProtobuf.Fixed Hs.Word64)) @(_ Hs.Word64) + (HsProtobuf.at HsProtobuf.decodeMessageField + (HsProtobuf.FieldNumber 3))) <*> - ((Hs.pure HsProtobuf.signed) <*> + (Hs.coerce @(_ (HsProtobuf.Signed (HsProtobuf.Fixed Hs.Int64))) + @(_ Hs.Int64) (HsProtobuf.at HsProtobuf.decodeMessageField (HsProtobuf.FieldNumber 4))) dotProto _ @@ -1171,22 +1188,22 @@ (HsProtobuf.Prim HsProtobuf.Fixed32) (HsProtobuf.Single "fixed1") [] - Hs.Nothing), + ""), (HsProtobuf.DotProtoField (HsProtobuf.FieldNumber 2) (HsProtobuf.Prim HsProtobuf.SFixed32) (HsProtobuf.Single "fixed2") [] - Hs.Nothing), + ""), (HsProtobuf.DotProtoField (HsProtobuf.FieldNumber 3) (HsProtobuf.Prim HsProtobuf.Fixed64) (HsProtobuf.Single "fixed3") [] - Hs.Nothing), + ""), (HsProtobuf.DotProtoField (HsProtobuf.FieldNumber 4) (HsProtobuf.Prim HsProtobuf.SFixed64) (HsProtobuf.Single "fixed4") [] - Hs.Nothing)] + "")] instance HsJSONPB.ToJSONPB WithFixed where toJSONPB (WithFixed f1 f2 f3 f4) @@ -1239,17 +1256,15 @@ ("fixed3", withFixedFixed3), ("fixed4", withFixedFixed4)]}}) -instance HsDhallPb.Interpret WithFixed - -instance HsDhallPb.Inject WithFixed - data WithBytes = WithBytes{withBytesBytes1 :: Hs.ByteString, withBytesBytes2 :: Hs.Vector Hs.ByteString} - deriving (Hs.Show, Hs.Eq, Hs.Ord, Hs.Generic) + deriving (Hs.Show, Hs.Eq, Hs.Ord, Hs.Generic, Hs.NFData) instance HsProtobuf.Named WithBytes where nameOf _ = (Hs.fromString "WithBytes") +instance HsProtobuf.HasDefault WithBytes + instance HsProtobuf.Message WithBytes where encodeMessage _ WithBytes{withBytesBytes1 = withBytesBytes1, @@ -1258,13 +1273,16 @@ [(HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 1) withBytesBytes1), (HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 2) - (HsProtobuf.UnpackedVec withBytesBytes2))]) + (Hs.coerce @(Hs.Vector Hs.ByteString) + @(HsProtobuf.UnpackedVec Hs.ByteString) + withBytesBytes2))]) decodeMessage _ = (Hs.pure WithBytes) <*> (HsProtobuf.at HsProtobuf.decodeMessageField (HsProtobuf.FieldNumber 1)) <*> - ((Hs.pure HsProtobuf.unpackedvec) <*> + (Hs.coerce @(_ (HsProtobuf.UnpackedVec Hs.ByteString)) + @(_ (Hs.Vector Hs.ByteString)) (HsProtobuf.at HsProtobuf.decodeMessageField (HsProtobuf.FieldNumber 2))) dotProto _ @@ -1272,12 +1290,12 @@ (HsProtobuf.Prim HsProtobuf.Bytes) (HsProtobuf.Single "bytes1") [] - Hs.Nothing), + ""), (HsProtobuf.DotProtoField (HsProtobuf.FieldNumber 2) (HsProtobuf.Repeated HsProtobuf.Bytes) (HsProtobuf.Single "bytes2") [] - Hs.Nothing)] + "")] instance HsJSONPB.ToJSONPB WithBytes where toJSONPB (WithBytes f1 f2) @@ -1318,34 +1336,36 @@ [("bytes1", withBytesBytes1), ("bytes2", withBytesBytes2)]}}) -instance HsDhallPb.Interpret WithBytes - -instance HsDhallPb.Inject WithBytes - data WithPacking = WithPacking{withPackingPacking1 :: Hs.Vector Hs.Int32, withPackingPacking2 :: Hs.Vector Hs.Int32} - deriving (Hs.Show, Hs.Eq, Hs.Ord, Hs.Generic) + deriving (Hs.Show, Hs.Eq, Hs.Ord, Hs.Generic, Hs.NFData) instance HsProtobuf.Named WithPacking where nameOf _ = (Hs.fromString "WithPacking") +instance HsProtobuf.HasDefault WithPacking + instance HsProtobuf.Message WithPacking where encodeMessage _ WithPacking{withPackingPacking1 = withPackingPacking1, withPackingPacking2 = withPackingPacking2} = (Hs.mconcat [(HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 1) - (HsProtobuf.UnpackedVec withPackingPacking1)), + (Hs.coerce @(Hs.Vector Hs.Int32) @(HsProtobuf.UnpackedVec Hs.Int32) + withPackingPacking1)), (HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 2) - (HsProtobuf.PackedVec withPackingPacking2))]) + (Hs.coerce @(Hs.Vector Hs.Int32) @(HsProtobuf.PackedVec Hs.Int32) + withPackingPacking2))]) decodeMessage _ = (Hs.pure WithPacking) <*> - ((Hs.pure HsProtobuf.unpackedvec) <*> + (Hs.coerce @(_ (HsProtobuf.UnpackedVec Hs.Int32)) + @(_ (Hs.Vector Hs.Int32)) (HsProtobuf.at HsProtobuf.decodeMessageField (HsProtobuf.FieldNumber 1))) <*> - ((Hs.pure HsProtobuf.packedvec) <*> + (Hs.coerce @(_ (HsProtobuf.PackedVec Hs.Int32)) + @(_ (Hs.Vector Hs.Int32)) (HsProtobuf.at HsProtobuf.decodeMessageField (HsProtobuf.FieldNumber 2))) dotProto _ @@ -1354,13 +1374,13 @@ (HsProtobuf.Single "packing1") [(HsProtobuf.DotProtoOption (HsProtobuf.Single "packed") (HsProtobuf.BoolLit Hs.False))] - Hs.Nothing), + ""), (HsProtobuf.DotProtoField (HsProtobuf.FieldNumber 2) (HsProtobuf.Repeated HsProtobuf.Int32) (HsProtobuf.Single "packing2") [(HsProtobuf.DotProtoOption (HsProtobuf.Single "packed") (HsProtobuf.BoolLit Hs.True))] - Hs.Nothing)] + "")] instance HsJSONPB.ToJSONPB WithPacking where toJSONPB (WithPacking f1 f2) @@ -1401,28 +1421,31 @@ [("packing1", withPackingPacking1), ("packing2", withPackingPacking2)]}}) -instance HsDhallPb.Interpret WithPacking - -instance HsDhallPb.Inject WithPacking - data E = EFLD0 | EFLD1 - deriving (Hs.Show, Hs.Bounded, Hs.Eq, Hs.Ord, Hs.Generic) + deriving (Hs.Show, Hs.Eq, Hs.Generic, Hs.NFData) instance HsProtobuf.Named E where nameOf _ = (Hs.fromString "E") -instance Hs.Enum E where - toEnum 0 = EFLD0 - toEnum 1 = EFLD1 - toEnum i = (Hs.toEnumError "E" i (0 :: Hs.Int, 1)) - fromEnum (EFLD0) = 0 - fromEnum (EFLD1) = 1 - succ (EFLD0) = EFLD1 - succ _ = Hs.succError "E" - pred (EFLD1) = EFLD0 - pred _ = Hs.predError "E" +instance HsProtobuf.HasDefault E +instance Hs.Bounded E where + minBound = EFLD0 + maxBound = EFLD1 + +instance Hs.Ord E where + compare x y + = Hs.compare (HsProtobuf.fromProtoEnum x) + (HsProtobuf.fromProtoEnum y) + +instance HsProtobuf.ProtoEnum E where + toProtoEnumMay 0 = Hs.Just EFLD0 + toProtoEnumMay 1 = Hs.Just EFLD1 + toProtoEnumMay _ = Hs.Nothing + fromProtoEnum (EFLD0) = 0 + fromProtoEnum (EFLD1) = 1 + instance HsJSONPB.ToJSONPB E where toJSONPB x _ = HsJSONPB.enumFieldString x toEncodingPB x _ = HsJSONPB.enumFieldEncoding x @@ -1439,10 +1462,6 @@ instance HsJSONPB.FromJSON E where parseJSON = HsJSONPB.parseJSONPB -instance HsDhallPb.Interpret E - -instance HsDhallPb.Inject E - instance HsProtobuf.Finite E data AllPackedTypes = AllPackedTypes{allPackedTypesPackedWord32 :: @@ -1450,26 +1469,24 @@ allPackedTypesPackedWord64 :: Hs.Vector Hs.Word64, allPackedTypesPackedInt32 :: Hs.Vector Hs.Int32, allPackedTypesPackedInt64 :: Hs.Vector Hs.Int64, - allPackedTypesPackedFixed32 :: - Hs.Vector (HsProtobuf.Fixed Hs.Word32), - allPackedTypesPackedFixed64 :: - Hs.Vector (HsProtobuf.Fixed Hs.Word64), + allPackedTypesPackedFixed32 :: Hs.Vector Hs.Word32, + allPackedTypesPackedFixed64 :: Hs.Vector Hs.Word64, allPackedTypesPackedFloat :: Hs.Vector Hs.Float, allPackedTypesPackedDouble :: Hs.Vector Hs.Double, - allPackedTypesPackedSFixed32 :: - Hs.Vector (HsProtobuf.Fixed Hs.Int32), - allPackedTypesPackedSFixed64 :: - Hs.Vector (HsProtobuf.Fixed Hs.Int64), + allPackedTypesPackedSFixed32 :: Hs.Vector Hs.Int32, + allPackedTypesPackedSFixed64 :: Hs.Vector Hs.Int64, allPackedTypesPackedBool :: Hs.Vector Hs.Bool, allPackedTypesPackedEnum :: Hs.Vector (HsProtobuf.Enumerated TestProto.E), allPackedTypesUnpackedEnum :: Hs.Vector (HsProtobuf.Enumerated TestProto.E)} - deriving (Hs.Show, Hs.Eq, Hs.Ord, Hs.Generic) + deriving (Hs.Show, Hs.Eq, Hs.Ord, Hs.Generic, Hs.NFData) instance HsProtobuf.Named AllPackedTypes where nameOf _ = (Hs.fromString "AllPackedTypes") +instance HsProtobuf.HasDefault AllPackedTypes + instance HsProtobuf.Message AllPackedTypes where encodeMessage _ AllPackedTypes{allPackedTypesPackedWord32 = @@ -1488,86 +1505,118 @@ allPackedTypesUnpackedEnum = allPackedTypesUnpackedEnum} = (Hs.mconcat [(HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 1) - (HsProtobuf.PackedVec allPackedTypesPackedWord32)), + (Hs.coerce @(Hs.Vector Hs.Word32) @(HsProtobuf.PackedVec Hs.Word32) + allPackedTypesPackedWord32)), (HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 2) - (HsProtobuf.PackedVec allPackedTypesPackedWord64)), + (Hs.coerce @(Hs.Vector Hs.Word64) @(HsProtobuf.PackedVec Hs.Word64) + allPackedTypesPackedWord64)), (HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 3) - (HsProtobuf.PackedVec allPackedTypesPackedInt32)), + (Hs.coerce @(Hs.Vector Hs.Int32) @(HsProtobuf.PackedVec Hs.Int32) + allPackedTypesPackedInt32)), (HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 4) - (HsProtobuf.PackedVec allPackedTypesPackedInt64)), + (Hs.coerce @(Hs.Vector Hs.Int64) @(HsProtobuf.PackedVec Hs.Int64) + allPackedTypesPackedInt64)), (HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 5) - (HsProtobuf.PackedVec allPackedTypesPackedFixed32)), + (Hs.coerce @(Hs.Vector Hs.Word32) + @(HsProtobuf.PackedVec (HsProtobuf.Fixed Hs.Word32)) + allPackedTypesPackedFixed32)), (HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 6) - (HsProtobuf.PackedVec allPackedTypesPackedFixed64)), + (Hs.coerce @(Hs.Vector Hs.Word64) + @(HsProtobuf.PackedVec (HsProtobuf.Fixed Hs.Word64)) + allPackedTypesPackedFixed64)), (HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 7) - (HsProtobuf.PackedVec allPackedTypesPackedFloat)), + (Hs.coerce @(Hs.Vector Hs.Float) @(HsProtobuf.PackedVec Hs.Float) + allPackedTypesPackedFloat)), (HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 8) - (HsProtobuf.PackedVec allPackedTypesPackedDouble)), + (Hs.coerce @(Hs.Vector Hs.Double) @(HsProtobuf.PackedVec Hs.Double) + allPackedTypesPackedDouble)), (HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 9) - (HsProtobuf.PackedVec - (Hs.fmap HsProtobuf.Signed allPackedTypesPackedSFixed32))), + (Hs.coerce @(Hs.Vector Hs.Int32) + @(HsProtobuf.PackedVec (HsProtobuf.Signed (HsProtobuf.Fixed Hs.Int32))) + allPackedTypesPackedSFixed32)), (HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 10) - (HsProtobuf.PackedVec - (Hs.fmap HsProtobuf.Signed allPackedTypesPackedSFixed64))), + (Hs.coerce @(Hs.Vector Hs.Int64) + @(HsProtobuf.PackedVec (HsProtobuf.Signed (HsProtobuf.Fixed Hs.Int64))) + allPackedTypesPackedSFixed64)), (HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 11) - (HsProtobuf.PackedVec allPackedTypesPackedBool)), + (Hs.coerce @(Hs.Vector Hs.Bool) @(HsProtobuf.PackedVec Hs.Bool) + allPackedTypesPackedBool)), (HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 12) - (HsProtobuf.PackedVec allPackedTypesPackedEnum)), + (Hs.coerce @(Hs.Vector (HsProtobuf.Enumerated TestProto.E)) + @(HsProtobuf.PackedVec (HsProtobuf.Enumerated TestProto.E)) + allPackedTypesPackedEnum)), (HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 13) - (HsProtobuf.UnpackedVec allPackedTypesUnpackedEnum))]) + (Hs.coerce @(Hs.Vector (HsProtobuf.Enumerated TestProto.E)) + @(HsProtobuf.UnpackedVec (HsProtobuf.Enumerated TestProto.E)) + allPackedTypesUnpackedEnum))]) decodeMessage _ = (Hs.pure AllPackedTypes) <*> - ((Hs.pure HsProtobuf.packedvec) <*> + (Hs.coerce @(_ (HsProtobuf.PackedVec Hs.Word32)) + @(_ (Hs.Vector Hs.Word32)) (HsProtobuf.at HsProtobuf.decodeMessageField (HsProtobuf.FieldNumber 1))) <*> - ((Hs.pure HsProtobuf.packedvec) <*> + (Hs.coerce @(_ (HsProtobuf.PackedVec Hs.Word64)) + @(_ (Hs.Vector Hs.Word64)) (HsProtobuf.at HsProtobuf.decodeMessageField (HsProtobuf.FieldNumber 2))) <*> - ((Hs.pure HsProtobuf.packedvec) <*> + (Hs.coerce @(_ (HsProtobuf.PackedVec Hs.Int32)) + @(_ (Hs.Vector Hs.Int32)) (HsProtobuf.at HsProtobuf.decodeMessageField (HsProtobuf.FieldNumber 3))) <*> - ((Hs.pure HsProtobuf.packedvec) <*> + (Hs.coerce @(_ (HsProtobuf.PackedVec Hs.Int64)) + @(_ (Hs.Vector Hs.Int64)) (HsProtobuf.at HsProtobuf.decodeMessageField (HsProtobuf.FieldNumber 4))) <*> - ((Hs.pure HsProtobuf.packedvec) <*> + (Hs.coerce @(_ (HsProtobuf.PackedVec (HsProtobuf.Fixed Hs.Word32))) + @(_ (Hs.Vector Hs.Word32)) (HsProtobuf.at HsProtobuf.decodeMessageField (HsProtobuf.FieldNumber 5))) <*> - ((Hs.pure HsProtobuf.packedvec) <*> + (Hs.coerce @(_ (HsProtobuf.PackedVec (HsProtobuf.Fixed Hs.Word64))) + @(_ (Hs.Vector Hs.Word64)) (HsProtobuf.at HsProtobuf.decodeMessageField (HsProtobuf.FieldNumber 6))) <*> - ((Hs.pure HsProtobuf.packedvec) <*> + (Hs.coerce @(_ (HsProtobuf.PackedVec Hs.Float)) + @(_ (Hs.Vector Hs.Float)) (HsProtobuf.at HsProtobuf.decodeMessageField (HsProtobuf.FieldNumber 7))) <*> - ((Hs.pure HsProtobuf.packedvec) <*> + (Hs.coerce @(_ (HsProtobuf.PackedVec Hs.Double)) + @(_ (Hs.Vector Hs.Double)) (HsProtobuf.at HsProtobuf.decodeMessageField (HsProtobuf.FieldNumber 8))) <*> - ((Hs.pure (Hs.fmap HsProtobuf.signed)) <*> - ((Hs.pure HsProtobuf.packedvec) <*> - (HsProtobuf.at HsProtobuf.decodeMessageField - (HsProtobuf.FieldNumber 9)))) + (Hs.coerce + @(_ (HsProtobuf.PackedVec (HsProtobuf.Signed (HsProtobuf.Fixed Hs.Int32)))) + @(_ (Hs.Vector Hs.Int32)) + (HsProtobuf.at HsProtobuf.decodeMessageField + (HsProtobuf.FieldNumber 9))) <*> - ((Hs.pure (Hs.fmap HsProtobuf.signed)) <*> - ((Hs.pure HsProtobuf.packedvec) <*> - (HsProtobuf.at HsProtobuf.decodeMessageField - (HsProtobuf.FieldNumber 10)))) + (Hs.coerce + @(_ (HsProtobuf.PackedVec (HsProtobuf.Signed (HsProtobuf.Fixed Hs.Int64)))) + @(_ (Hs.Vector Hs.Int64)) + (HsProtobuf.at HsProtobuf.decodeMessageField + (HsProtobuf.FieldNumber 10))) <*> - ((Hs.pure HsProtobuf.packedvec) <*> + (Hs.coerce @(_ (HsProtobuf.PackedVec Hs.Bool)) + @(_ (Hs.Vector Hs.Bool)) (HsProtobuf.at HsProtobuf.decodeMessageField (HsProtobuf.FieldNumber 11))) <*> - ((Hs.pure HsProtobuf.packedvec) <*> + (Hs.coerce + @(_ (HsProtobuf.PackedVec (HsProtobuf.Enumerated TestProto.E))) + @(_ (Hs.Vector (HsProtobuf.Enumerated TestProto.E))) (HsProtobuf.at HsProtobuf.decodeMessageField (HsProtobuf.FieldNumber 12))) <*> - ((Hs.pure HsProtobuf.unpackedvec) <*> + (Hs.coerce + @(_ (HsProtobuf.UnpackedVec (HsProtobuf.Enumerated TestProto.E))) + @(_ (Hs.Vector (HsProtobuf.Enumerated TestProto.E))) (HsProtobuf.at HsProtobuf.decodeMessageField (HsProtobuf.FieldNumber 13))) dotProto _ @@ -1576,79 +1625,79 @@ (HsProtobuf.Single "packedWord32") [(HsProtobuf.DotProtoOption (HsProtobuf.Single "packed") (HsProtobuf.BoolLit Hs.True))] - Hs.Nothing), + ""), (HsProtobuf.DotProtoField (HsProtobuf.FieldNumber 2) (HsProtobuf.Repeated HsProtobuf.UInt64) (HsProtobuf.Single "packedWord64") [(HsProtobuf.DotProtoOption (HsProtobuf.Single "packed") (HsProtobuf.BoolLit Hs.True))] - Hs.Nothing), + ""), (HsProtobuf.DotProtoField (HsProtobuf.FieldNumber 3) (HsProtobuf.Repeated HsProtobuf.Int32) (HsProtobuf.Single "packedInt32") [(HsProtobuf.DotProtoOption (HsProtobuf.Single "packed") (HsProtobuf.BoolLit Hs.True))] - Hs.Nothing), + ""), (HsProtobuf.DotProtoField (HsProtobuf.FieldNumber 4) (HsProtobuf.Repeated HsProtobuf.Int64) (HsProtobuf.Single "packedInt64") [(HsProtobuf.DotProtoOption (HsProtobuf.Single "packed") (HsProtobuf.BoolLit Hs.True))] - Hs.Nothing), + ""), (HsProtobuf.DotProtoField (HsProtobuf.FieldNumber 5) (HsProtobuf.Repeated HsProtobuf.Fixed32) (HsProtobuf.Single "packedFixed32") [(HsProtobuf.DotProtoOption (HsProtobuf.Single "packed") (HsProtobuf.BoolLit Hs.True))] - Hs.Nothing), + ""), (HsProtobuf.DotProtoField (HsProtobuf.FieldNumber 6) (HsProtobuf.Repeated HsProtobuf.Fixed64) (HsProtobuf.Single "packedFixed64") [(HsProtobuf.DotProtoOption (HsProtobuf.Single "packed") (HsProtobuf.BoolLit Hs.True))] - Hs.Nothing), + ""), (HsProtobuf.DotProtoField (HsProtobuf.FieldNumber 7) (HsProtobuf.Repeated HsProtobuf.Float) (HsProtobuf.Single "packedFloat") [(HsProtobuf.DotProtoOption (HsProtobuf.Single "packed") (HsProtobuf.BoolLit Hs.True))] - Hs.Nothing), + ""), (HsProtobuf.DotProtoField (HsProtobuf.FieldNumber 8) (HsProtobuf.Repeated HsProtobuf.Double) (HsProtobuf.Single "packedDouble") [(HsProtobuf.DotProtoOption (HsProtobuf.Single "packed") (HsProtobuf.BoolLit Hs.True))] - Hs.Nothing), + ""), (HsProtobuf.DotProtoField (HsProtobuf.FieldNumber 9) (HsProtobuf.Repeated HsProtobuf.SFixed32) (HsProtobuf.Single "packedSFixed32") [(HsProtobuf.DotProtoOption (HsProtobuf.Single "packed") (HsProtobuf.BoolLit Hs.True))] - Hs.Nothing), + ""), (HsProtobuf.DotProtoField (HsProtobuf.FieldNumber 10) (HsProtobuf.Repeated HsProtobuf.SFixed64) (HsProtobuf.Single "packedSFixed64") [(HsProtobuf.DotProtoOption (HsProtobuf.Single "packed") (HsProtobuf.BoolLit Hs.True))] - Hs.Nothing), + ""), (HsProtobuf.DotProtoField (HsProtobuf.FieldNumber 11) (HsProtobuf.Repeated HsProtobuf.Bool) (HsProtobuf.Single "packedBool") [(HsProtobuf.DotProtoOption (HsProtobuf.Single "packed") (HsProtobuf.BoolLit Hs.True))] - Hs.Nothing), + ""), (HsProtobuf.DotProtoField (HsProtobuf.FieldNumber 12) (HsProtobuf.Repeated (HsProtobuf.Named (HsProtobuf.Single "E"))) (HsProtobuf.Single "packedEnum") [(HsProtobuf.DotProtoOption (HsProtobuf.Single "packed") (HsProtobuf.BoolLit Hs.True))] - Hs.Nothing), + ""), (HsProtobuf.DotProtoField (HsProtobuf.FieldNumber 13) (HsProtobuf.Repeated (HsProtobuf.Named (HsProtobuf.Single "E"))) (HsProtobuf.Single "unpackedEnum") [(HsProtobuf.DotProtoOption (HsProtobuf.Single "packed") (HsProtobuf.BoolLit Hs.False))] - Hs.Nothing)] + "")] instance HsJSONPB.ToJSONPB AllPackedTypes where toJSONPB @@ -1766,20 +1815,18 @@ ("unpackedEnum", allPackedTypesUnpackedEnum)]}}) -instance HsDhallPb.Interpret AllPackedTypes - -instance HsDhallPb.Inject AllPackedTypes - data OutOfOrderFields = OutOfOrderFields{outOfOrderFieldsField1 :: Hs.Vector Hs.Word32, outOfOrderFieldsField2 :: Hs.Text, outOfOrderFieldsField3 :: Hs.Int64, outOfOrderFieldsField4 :: Hs.Vector Hs.Text} - deriving (Hs.Show, Hs.Eq, Hs.Ord, Hs.Generic) + deriving (Hs.Show, Hs.Eq, Hs.Ord, Hs.Generic, Hs.NFData) instance HsProtobuf.Named OutOfOrderFields where nameOf _ = (Hs.fromString "OutOfOrderFields") +instance HsProtobuf.HasDefault OutOfOrderFields + instance HsProtobuf.Message OutOfOrderFields where encodeMessage _ OutOfOrderFields{outOfOrderFieldsField1 = outOfOrderFieldsField1, @@ -1788,16 +1835,19 @@ outOfOrderFieldsField4 = outOfOrderFieldsField4} = (Hs.mconcat [(HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 2001) - (HsProtobuf.PackedVec outOfOrderFieldsField1)), + (Hs.coerce @(Hs.Vector Hs.Word32) @(HsProtobuf.PackedVec Hs.Word32) + outOfOrderFieldsField1)), (HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 101) outOfOrderFieldsField2), (HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 30) outOfOrderFieldsField3), (HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 1002) - (HsProtobuf.UnpackedVec outOfOrderFieldsField4))]) + (Hs.coerce @(Hs.Vector Hs.Text) @(HsProtobuf.UnpackedVec Hs.Text) + outOfOrderFieldsField4))]) decodeMessage _ = (Hs.pure OutOfOrderFields) <*> - ((Hs.pure HsProtobuf.packedvec) <*> + (Hs.coerce @(_ (HsProtobuf.PackedVec Hs.Word32)) + @(_ (Hs.Vector Hs.Word32)) (HsProtobuf.at HsProtobuf.decodeMessageField (HsProtobuf.FieldNumber 2001))) <*> @@ -1807,7 +1857,8 @@ (HsProtobuf.at HsProtobuf.decodeMessageField (HsProtobuf.FieldNumber 30)) <*> - ((Hs.pure HsProtobuf.unpackedvec) <*> + (Hs.coerce @(_ (HsProtobuf.UnpackedVec Hs.Text)) + @(_ (Hs.Vector Hs.Text)) (HsProtobuf.at HsProtobuf.decodeMessageField (HsProtobuf.FieldNumber 1002))) dotProto _ @@ -1816,22 +1867,22 @@ (HsProtobuf.Single "field1") [(HsProtobuf.DotProtoOption (HsProtobuf.Single "packed") (HsProtobuf.BoolLit Hs.True))] - Hs.Nothing), + ""), (HsProtobuf.DotProtoField (HsProtobuf.FieldNumber 101) (HsProtobuf.Prim HsProtobuf.String) (HsProtobuf.Single "field2") [] - Hs.Nothing), + ""), (HsProtobuf.DotProtoField (HsProtobuf.FieldNumber 30) (HsProtobuf.Prim HsProtobuf.Int64) (HsProtobuf.Single "field3") [] - Hs.Nothing), + ""), (HsProtobuf.DotProtoField (HsProtobuf.FieldNumber 1002) (HsProtobuf.Repeated HsProtobuf.String) (HsProtobuf.Single "field4") [] - Hs.Nothing)] + "")] instance HsJSONPB.ToJSONPB OutOfOrderFields where toJSONPB (OutOfOrderFields f2001 f101 f30 f1002) @@ -1887,18 +1938,16 @@ ("field3", outOfOrderFieldsField3), ("field4", outOfOrderFieldsField4)]}}) -instance HsDhallPb.Interpret OutOfOrderFields - -instance HsDhallPb.Inject OutOfOrderFields - data ShadowedMessage = ShadowedMessage{shadowedMessageName :: Hs.Text, shadowedMessageValue :: Hs.Int32} - deriving (Hs.Show, Hs.Eq, Hs.Ord, Hs.Generic) + deriving (Hs.Show, Hs.Eq, Hs.Ord, Hs.Generic, Hs.NFData) instance HsProtobuf.Named ShadowedMessage where nameOf _ = (Hs.fromString "ShadowedMessage") +instance HsProtobuf.HasDefault ShadowedMessage + instance HsProtobuf.Message ShadowedMessage where encodeMessage _ ShadowedMessage{shadowedMessageName = shadowedMessageName, @@ -1920,12 +1969,12 @@ (HsProtobuf.Prim HsProtobuf.String) (HsProtobuf.Single "name") [] - Hs.Nothing), + ""), (HsProtobuf.DotProtoField (HsProtobuf.FieldNumber 1) (HsProtobuf.Prim HsProtobuf.Int32) (HsProtobuf.Single "value") [] - Hs.Nothing)] + "")] instance HsJSONPB.ToJSONPB ShadowedMessage where toJSONPB (ShadowedMessage f2 f1) @@ -1966,18 +2015,16 @@ [("name", shadowedMessageName), ("value", shadowedMessageValue)]}}) -instance HsDhallPb.Interpret ShadowedMessage - -instance HsDhallPb.Inject ShadowedMessage - data MessageShadower = MessageShadower{messageShadowerShadowedMessage :: Hs.Maybe TestProto.MessageShadower_ShadowedMessage, messageShadowerName :: Hs.Text} - deriving (Hs.Show, Hs.Eq, Hs.Ord, Hs.Generic) + deriving (Hs.Show, Hs.Eq, Hs.Ord, Hs.Generic, Hs.NFData) instance HsProtobuf.Named MessageShadower where nameOf _ = (Hs.fromString "MessageShadower") +instance HsProtobuf.HasDefault MessageShadower + instance HsProtobuf.Message MessageShadower where encodeMessage _ MessageShadower{messageShadowerShadowedMessage = @@ -1985,12 +2032,16 @@ messageShadowerName = messageShadowerName} = (Hs.mconcat [(HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 1) - (HsProtobuf.Nested messageShadowerShadowedMessage)), + (Hs.coerce @(Hs.Maybe TestProto.MessageShadower_ShadowedMessage) + @(HsProtobuf.Nested TestProto.MessageShadower_ShadowedMessage) + messageShadowerShadowedMessage)), (HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 2) messageShadowerName)]) decodeMessage _ = (Hs.pure MessageShadower) <*> - ((Hs.pure HsProtobuf.nested) <*> + (Hs.coerce + @(_ (HsProtobuf.Nested TestProto.MessageShadower_ShadowedMessage)) + @(_ (Hs.Maybe TestProto.MessageShadower_ShadowedMessage)) (HsProtobuf.at HsProtobuf.decodeMessageField (HsProtobuf.FieldNumber 1))) <*> @@ -2002,12 +2053,12 @@ (HsProtobuf.Named (HsProtobuf.Single "ShadowedMessage"))) (HsProtobuf.Single "shadowed_message") [] - Hs.Nothing), + ""), (HsProtobuf.DotProtoField (HsProtobuf.FieldNumber 2) (HsProtobuf.Prim HsProtobuf.String) (HsProtobuf.Single "name") [] - Hs.Nothing)] + "")] instance HsJSONPB.ToJSONPB MessageShadower where toJSONPB (MessageShadower f1 f2) @@ -2052,19 +2103,17 @@ messageShadowerShadowedMessage), ("name", messageShadowerName)]}}) -instance HsDhallPb.Interpret MessageShadower - -instance HsDhallPb.Inject MessageShadower - data MessageShadower_ShadowedMessage = MessageShadower_ShadowedMessage{messageShadower_ShadowedMessageName :: Hs.Text, messageShadower_ShadowedMessageValue :: Hs.Text} - deriving (Hs.Show, Hs.Eq, Hs.Ord, Hs.Generic) + deriving (Hs.Show, Hs.Eq, Hs.Ord, Hs.Generic, Hs.NFData) instance HsProtobuf.Named MessageShadower_ShadowedMessage where nameOf _ = (Hs.fromString "MessageShadower_ShadowedMessage") +instance HsProtobuf.HasDefault MessageShadower_ShadowedMessage + instance HsProtobuf.Message MessageShadower_ShadowedMessage where encodeMessage _ MessageShadower_ShadowedMessage{messageShadower_ShadowedMessageName @@ -2088,12 +2137,12 @@ (HsProtobuf.Prim HsProtobuf.String) (HsProtobuf.Single "name") [] - Hs.Nothing), + ""), (HsProtobuf.DotProtoField (HsProtobuf.FieldNumber 2) (HsProtobuf.Prim HsProtobuf.String) (HsProtobuf.Single "value") [] - Hs.Nothing)] + "")] instance HsJSONPB.ToJSONPB MessageShadower_ShadowedMessage where toJSONPB (MessageShadower_ShadowedMessage f1 f2) @@ -2138,19 +2187,17 @@ ("value", messageShadower_ShadowedMessageValue)]}}) -instance HsDhallPb.Interpret MessageShadower_ShadowedMessage - -instance HsDhallPb.Inject MessageShadower_ShadowedMessage - data WithQualifiedName = WithQualifiedName{withQualifiedNameQname1 :: Hs.Maybe TestProto.ShadowedMessage, withQualifiedNameQname2 :: Hs.Maybe TestProto.MessageShadower_ShadowedMessage} - deriving (Hs.Show, Hs.Eq, Hs.Ord, Hs.Generic) + deriving (Hs.Show, Hs.Eq, Hs.Ord, Hs.Generic, Hs.NFData) instance HsProtobuf.Named WithQualifiedName where nameOf _ = (Hs.fromString "WithQualifiedName") +instance HsProtobuf.HasDefault WithQualifiedName + instance HsProtobuf.Message WithQualifiedName where encodeMessage _ WithQualifiedName{withQualifiedNameQname1 = @@ -2158,16 +2205,23 @@ withQualifiedNameQname2 = withQualifiedNameQname2} = (Hs.mconcat [(HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 100) - (HsProtobuf.Nested withQualifiedNameQname1)), + (Hs.coerce @(Hs.Maybe TestProto.ShadowedMessage) + @(HsProtobuf.Nested TestProto.ShadowedMessage) + withQualifiedNameQname1)), (HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 200) - (HsProtobuf.Nested withQualifiedNameQname2))]) + (Hs.coerce @(Hs.Maybe TestProto.MessageShadower_ShadowedMessage) + @(HsProtobuf.Nested TestProto.MessageShadower_ShadowedMessage) + withQualifiedNameQname2))]) decodeMessage _ = (Hs.pure WithQualifiedName) <*> - ((Hs.pure HsProtobuf.nested) <*> + (Hs.coerce @(_ (HsProtobuf.Nested TestProto.ShadowedMessage)) + @(_ (Hs.Maybe TestProto.ShadowedMessage)) (HsProtobuf.at HsProtobuf.decodeMessageField (HsProtobuf.FieldNumber 100))) <*> - ((Hs.pure HsProtobuf.nested) <*> + (Hs.coerce + @(_ (HsProtobuf.Nested TestProto.MessageShadower_ShadowedMessage)) + @(_ (Hs.Maybe TestProto.MessageShadower_ShadowedMessage)) (HsProtobuf.at HsProtobuf.decodeMessageField (HsProtobuf.FieldNumber 200))) dotProto _ @@ -2176,15 +2230,15 @@ (HsProtobuf.Named (HsProtobuf.Single "ShadowedMessage"))) (HsProtobuf.Single "qname1") [] - Hs.Nothing), + ""), (HsProtobuf.DotProtoField (HsProtobuf.FieldNumber 200) (HsProtobuf.Prim (HsProtobuf.Named (HsProtobuf.Dots - (HsProtobuf.Path ["MessageShadower", "ShadowedMessage"])))) + (HsProtobuf.Path ("MessageShadower" Hs.:| ["ShadowedMessage"]))))) (HsProtobuf.Single "qname2") [] - Hs.Nothing)] + "")] instance HsJSONPB.ToJSONPB WithQualifiedName where toJSONPB (WithQualifiedName f100 f200) @@ -2227,18 +2281,16 @@ [("qname1", withQualifiedNameQname1), ("qname2", withQualifiedNameQname2)]}}) -instance HsDhallPb.Interpret WithQualifiedName - -instance HsDhallPb.Inject WithQualifiedName - data UsingImported = UsingImported{usingImportedImportedNesting :: Hs.Maybe TestProtoImport.WithNesting, usingImportedLocalNesting :: Hs.Maybe TestProto.WithNesting} - deriving (Hs.Show, Hs.Eq, Hs.Ord, Hs.Generic) + deriving (Hs.Show, Hs.Eq, Hs.Ord, Hs.Generic, Hs.NFData) instance HsProtobuf.Named UsingImported where nameOf _ = (Hs.fromString "UsingImported") +instance HsProtobuf.HasDefault UsingImported + instance HsProtobuf.Message UsingImported where encodeMessage _ UsingImported{usingImportedImportedNesting = @@ -2246,16 +2298,22 @@ usingImportedLocalNesting = usingImportedLocalNesting} = (Hs.mconcat [(HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 100) - (HsProtobuf.Nested usingImportedImportedNesting)), + (Hs.coerce @(Hs.Maybe TestProtoImport.WithNesting) + @(HsProtobuf.Nested TestProtoImport.WithNesting) + usingImportedImportedNesting)), (HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 200) - (HsProtobuf.Nested usingImportedLocalNesting))]) + (Hs.coerce @(Hs.Maybe TestProto.WithNesting) + @(HsProtobuf.Nested TestProto.WithNesting) + usingImportedLocalNesting))]) decodeMessage _ = (Hs.pure UsingImported) <*> - ((Hs.pure HsProtobuf.nested) <*> + (Hs.coerce @(_ (HsProtobuf.Nested TestProtoImport.WithNesting)) + @(_ (Hs.Maybe TestProtoImport.WithNesting)) (HsProtobuf.at HsProtobuf.decodeMessageField (HsProtobuf.FieldNumber 100))) <*> - ((Hs.pure HsProtobuf.nested) <*> + (Hs.coerce @(_ (HsProtobuf.Nested TestProto.WithNesting)) + @(_ (Hs.Maybe TestProto.WithNesting)) (HsProtobuf.at HsProtobuf.decodeMessageField (HsProtobuf.FieldNumber 200))) dotProto _ @@ -2263,16 +2321,16 @@ (HsProtobuf.Prim (HsProtobuf.Named (HsProtobuf.Dots - (HsProtobuf.Path ["TestProtoImport", "WithNesting"])))) + (HsProtobuf.Path ("TestProtoImport" Hs.:| ["WithNesting"]))))) (HsProtobuf.Single "importedNesting") [] - Hs.Nothing), + ""), (HsProtobuf.DotProtoField (HsProtobuf.FieldNumber 200) (HsProtobuf.Prim (HsProtobuf.Named (HsProtobuf.Single "WithNesting"))) (HsProtobuf.Single "localNesting") [] - Hs.Nothing)] + "")] instance HsJSONPB.ToJSONPB UsingImported where toJSONPB (UsingImported f100 f200) @@ -2319,25 +2377,26 @@ ("localNesting", usingImportedLocalNesting)]}}) -instance HsDhallPb.Interpret UsingImported - -instance HsDhallPb.Inject UsingImported - data Wrapped = Wrapped{wrappedWrapped :: Hs.Maybe TestProto.Wrapped} - deriving (Hs.Show, Hs.Eq, Hs.Ord, Hs.Generic) + deriving (Hs.Show, Hs.Eq, Hs.Ord, Hs.Generic, Hs.NFData) instance HsProtobuf.Named Wrapped where nameOf _ = (Hs.fromString "Wrapped") +instance HsProtobuf.HasDefault Wrapped + instance HsProtobuf.Message Wrapped where encodeMessage _ Wrapped{wrappedWrapped = wrappedWrapped} = (Hs.mconcat [(HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 1) - (HsProtobuf.Nested wrappedWrapped))]) + (Hs.coerce @(Hs.Maybe TestProto.Wrapped) + @(HsProtobuf.Nested TestProto.Wrapped) + wrappedWrapped))]) decodeMessage _ = (Hs.pure Wrapped) <*> - ((Hs.pure HsProtobuf.nested) <*> + (Hs.coerce @(_ (HsProtobuf.Nested TestProto.Wrapped)) + @(_ (Hs.Maybe TestProto.Wrapped)) (HsProtobuf.at HsProtobuf.decodeMessageField (HsProtobuf.FieldNumber 1))) dotProto _ @@ -2345,7 +2404,7 @@ (HsProtobuf.Prim (HsProtobuf.Named (HsProtobuf.Single "Wrapped"))) (HsProtobuf.Single "wrapped") [] - Hs.Nothing)] + "")] instance HsJSONPB.ToJSONPB Wrapped where toJSONPB (Wrapped f1) = (HsJSONPB.object ["wrapped" .= f1]) @@ -2379,28 +2438,31 @@ HsJSONPB.insOrdFromList [("wrapped", wrappedWrapped)]}}) -instance HsDhallPb.Interpret Wrapped - -instance HsDhallPb.Inject Wrapped - data EnumAnnots = EnumAnnotsFOO | EnumAnnotsBAR - deriving (Hs.Show, Hs.Bounded, Hs.Eq, Hs.Ord, Hs.Generic) + deriving (Hs.Show, Hs.Eq, Hs.Generic, Hs.NFData) instance HsProtobuf.Named EnumAnnots where nameOf _ = (Hs.fromString "EnumAnnots") -instance Hs.Enum EnumAnnots where - toEnum 0 = EnumAnnotsFOO - toEnum 1 = EnumAnnotsBAR - toEnum i = (Hs.toEnumError "EnumAnnots" i (0 :: Hs.Int, 1)) - fromEnum (EnumAnnotsFOO) = 0 - fromEnum (EnumAnnotsBAR) = 1 - succ (EnumAnnotsFOO) = EnumAnnotsBAR - succ _ = Hs.succError "EnumAnnots" - pred (EnumAnnotsBAR) = EnumAnnotsFOO - pred _ = Hs.predError "EnumAnnots" +instance HsProtobuf.HasDefault EnumAnnots +instance Hs.Bounded EnumAnnots where + minBound = EnumAnnotsFOO + maxBound = EnumAnnotsBAR + +instance Hs.Ord EnumAnnots where + compare x y + = Hs.compare (HsProtobuf.fromProtoEnum x) + (HsProtobuf.fromProtoEnum y) + +instance HsProtobuf.ProtoEnum EnumAnnots where + toProtoEnumMay 0 = Hs.Just EnumAnnotsFOO + toProtoEnumMay 1 = Hs.Just EnumAnnotsBAR + toProtoEnumMay _ = Hs.Nothing + fromProtoEnum (EnumAnnotsFOO) = 0 + fromProtoEnum (EnumAnnotsBAR) = 1 + instance HsJSONPB.ToJSONPB EnumAnnots where toJSONPB x _ = HsJSONPB.enumFieldString x toEncodingPB x _ = HsJSONPB.enumFieldEncoding x @@ -2417,8 +2479,176 @@ instance HsJSONPB.FromJSON EnumAnnots where parseJSON = HsJSONPB.parseJSONPB -instance HsDhallPb.Interpret EnumAnnots +instance HsProtobuf.Finite EnumAnnots -instance HsDhallPb.Inject EnumAnnots +data WrappedTrivial = WrappedTrivial{wrappedTrivialTrivial :: + Hs.Maybe TestProto.Trivial} + deriving (Hs.Show, Hs.Eq, Hs.Ord, Hs.Generic, Hs.NFData) -instance HsProtobuf.Finite EnumAnnots +instance HsProtobuf.Named WrappedTrivial where + nameOf _ = (Hs.fromString "WrappedTrivial") + +instance HsProtobuf.HasDefault WrappedTrivial + +instance HsProtobuf.Message WrappedTrivial where + encodeMessage _ + WrappedTrivial{wrappedTrivialTrivial = wrappedTrivialTrivial} + = (Hs.mconcat + [(HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 1) + (Hs.coerce @(Hs.Maybe TestProto.Trivial) + @(HsProtobuf.Nested TestProto.Trivial) + wrappedTrivialTrivial))]) + decodeMessage _ + = (Hs.pure WrappedTrivial) <*> + (Hs.coerce @(_ (HsProtobuf.Nested TestProto.Trivial)) + @(_ (Hs.Maybe TestProto.Trivial)) + (HsProtobuf.at HsProtobuf.decodeMessageField + (HsProtobuf.FieldNumber 1))) + dotProto _ + = [(HsProtobuf.DotProtoField (HsProtobuf.FieldNumber 1) + (HsProtobuf.Prim (HsProtobuf.Named (HsProtobuf.Single "Trivial"))) + (HsProtobuf.Single "trivial") + [] + "")] + +instance HsJSONPB.ToJSONPB WrappedTrivial where + toJSONPB (WrappedTrivial f1) = (HsJSONPB.object ["trivial" .= f1]) + toEncodingPB (WrappedTrivial f1) + = (HsJSONPB.pairs ["trivial" .= f1]) + +instance HsJSONPB.FromJSONPB WrappedTrivial where + parseJSONPB + = (HsJSONPB.withObject "WrappedTrivial" + (\ obj -> (Hs.pure WrappedTrivial) <*> obj .: "trivial")) + +instance HsJSONPB.ToJSON WrappedTrivial where + toJSON = HsJSONPB.toAesonValue + toEncoding = HsJSONPB.toAesonEncoding + +instance HsJSONPB.FromJSON WrappedTrivial where + parseJSON = HsJSONPB.parseJSONPB + +instance HsJSONPB.ToSchema WrappedTrivial where + declareNamedSchema _ + = do let declare_trivial = HsJSONPB.declareSchemaRef + wrappedTrivialTrivial <- declare_trivial Proxy.Proxy + let _ = Hs.pure WrappedTrivial <*> HsJSONPB.asProxy declare_trivial + Hs.return + (HsJSONPB.NamedSchema{HsJSONPB._namedSchemaName = + Hs.Just "WrappedTrivial", + HsJSONPB._namedSchemaSchema = + Hs.mempty{HsJSONPB._schemaParamSchema = + Hs.mempty{HsJSONPB._paramSchemaType = + HsJSONPB.SwaggerObject}, + HsJSONPB._schemaProperties = + HsJSONPB.insOrdFromList + [("trivial", wrappedTrivialTrivial)]}}) + +data MapTest = MapTest{mapTestPrim :: Hs.Map Hs.Text Hs.Int32, + mapTestTrivial :: + Hs.Map Hs.Int32 (Hs.Maybe TestProto.WrappedTrivial), + mapTestSigned :: Hs.Map Hs.Int32 Hs.Int32} + deriving (Hs.Show, Hs.Eq, Hs.Ord, Hs.Generic, Hs.NFData) + +instance HsProtobuf.Named MapTest where + nameOf _ = (Hs.fromString "MapTest") + +instance HsProtobuf.HasDefault MapTest + +instance HsProtobuf.Message MapTest where + encodeMessage _ + MapTest{mapTestPrim = mapTestPrim, mapTestTrivial = mapTestTrivial, + mapTestSigned = mapTestSigned} + = (Hs.mconcat + [(HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 1) + (Hs.unsafeCoerce @(Hs.Map Hs.Text Hs.Int32) + @(Hs.Map Hs.Text (HsProtobuf.Signed Hs.Int32)) + mapTestPrim)), + (HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 2) + (Hs.unsafeCoerce + @(Hs.Map Hs.Int32 (Hs.Maybe TestProto.WrappedTrivial)) + @(Hs.Map Hs.Int32 (HsProtobuf.Nested TestProto.WrappedTrivial)) + mapTestTrivial)), + (HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 3) + (Hs.unsafeCoerce @(Hs.Map Hs.Int32 Hs.Int32) + @(Hs.Map (HsProtobuf.Signed Hs.Int32) (HsProtobuf.Signed Hs.Int32)) + mapTestSigned))]) + decodeMessage _ + = (Hs.pure MapTest) <*> + (Hs.unsafeCoerce @(_ (Hs.Map Hs.Text (HsProtobuf.Signed Hs.Int32))) + @(_ (Hs.Map Hs.Text Hs.Int32)) + (HsProtobuf.at HsProtobuf.decodeMessageField + (HsProtobuf.FieldNumber 1))) + <*> + (Hs.unsafeCoerce + @(_ (Hs.Map Hs.Int32 (HsProtobuf.Nested TestProto.WrappedTrivial))) + @(_ (Hs.Map Hs.Int32 (Hs.Maybe TestProto.WrappedTrivial))) + (HsProtobuf.at HsProtobuf.decodeMessageField + (HsProtobuf.FieldNumber 2))) + <*> + (Hs.unsafeCoerce + @(_ (Hs.Map (HsProtobuf.Signed Hs.Int32) (HsProtobuf.Signed Hs.Int32))) + @(_ (Hs.Map Hs.Int32 Hs.Int32)) + (HsProtobuf.at HsProtobuf.decodeMessageField + (HsProtobuf.FieldNumber 3))) + dotProto _ + = [(HsProtobuf.DotProtoField (HsProtobuf.FieldNumber 1) + (HsProtobuf.Map HsProtobuf.String HsProtobuf.SInt32) + (HsProtobuf.Single "prim") + [] + ""), + (HsProtobuf.DotProtoField (HsProtobuf.FieldNumber 2) + (HsProtobuf.Map HsProtobuf.Int32 + (HsProtobuf.Named (HsProtobuf.Single "WrappedTrivial"))) + (HsProtobuf.Single "trivial") + [] + ""), + (HsProtobuf.DotProtoField (HsProtobuf.FieldNumber 3) + (HsProtobuf.Map HsProtobuf.SInt32 HsProtobuf.SInt32) + (HsProtobuf.Single "signed") + [] + "")] + +instance HsJSONPB.ToJSONPB MapTest where + toJSONPB (MapTest f1 f2 f3) + = (HsJSONPB.object ["prim" .= f1, "trivial" .= f2, "signed" .= f3]) + toEncodingPB (MapTest f1 f2 f3) + = (HsJSONPB.pairs ["prim" .= f1, "trivial" .= f2, "signed" .= f3]) + +instance HsJSONPB.FromJSONPB MapTest where + parseJSONPB + = (HsJSONPB.withObject "MapTest" + (\ obj -> + (Hs.pure MapTest) <*> obj .: "prim" <*> obj .: "trivial" <*> + obj .: "signed")) + +instance HsJSONPB.ToJSON MapTest where + toJSON = HsJSONPB.toAesonValue + toEncoding = HsJSONPB.toAesonEncoding + +instance HsJSONPB.FromJSON MapTest where + parseJSON = HsJSONPB.parseJSONPB + +instance HsJSONPB.ToSchema MapTest where + declareNamedSchema _ + = do let declare_prim = HsJSONPB.declareSchemaRef + mapTestPrim <- declare_prim Proxy.Proxy + let declare_trivial = HsJSONPB.declareSchemaRef + mapTestTrivial <- declare_trivial Proxy.Proxy + let declare_signed = HsJSONPB.declareSchemaRef + mapTestSigned <- declare_signed Proxy.Proxy + let _ = Hs.pure MapTest <*> HsJSONPB.asProxy declare_prim <*> + HsJSONPB.asProxy declare_trivial + <*> HsJSONPB.asProxy declare_signed + Hs.return + (HsJSONPB.NamedSchema{HsJSONPB._namedSchemaName = + Hs.Just "MapTest", + HsJSONPB._namedSchemaSchema = + Hs.mempty{HsJSONPB._schemaParamSchema = + Hs.mempty{HsJSONPB._paramSchemaType = + HsJSONPB.SwaggerObject}, + HsJSONPB._schemaProperties = + HsJSONPB.insOrdFromList + [("prim", mapTestPrim), + ("trivial", mapTestTrivial), + ("signed", mapTestSigned)]}}) diff --git a/gen/TestProtoImport.hs b/gen/TestProtoImport.hs --- a/gen/TestProtoImport.hs +++ b/gen/TestProtoImport.hs @@ -1,6 +1,8 @@ {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-unused-imports #-} {-# OPTIONS_GHC -fno-warn-name-shadowing #-} @@ -9,51 +11,65 @@ -- | Generated by Haskell protocol buffer compiler. DO NOT EDIT! module TestProtoImport where import qualified Prelude as Hs -import qualified Proto3.Suite.DhallPB as HsDhallPb -import qualified Proto3.Suite.DotProto as HsProtobuf -import qualified Proto3.Suite.Types as HsProtobuf import qualified Proto3.Suite.Class as HsProtobuf +import qualified Proto3.Suite.DotProto as HsProtobuf import qualified Proto3.Suite.JSONPB as HsJSONPB import Proto3.Suite.JSONPB ((.=), (.:)) +import qualified Proto3.Suite.Types as HsProtobuf import qualified Proto3.Wire as HsProtobuf -import Control.Applicative ((<*>), (<|>), (<$>)) import qualified Control.Applicative as Hs +import Control.Applicative ((<*>), (<|>), (<$>)) +import qualified Control.DeepSeq as Hs import qualified Control.Monad as Hs -import qualified Data.Text.Lazy as Hs (Text) import qualified Data.ByteString as Hs +import qualified Data.Coerce as Hs +import qualified Data.Int as Hs (Int16, Int32, Int64) +import qualified Data.List.NonEmpty as Hs (NonEmpty(..)) +import qualified Data.Map as Hs (Map, mapKeysMonotonic) +import qualified Data.Proxy as Proxy import qualified Data.String as Hs (fromString) +import qualified Data.Text.Lazy as Hs (Text) import qualified Data.Vector as Hs (Vector) -import qualified Data.Int as Hs (Int16, Int32, Int64) import qualified Data.Word as Hs (Word16, Word32, Word64) -import qualified Data.Proxy as Proxy -import qualified GHC.Generics as Hs import qualified GHC.Enum as Hs +import qualified GHC.Generics as Hs +import qualified Unsafe.Coerce as Hs data WithNesting = WithNesting{withNestingNestedMessage1 :: Hs.Maybe TestProtoImport.WithNesting_Nested, withNestingNestedMessage2 :: Hs.Maybe TestProtoImport.WithNesting_Nested} - deriving (Hs.Show, Hs.Eq, Hs.Ord, Hs.Generic) + deriving (Hs.Show, Hs.Eq, Hs.Ord, Hs.Generic, Hs.NFData) instance HsProtobuf.Named WithNesting where nameOf _ = (Hs.fromString "WithNesting") +instance HsProtobuf.HasDefault WithNesting + instance HsProtobuf.Message WithNesting where encodeMessage _ WithNesting{withNestingNestedMessage1 = withNestingNestedMessage1, withNestingNestedMessage2 = withNestingNestedMessage2} = (Hs.mconcat [(HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 1) - (HsProtobuf.Nested withNestingNestedMessage1)), + (Hs.coerce @(Hs.Maybe TestProtoImport.WithNesting_Nested) + @(HsProtobuf.Nested TestProtoImport.WithNesting_Nested) + withNestingNestedMessage1)), (HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 100) - (HsProtobuf.Nested withNestingNestedMessage2))]) + (Hs.coerce @(Hs.Maybe TestProtoImport.WithNesting_Nested) + @(HsProtobuf.Nested TestProtoImport.WithNesting_Nested) + withNestingNestedMessage2))]) decodeMessage _ = (Hs.pure WithNesting) <*> - ((Hs.pure HsProtobuf.nested) <*> + (Hs.coerce + @(_ (HsProtobuf.Nested TestProtoImport.WithNesting_Nested)) + @(_ (Hs.Maybe TestProtoImport.WithNesting_Nested)) (HsProtobuf.at HsProtobuf.decodeMessageField (HsProtobuf.FieldNumber 1))) <*> - ((Hs.pure HsProtobuf.nested) <*> + (Hs.coerce + @(_ (HsProtobuf.Nested TestProtoImport.WithNesting_Nested)) + @(_ (Hs.Maybe TestProtoImport.WithNesting_Nested)) (HsProtobuf.at HsProtobuf.decodeMessageField (HsProtobuf.FieldNumber 100))) dotProto _ @@ -61,12 +77,12 @@ (HsProtobuf.Prim (HsProtobuf.Named (HsProtobuf.Single "Nested"))) (HsProtobuf.Single "nestedMessage1") [] - Hs.Nothing), + ""), (HsProtobuf.DotProtoField (HsProtobuf.FieldNumber 100) (HsProtobuf.Prim (HsProtobuf.Named (HsProtobuf.Single "Nested"))) (HsProtobuf.Single "nestedMessage2") [] - Hs.Nothing)] + "")] instance HsJSONPB.ToJSONPB WithNesting where toJSONPB (WithNesting f1 f100) @@ -113,18 +129,16 @@ ("nestedMessage2", withNestingNestedMessage2)]}}) -instance HsDhallPb.Interpret WithNesting - -instance HsDhallPb.Inject WithNesting - data WithNesting_Nested = WithNesting_Nested{withNesting_NestedNestedField1 :: Hs.Int32, withNesting_NestedNestedField2 :: Hs.Int32} - deriving (Hs.Show, Hs.Eq, Hs.Ord, Hs.Generic) + deriving (Hs.Show, Hs.Eq, Hs.Ord, Hs.Generic, Hs.NFData) instance HsProtobuf.Named WithNesting_Nested where nameOf _ = (Hs.fromString "WithNesting_Nested") +instance HsProtobuf.HasDefault WithNesting_Nested + instance HsProtobuf.Message WithNesting_Nested where encodeMessage _ WithNesting_Nested{withNesting_NestedNestedField1 = @@ -147,12 +161,12 @@ (HsProtobuf.Prim HsProtobuf.Int32) (HsProtobuf.Single "nestedField1") [] - Hs.Nothing), + ""), (HsProtobuf.DotProtoField (HsProtobuf.FieldNumber 2) (HsProtobuf.Prim HsProtobuf.Int32) (HsProtobuf.Single "nestedField2") [] - Hs.Nothing)] + "")] instance HsJSONPB.ToJSONPB WithNesting_Nested where toJSONPB (WithNesting_Nested f1 f2) @@ -196,7 +210,3 @@ withNesting_NestedNestedField1), ("nestedField2", withNesting_NestedNestedField2)]}}) - -instance HsDhallPb.Interpret WithNesting_Nested - -instance HsDhallPb.Inject WithNesting_Nested diff --git a/gen/TestProtoOneof.hs b/gen/TestProtoOneof.hs --- a/gen/TestProtoOneof.hs +++ b/gen/TestProtoOneof.hs @@ -1,6 +1,8 @@ {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-unused-imports #-} {-# OPTIONS_GHC -fno-warn-name-shadowing #-} @@ -9,33 +11,39 @@ -- | Generated by Haskell protocol buffer compiler. DO NOT EDIT! module TestProtoOneof where import qualified Prelude as Hs -import qualified Proto3.Suite.DhallPB as HsDhallPb -import qualified Proto3.Suite.DotProto as HsProtobuf -import qualified Proto3.Suite.Types as HsProtobuf import qualified Proto3.Suite.Class as HsProtobuf +import qualified Proto3.Suite.DotProto as HsProtobuf import qualified Proto3.Suite.JSONPB as HsJSONPB import Proto3.Suite.JSONPB ((.=), (.:)) +import qualified Proto3.Suite.Types as HsProtobuf import qualified Proto3.Wire as HsProtobuf -import Control.Applicative ((<*>), (<|>), (<$>)) import qualified Control.Applicative as Hs +import Control.Applicative ((<*>), (<|>), (<$>)) +import qualified Control.DeepSeq as Hs import qualified Control.Monad as Hs -import qualified Data.Text.Lazy as Hs (Text) import qualified Data.ByteString as Hs +import qualified Data.Coerce as Hs +import qualified Data.Int as Hs (Int16, Int32, Int64) +import qualified Data.List.NonEmpty as Hs (NonEmpty(..)) +import qualified Data.Map as Hs (Map, mapKeysMonotonic) +import qualified Data.Proxy as Proxy import qualified Data.String as Hs (fromString) +import qualified Data.Text.Lazy as Hs (Text) import qualified Data.Vector as Hs (Vector) -import qualified Data.Int as Hs (Int16, Int32, Int64) import qualified Data.Word as Hs (Word16, Word32, Word64) -import qualified Data.Proxy as Proxy -import qualified GHC.Generics as Hs import qualified GHC.Enum as Hs +import qualified GHC.Generics as Hs +import qualified Unsafe.Coerce as Hs import qualified TestProtoOneofImport data DummyMsg = DummyMsg{dummyMsgDummy :: Hs.Int32} - deriving (Hs.Show, Hs.Eq, Hs.Ord, Hs.Generic) + deriving (Hs.Show, Hs.Eq, Hs.Ord, Hs.Generic, Hs.NFData) instance HsProtobuf.Named DummyMsg where nameOf _ = (Hs.fromString "DummyMsg") +instance HsProtobuf.HasDefault DummyMsg + instance HsProtobuf.Message DummyMsg where encodeMessage _ DummyMsg{dummyMsgDummy = dummyMsgDummy} = (Hs.mconcat @@ -50,7 +58,7 @@ (HsProtobuf.Prim HsProtobuf.Int32) (HsProtobuf.Single "dummy") [] - Hs.Nothing)] + "")] instance HsJSONPB.ToJSONPB DummyMsg where toJSONPB (DummyMsg f1) = (HsJSONPB.object ["dummy" .= f1]) @@ -84,28 +92,31 @@ HsJSONPB.insOrdFromList [("dummy", dummyMsgDummy)]}}) -instance HsDhallPb.Interpret DummyMsg - -instance HsDhallPb.Inject DummyMsg - data DummyEnum = DummyEnumDUMMY0 | DummyEnumDUMMY1 - deriving (Hs.Show, Hs.Bounded, Hs.Eq, Hs.Ord, Hs.Generic) + deriving (Hs.Show, Hs.Eq, Hs.Generic, Hs.NFData) instance HsProtobuf.Named DummyEnum where nameOf _ = (Hs.fromString "DummyEnum") -instance Hs.Enum DummyEnum where - toEnum 0 = DummyEnumDUMMY0 - toEnum 1 = DummyEnumDUMMY1 - toEnum i = (Hs.toEnumError "DummyEnum" i (0 :: Hs.Int, 1)) - fromEnum (DummyEnumDUMMY0) = 0 - fromEnum (DummyEnumDUMMY1) = 1 - succ (DummyEnumDUMMY0) = DummyEnumDUMMY1 - succ _ = Hs.succError "DummyEnum" - pred (DummyEnumDUMMY1) = DummyEnumDUMMY0 - pred _ = Hs.predError "DummyEnum" +instance HsProtobuf.HasDefault DummyEnum +instance Hs.Bounded DummyEnum where + minBound = DummyEnumDUMMY0 + maxBound = DummyEnumDUMMY1 + +instance Hs.Ord DummyEnum where + compare x y + = Hs.compare (HsProtobuf.fromProtoEnum x) + (HsProtobuf.fromProtoEnum y) + +instance HsProtobuf.ProtoEnum DummyEnum where + toProtoEnumMay 0 = Hs.Just DummyEnumDUMMY0 + toProtoEnumMay 1 = Hs.Just DummyEnumDUMMY1 + toProtoEnumMay _ = Hs.Nothing + fromProtoEnum (DummyEnumDUMMY0) = 0 + fromProtoEnum (DummyEnumDUMMY1) = 1 + instance HsJSONPB.ToJSONPB DummyEnum where toJSONPB x _ = HsJSONPB.enumFieldString x toEncodingPB x _ = HsJSONPB.enumFieldEncoding x @@ -122,20 +133,18 @@ instance HsJSONPB.FromJSON DummyEnum where parseJSON = HsJSONPB.parseJSONPB -instance HsDhallPb.Interpret DummyEnum - -instance HsDhallPb.Inject DummyEnum - instance HsProtobuf.Finite DummyEnum data Something = Something{somethingValue :: Hs.Int64, somethingAnother :: Hs.Int32, somethingPickOne :: Hs.Maybe SomethingPickOne} - deriving (Hs.Show, Hs.Eq, Hs.Ord, Hs.Generic) + deriving (Hs.Show, Hs.Eq, Hs.Ord, Hs.Generic, Hs.NFData) instance HsProtobuf.Named Something where nameOf _ = (Hs.fromString "Something") +instance HsProtobuf.HasDefault Something + instance HsProtobuf.Message Something where encodeMessage _ Something{somethingValue = somethingValue, @@ -143,9 +152,11 @@ somethingPickOne = somethingPickOne} = (Hs.mconcat [(HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 1) - (HsProtobuf.Signed somethingValue)), + (Hs.coerce @(Hs.Int64) @(HsProtobuf.Signed Hs.Int64) + somethingValue)), (HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 2) - (HsProtobuf.Signed somethingAnother)), + (Hs.coerce @(Hs.Int32) @(HsProtobuf.Signed Hs.Int32) + somethingAnother)), case somethingPickOne of Hs.Nothing -> Hs.mempty Hs.Just x @@ -158,20 +169,24 @@ (HsProtobuf.ForceEmit y)) SomethingPickOneDummyMsg1 y -> (HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 10) - (HsProtobuf.Nested (Hs.Just y))) + (Hs.coerce @(Hs.Maybe TestProtoOneof.DummyMsg) + @(HsProtobuf.Nested TestProtoOneof.DummyMsg) + (Hs.Just y))) SomethingPickOneDummyMsg2 y -> (HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 11) - (HsProtobuf.Nested (Hs.Just y))) + (Hs.coerce @(Hs.Maybe TestProtoOneof.DummyMsg) + @(HsProtobuf.Nested TestProtoOneof.DummyMsg) + (Hs.Just y))) SomethingPickOneDummyEnum y -> (HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 12) (HsProtobuf.ForceEmit y))]) decodeMessage _ = (Hs.pure Something) <*> - ((Hs.pure HsProtobuf.signed) <*> + (Hs.coerce @(_ (HsProtobuf.Signed Hs.Int64)) @(_ Hs.Int64) (HsProtobuf.at HsProtobuf.decodeMessageField (HsProtobuf.FieldNumber 1))) <*> - ((Hs.pure HsProtobuf.signed) <*> + (Hs.coerce @(_ (HsProtobuf.Signed Hs.Int32)) @(_ Hs.Int32) (HsProtobuf.at HsProtobuf.decodeMessageField (HsProtobuf.FieldNumber 2))) <*> @@ -184,10 +199,14 @@ HsProtobuf.decodeMessageField), ((HsProtobuf.FieldNumber 10), (Hs.pure (Hs.fmap SomethingPickOneDummyMsg1)) <*> - ((Hs.pure HsProtobuf.nested) <*> HsProtobuf.decodeMessageField)), + (Hs.coerce @(_ (HsProtobuf.Nested TestProtoOneof.DummyMsg)) + @(_ (Hs.Maybe TestProtoOneof.DummyMsg)) + HsProtobuf.decodeMessageField)), ((HsProtobuf.FieldNumber 11), (Hs.pure (Hs.fmap SomethingPickOneDummyMsg2)) <*> - ((Hs.pure HsProtobuf.nested) <*> HsProtobuf.decodeMessageField)), + (Hs.coerce @(_ (HsProtobuf.Nested TestProtoOneof.DummyMsg)) + @(_ (Hs.Maybe TestProtoOneof.DummyMsg)) + HsProtobuf.decodeMessageField)), ((HsProtobuf.FieldNumber 12), (Hs.pure (Hs.Just Hs.. SomethingPickOneDummyEnum)) <*> HsProtobuf.decodeMessageField)]) @@ -196,12 +215,12 @@ (HsProtobuf.Prim HsProtobuf.SInt64) (HsProtobuf.Single "value") [] - Hs.Nothing), + ""), (HsProtobuf.DotProtoField (HsProtobuf.FieldNumber 2) (HsProtobuf.Prim HsProtobuf.SInt32) (HsProtobuf.Single "another") [] - Hs.Nothing)] + "")] instance HsJSONPB.ToJSONPB Something where toJSONPB (Something f1 f2 f4_or_f9_or_f10_or_f11_or_f12) @@ -299,17 +318,13 @@ ("another", somethingAnother), ("pickOne", somethingPickOne)]}}) -instance HsDhallPb.Interpret Something - -instance HsDhallPb.Inject Something - data SomethingPickOne = SomethingPickOneName Hs.Text | SomethingPickOneSomeid Hs.Int32 | SomethingPickOneDummyMsg1 TestProtoOneof.DummyMsg | SomethingPickOneDummyMsg2 TestProtoOneof.DummyMsg | SomethingPickOneDummyEnum (HsProtobuf.Enumerated TestProtoOneof.DummyEnum) - deriving (Hs.Show, Hs.Eq, Hs.Ord, Hs.Generic) + deriving (Hs.Show, Hs.Eq, Hs.Ord, Hs.Generic, Hs.NFData) instance HsProtobuf.Named SomethingPickOne where nameOf _ = (Hs.fromString "SomethingPickOne") @@ -353,18 +368,16 @@ HsJSONPB._schemaMinProperties = Hs.Just 1, HsJSONPB._schemaMaxProperties = Hs.Just 1}}) -instance HsDhallPb.Interpret SomethingPickOne - -instance HsDhallPb.Inject SomethingPickOne - data OneofFirst = OneofFirst{oneofFirstFirst :: Hs.Maybe OneofFirstFirst, oneofFirstLast :: Hs.Int32} - deriving (Hs.Show, Hs.Eq, Hs.Ord, Hs.Generic) + deriving (Hs.Show, Hs.Eq, Hs.Ord, Hs.Generic, Hs.NFData) instance HsProtobuf.Named OneofFirst where nameOf _ = (Hs.fromString "OneofFirst") +instance HsProtobuf.HasDefault OneofFirst + instance HsProtobuf.Message OneofFirst where encodeMessage _ OneofFirst{oneofFirstFirst = oneofFirstFirst, @@ -399,7 +412,7 @@ (HsProtobuf.Prim HsProtobuf.Int32) (HsProtobuf.Single "last") [] - Hs.Nothing)] + "")] instance HsJSONPB.ToJSONPB OneofFirst where toJSONPB (OneofFirst f1_or_f2 f3) @@ -473,13 +486,9 @@ [("first", oneofFirstFirst), ("last", oneofFirstLast)]}}) -instance HsDhallPb.Interpret OneofFirst - -instance HsDhallPb.Inject OneofFirst - data OneofFirstFirst = OneofFirstFirstChoice1 Hs.Text | OneofFirstFirstChoice2 Hs.Text - deriving (Hs.Show, Hs.Eq, Hs.Ord, Hs.Generic) + deriving (Hs.Show, Hs.Eq, Hs.Ord, Hs.Generic, Hs.NFData) instance HsProtobuf.Named OneofFirstFirst where nameOf _ = (Hs.fromString "OneofFirstFirst") @@ -508,18 +517,16 @@ HsJSONPB._schemaMinProperties = Hs.Just 1, HsJSONPB._schemaMaxProperties = Hs.Just 1}}) -instance HsDhallPb.Interpret OneofFirstFirst - -instance HsDhallPb.Inject OneofFirstFirst - data OneofMiddle = OneofMiddle{oneofMiddleFirst :: Hs.Int32, oneofMiddleMiddle :: Hs.Maybe OneofMiddleMiddle, oneofMiddleLast :: Hs.Int32} - deriving (Hs.Show, Hs.Eq, Hs.Ord, Hs.Generic) + deriving (Hs.Show, Hs.Eq, Hs.Ord, Hs.Generic, Hs.NFData) instance HsProtobuf.Named OneofMiddle where nameOf _ = (Hs.fromString "OneofMiddle") +instance HsProtobuf.HasDefault OneofMiddle + instance HsProtobuf.Message OneofMiddle where encodeMessage _ OneofMiddle{oneofMiddleFirst = oneofMiddleFirst, @@ -560,12 +567,12 @@ (HsProtobuf.Prim HsProtobuf.Int32) (HsProtobuf.Single "first") [] - Hs.Nothing), + ""), (HsProtobuf.DotProtoField (HsProtobuf.FieldNumber 4) (HsProtobuf.Prim HsProtobuf.Int32) (HsProtobuf.Single "last") [] - Hs.Nothing)] + "")] instance HsJSONPB.ToJSONPB OneofMiddle where toJSONPB (OneofMiddle f1 f2_or_f3 f4) @@ -651,13 +658,9 @@ ("middle", oneofMiddleMiddle), ("last", oneofMiddleLast)]}}) -instance HsDhallPb.Interpret OneofMiddle - -instance HsDhallPb.Inject OneofMiddle - data OneofMiddleMiddle = OneofMiddleMiddleChoice1 Hs.Text | OneofMiddleMiddleChoice2 Hs.Text - deriving (Hs.Show, Hs.Eq, Hs.Ord, Hs.Generic) + deriving (Hs.Show, Hs.Eq, Hs.Ord, Hs.Generic, Hs.NFData) instance HsProtobuf.Named OneofMiddleMiddle where nameOf _ = (Hs.fromString "OneofMiddleMiddle") @@ -686,17 +689,15 @@ HsJSONPB._schemaMinProperties = Hs.Just 1, HsJSONPB._schemaMaxProperties = Hs.Just 1}}) -instance HsDhallPb.Interpret OneofMiddleMiddle - -instance HsDhallPb.Inject OneofMiddleMiddle - data WithImported = WithImported{withImportedPickOne :: Hs.Maybe WithImportedPickOne} - deriving (Hs.Show, Hs.Eq, Hs.Ord, Hs.Generic) + deriving (Hs.Show, Hs.Eq, Hs.Ord, Hs.Generic, Hs.NFData) instance HsProtobuf.Named WithImported where nameOf _ = (Hs.fromString "WithImported") +instance HsProtobuf.HasDefault WithImported + instance HsProtobuf.Message WithImported where encodeMessage _ WithImported{withImportedPickOne = withImportedPickOne} @@ -707,19 +708,27 @@ -> case x of WithImportedPickOneDummyMsg1 y -> (HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 1) - (HsProtobuf.Nested (Hs.Just y))) + (Hs.coerce @(Hs.Maybe TestProtoOneof.DummyMsg) + @(HsProtobuf.Nested TestProtoOneof.DummyMsg) + (Hs.Just y))) WithImportedPickOneWithOneof y -> (HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 2) - (HsProtobuf.Nested (Hs.Just y)))]) + (Hs.coerce @(Hs.Maybe TestProtoOneofImport.WithOneof) + @(HsProtobuf.Nested TestProtoOneofImport.WithOneof) + (Hs.Just y)))]) decodeMessage _ = (Hs.pure WithImported) <*> (HsProtobuf.oneof Hs.Nothing [((HsProtobuf.FieldNumber 1), (Hs.pure (Hs.fmap WithImportedPickOneDummyMsg1)) <*> - ((Hs.pure HsProtobuf.nested) <*> HsProtobuf.decodeMessageField)), + (Hs.coerce @(_ (HsProtobuf.Nested TestProtoOneof.DummyMsg)) + @(_ (Hs.Maybe TestProtoOneof.DummyMsg)) + HsProtobuf.decodeMessageField)), ((HsProtobuf.FieldNumber 2), (Hs.pure (Hs.fmap WithImportedPickOneWithOneof)) <*> - ((Hs.pure HsProtobuf.nested) <*> HsProtobuf.decodeMessageField))]) + (Hs.coerce @(_ (HsProtobuf.Nested TestProtoOneofImport.WithOneof)) + @(_ (Hs.Maybe TestProtoOneofImport.WithOneof)) + HsProtobuf.decodeMessageField))]) dotProto _ = [] instance HsJSONPB.ToJSONPB WithImported where @@ -794,13 +803,9 @@ HsJSONPB.insOrdFromList [("pickOne", withImportedPickOne)]}}) -instance HsDhallPb.Interpret WithImported - -instance HsDhallPb.Inject WithImported - data WithImportedPickOne = WithImportedPickOneDummyMsg1 TestProtoOneof.DummyMsg | WithImportedPickOneWithOneof TestProtoOneofImport.WithOneof - deriving (Hs.Show, Hs.Eq, Hs.Ord, Hs.Generic) + deriving (Hs.Show, Hs.Eq, Hs.Ord, Hs.Generic, Hs.NFData) instance HsProtobuf.Named WithImportedPickOne where nameOf _ = (Hs.fromString "WithImportedPickOne") @@ -829,7 +834,3 @@ withImportedPickOneWithOneof)], HsJSONPB._schemaMinProperties = Hs.Just 1, HsJSONPB._schemaMaxProperties = Hs.Just 1}}) - -instance HsDhallPb.Interpret WithImportedPickOne - -instance HsDhallPb.Inject WithImportedPickOne diff --git a/gen/TestProtoOneofImport.hs b/gen/TestProtoOneofImport.hs --- a/gen/TestProtoOneofImport.hs +++ b/gen/TestProtoOneofImport.hs @@ -1,6 +1,8 @@ {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-unused-imports #-} {-# OPTIONS_GHC -fno-warn-name-shadowing #-} @@ -9,33 +11,112 @@ -- | Generated by Haskell protocol buffer compiler. DO NOT EDIT! module TestProtoOneofImport where import qualified Prelude as Hs -import qualified Proto3.Suite.DhallPB as HsDhallPb -import qualified Proto3.Suite.DotProto as HsProtobuf -import qualified Proto3.Suite.Types as HsProtobuf import qualified Proto3.Suite.Class as HsProtobuf +import qualified Proto3.Suite.DotProto as HsProtobuf import qualified Proto3.Suite.JSONPB as HsJSONPB import Proto3.Suite.JSONPB ((.=), (.:)) +import qualified Proto3.Suite.Types as HsProtobuf import qualified Proto3.Wire as HsProtobuf -import Control.Applicative ((<*>), (<|>), (<$>)) import qualified Control.Applicative as Hs +import Control.Applicative ((<*>), (<|>), (<$>)) +import qualified Control.DeepSeq as Hs import qualified Control.Monad as Hs -import qualified Data.Text.Lazy as Hs (Text) import qualified Data.ByteString as Hs +import qualified Data.Coerce as Hs +import qualified Data.Int as Hs (Int16, Int32, Int64) +import qualified Data.List.NonEmpty as Hs (NonEmpty(..)) +import qualified Data.Map as Hs (Map, mapKeysMonotonic) +import qualified Data.Proxy as Proxy import qualified Data.String as Hs (fromString) +import qualified Data.Text.Lazy as Hs (Text) import qualified Data.Vector as Hs (Vector) -import qualified Data.Int as Hs (Int16, Int32, Int64) import qualified Data.Word as Hs (Word16, Word32, Word64) -import qualified Data.Proxy as Proxy -import qualified GHC.Generics as Hs import qualified GHC.Enum as Hs +import qualified GHC.Generics as Hs +import qualified Unsafe.Coerce as Hs +data AMessage = AMessage{amessageX :: Hs.Text, + amessageY :: Hs.Int32} + deriving (Hs.Show, Hs.Eq, Hs.Ord, Hs.Generic, Hs.NFData) + +instance HsProtobuf.Named AMessage where + nameOf _ = (Hs.fromString "AMessage") + +instance HsProtobuf.HasDefault AMessage + +instance HsProtobuf.Message AMessage where + encodeMessage _ + AMessage{amessageX = amessageX, amessageY = amessageY} + = (Hs.mconcat + [(HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 1) + amessageX), + (HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 2) + amessageY)]) + decodeMessage _ + = (Hs.pure AMessage) <*> + (HsProtobuf.at HsProtobuf.decodeMessageField + (HsProtobuf.FieldNumber 1)) + <*> + (HsProtobuf.at HsProtobuf.decodeMessageField + (HsProtobuf.FieldNumber 2)) + dotProto _ + = [(HsProtobuf.DotProtoField (HsProtobuf.FieldNumber 1) + (HsProtobuf.Prim HsProtobuf.String) + (HsProtobuf.Single "x") + [] + ""), + (HsProtobuf.DotProtoField (HsProtobuf.FieldNumber 2) + (HsProtobuf.Prim HsProtobuf.Int32) + (HsProtobuf.Single "y") + [] + "")] + +instance HsJSONPB.ToJSONPB AMessage where + toJSONPB (AMessage f1 f2) + = (HsJSONPB.object ["x" .= f1, "y" .= f2]) + toEncodingPB (AMessage f1 f2) + = (HsJSONPB.pairs ["x" .= f1, "y" .= f2]) + +instance HsJSONPB.FromJSONPB AMessage where + parseJSONPB + = (HsJSONPB.withObject "AMessage" + (\ obj -> (Hs.pure AMessage) <*> obj .: "x" <*> obj .: "y")) + +instance HsJSONPB.ToJSON AMessage where + toJSON = HsJSONPB.toAesonValue + toEncoding = HsJSONPB.toAesonEncoding + +instance HsJSONPB.FromJSON AMessage where + parseJSON = HsJSONPB.parseJSONPB + +instance HsJSONPB.ToSchema AMessage where + declareNamedSchema _ + = do let declare_x = HsJSONPB.declareSchemaRef + amessageX <- declare_x Proxy.Proxy + let declare_y = HsJSONPB.declareSchemaRef + amessageY <- declare_y Proxy.Proxy + let _ = Hs.pure AMessage <*> HsJSONPB.asProxy declare_x <*> + HsJSONPB.asProxy declare_y + Hs.return + (HsJSONPB.NamedSchema{HsJSONPB._namedSchemaName = + Hs.Just "AMessage", + HsJSONPB._namedSchemaSchema = + Hs.mempty{HsJSONPB._schemaParamSchema = + Hs.mempty{HsJSONPB._paramSchemaType = + HsJSONPB.SwaggerObject}, + HsJSONPB._schemaProperties = + HsJSONPB.insOrdFromList + [("x", amessageX), ("y", amessageY)]}}) + data WithOneof = WithOneof{withOneofPickOne :: Hs.Maybe WithOneofPickOne} - deriving (Hs.Show, Hs.Eq, Hs.Ord, Hs.Generic) + deriving (Hs.Show, Hs.Eq, Hs.Ord, Hs.Generic, Hs.NFData) instance HsProtobuf.Named WithOneof where nameOf _ = (Hs.fromString "WithOneof") +instance HsProtobuf.HasDefault WithOneof + instance HsProtobuf.Message WithOneof where encodeMessage _ WithOneof{withOneofPickOne = withOneofPickOne} = (Hs.mconcat @@ -48,7 +129,12 @@ (HsProtobuf.ForceEmit y)) WithOneofPickOneB y -> (HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 2) - (HsProtobuf.ForceEmit y))]) + (HsProtobuf.ForceEmit y)) + WithOneofPickOneC y + -> (HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 3) + (Hs.coerce @(Hs.Maybe TestProtoOneofImport.AMessage) + @(HsProtobuf.Nested TestProtoOneofImport.AMessage) + (Hs.Just y)))]) decodeMessage _ = (Hs.pure WithOneof) <*> (HsProtobuf.oneof Hs.Nothing @@ -57,16 +143,22 @@ HsProtobuf.decodeMessageField), ((HsProtobuf.FieldNumber 2), (Hs.pure (Hs.Just Hs.. WithOneofPickOneB)) <*> - HsProtobuf.decodeMessageField)]) + HsProtobuf.decodeMessageField), + ((HsProtobuf.FieldNumber 3), + (Hs.pure (Hs.fmap WithOneofPickOneC)) <*> + (Hs.coerce @(_ (HsProtobuf.Nested TestProtoOneofImport.AMessage)) + @(_ (Hs.Maybe TestProtoOneofImport.AMessage)) + HsProtobuf.decodeMessageField))]) dotProto _ = [] instance HsJSONPB.ToJSONPB WithOneof where - toJSONPB (WithOneof f1_or_f2) + toJSONPB (WithOneof f1_or_f2_or_f3) = (HsJSONPB.object [(let encodePickOne - = (case f1_or_f2 of + = (case f1_or_f2_or_f3 of Hs.Just (WithOneofPickOneA f1) -> (HsJSONPB.pair "a" f1) Hs.Just (WithOneofPickOneB f2) -> (HsJSONPB.pair "b" f2) + Hs.Just (WithOneofPickOneC f3) -> (HsJSONPB.pair "c" f3) Hs.Nothing -> Hs.mempty) in \ options -> @@ -74,12 +166,13 @@ ("pickOne" .= (HsJSONPB.objectOrNull [encodePickOne] options)) options else encodePickOne options)]) - toEncodingPB (WithOneof f1_or_f2) + toEncodingPB (WithOneof f1_or_f2_or_f3) = (HsJSONPB.pairs [(let encodePickOne - = (case f1_or_f2 of + = (case f1_or_f2_or_f3 of Hs.Just (WithOneofPickOneA f1) -> (HsJSONPB.pair "a" f1) Hs.Just (WithOneofPickOneB f2) -> (HsJSONPB.pair "b" f2) + Hs.Just (WithOneofPickOneC f3) -> (HsJSONPB.pair "c" f3) Hs.Nothing -> Hs.mempty) in \ options -> @@ -99,6 +192,8 @@ (HsJSONPB.parseField parseObj "a"), Hs.Just Hs.. WithOneofPickOneB <$> (HsJSONPB.parseField parseObj "b"), + Hs.Just Hs.. WithOneofPickOneC <$> + (HsJSONPB.parseField parseObj "c"), Hs.pure Hs.Nothing] in ((obj .: "pickOne") Hs.>>= @@ -128,13 +223,10 @@ HsJSONPB.insOrdFromList [("pickOne", withOneofPickOne)]}}) -instance HsDhallPb.Interpret WithOneof - -instance HsDhallPb.Inject WithOneof - data WithOneofPickOne = WithOneofPickOneA Hs.Text | WithOneofPickOneB Hs.Int32 - deriving (Hs.Show, Hs.Eq, Hs.Ord, Hs.Generic) + | WithOneofPickOneC TestProtoOneofImport.AMessage + deriving (Hs.Show, Hs.Eq, Hs.Ord, Hs.Generic, Hs.NFData) instance HsProtobuf.Named WithOneofPickOne where nameOf _ = (Hs.fromString "WithOneofPickOne") @@ -147,6 +239,9 @@ let declare_b = HsJSONPB.declareSchemaRef withOneofPickOneB <- declare_b Proxy.Proxy let _ = Hs.pure WithOneofPickOneB <*> HsJSONPB.asProxy declare_b + let declare_c = HsJSONPB.declareSchemaRef + withOneofPickOneC <- declare_c Proxy.Proxy + let _ = Hs.pure WithOneofPickOneC <*> HsJSONPB.asProxy declare_c Hs.return (HsJSONPB.NamedSchema{HsJSONPB._namedSchemaName = Hs.Just "WithOneofPickOne", @@ -157,10 +252,7 @@ HsJSONPB._schemaProperties = HsJSONPB.insOrdFromList [("a", withOneofPickOneA), - ("b", withOneofPickOneB)], + ("b", withOneofPickOneB), + ("c", withOneofPickOneC)], HsJSONPB._schemaMinProperties = Hs.Just 1, HsJSONPB._schemaMaxProperties = Hs.Just 1}}) - -instance HsDhallPb.Interpret WithOneofPickOne - -instance HsDhallPb.Inject WithOneofPickOne diff --git a/proto3-suite.cabal b/proto3-suite.cabal --- a/proto3-suite.cabal +++ b/proto3-suite.cabal @@ -1,5 +1,5 @@ name: proto3-suite -version: 0.3.0.0 +version: 0.4.0.0 synopsis: A low level library for writing out data in the Protocol Buffers wire format license: Apache-2.0 author: Awake Security @@ -27,6 +27,7 @@ Proto3.Suite.DotProto Proto3.Suite.DotProto.Generate Proto3.Suite.DotProto.AST + Proto3.Suite.DotProto.AST.Lens Proto3.Suite.DotProto.Parsing Proto3.Suite.DotProto.Rendering Proto3.Suite.JSONPB @@ -59,12 +60,12 @@ parsers >= 0.12 && <0.13, pretty ==1.1.*, pretty-show >= 1.6.12 && < 2.0, - proto3-wire == 1.0.*, - QuickCheck >=2.10 && <2.13, + proto3-wire == 1.1.*, + QuickCheck >=2.10 && <2.14, quickcheck-instances < 0.4, safe ==0.3.*, semigroups ==0.18.*, - swagger2 >=2.1.6 && <2.4, + swagger2 >=2.1.6 && <2.5, system-filepath, text >= 0.2 && <1.3, transformers >=0.4 && <0.6, @@ -94,7 +95,7 @@ hs-source-dirs: tests gen default-language: Haskell2010 build-depends: base >=4.8 && <5.0, - QuickCheck >=2.10 && <2.13, + QuickCheck >=2.10 && <2.14, aeson >= 1.1.1.0 && < 1.5, attoparsec >= 0.13.0.1, base >=4.8 && <5.0, @@ -102,10 +103,13 @@ bytestring >=0.10.6.0 && <0.11.0, cereal >= 0.5.1 && <0.6, containers >=0.5 && < 0.7, + deepseq ==1.4.*, doctest, + generic-arbitrary, + mtl ==2.2.*, pretty-show >= 1.6.12 && < 2.0, proto3-suite, - proto3-wire == 1.0.*, + proto3-wire == 1.1.*, semigroups ==0.18.*, swagger2, tasty >= 0.11 && <1.2, @@ -122,7 +126,7 @@ hs-source-dirs: tools/compile-proto-file default-language: Haskell2010 build-depends: base >=4.8 && <5.0 - , optparse-generic + , optparse-applicative , proto3-suite , system-filepath , text @@ -135,9 +139,10 @@ default-language: Haskell2010 build-depends: base >=4.8 && <5.0 , containers >=0.5 && <0.7 + , mtl ==2.2.* , optparse-generic , proto3-suite - , proto3-wire == 1.0.* + , proto3-wire == 1.1.* , range-set-list >=0.1.2 && <0.2 , system-filepath , turtle diff --git a/src/Proto3/Suite/Class.hs b/src/Proto3/Suite/Class.hs --- a/src/Proto3/Suite/Class.hs +++ b/src/Proto3/Suite/Class.hs @@ -97,6 +97,7 @@ import qualified Data.ByteString.Base64 as B64 import qualified Data.ByteString.Lazy as BL import Data.Coerce (coerce) +import qualified Data.Foldable as Foldable import Data.Functor (($>)) import Data.Int (Int32, Int64) import qualified Data.Map as M @@ -115,20 +116,19 @@ import Proto3.Suite.DotProto as DotProto import Proto3.Suite.Types as Wire import Proto3.Wire +import Proto3.Wire.Class (ProtoEnum(..)) import Proto3.Wire.Decode (ParseError, Parser (..), RawField, RawMessage, RawPrimitive, runParser) import qualified Proto3.Wire.Decode as Decode import qualified Proto3.Wire.Encode as Encode -import Safe (toEnumMay) -- | A class for types with default values per the protocol buffers spec. class HasDefault a where -- | The default value for this type. def :: a - -- | Numeric types default to zero - default def :: Num a => a - def = 0 + default def :: (Generic a, GenericHasDefault (Rep a)) => a + def = to (genericDef @(Rep a)) isDefault :: a -> Bool @@ -145,19 +145,29 @@ | isDefault p = mempty | otherwise = f p -instance HasDefault Int32 -instance HasDefault Int64 -instance HasDefault Word32 -instance HasDefault Word64 -instance HasDefault (Signed Int32) -instance HasDefault (Signed Int64) -instance HasDefault (Fixed Word32) -instance HasDefault (Fixed Word64) -instance HasDefault (Signed (Fixed Int32)) -instance HasDefault (Signed (Fixed Int64)) -instance HasDefault Float -instance HasDefault Double +-- -- | Numeric types default to zero +-- instance Num a => HasDefault a where def = 0 +instance HasDefault Int where def = 0 +instance HasDefault Integer where def = 0 + +instance HasDefault Int32 where def = 0 +instance HasDefault Int64 where def = 0 +instance HasDefault Word32 where def = 0 +instance HasDefault Word64 where def = 0 +instance HasDefault (Signed Int32) where def = 0 +instance HasDefault (Signed Int64) where def = 0 +-- | Used in generated records to represent @sfixed32@ +instance HasDefault (Fixed Int32) where def = 0 +-- | Used in generated records to represent @sfixed64@ +instance HasDefault (Fixed Int64) where def = 0 +instance HasDefault (Fixed Word32) where def = 0 +instance HasDefault (Fixed Word64) where def = 0 +instance HasDefault (Signed (Fixed Int32)) where def = 0 +instance HasDefault (Signed (Fixed Int64)) where def = 0 +instance HasDefault Float where def = 0 +instance HasDefault Double where def = 0 + instance HasDefault Bool where def = False @@ -173,12 +183,9 @@ instance HasDefault BL.ByteString where def = mempty -instance (Bounded e, Enum e) => HasDefault (Enumerated e) where - def = - case toEnumMay 0 of - Nothing -> Enumerated (Left 0) - Just x -> Enumerated (Right x) - isDefault = (== 0) . either id fromEnum . enumerated +instance ProtoEnum e => HasDefault (Enumerated e) where + def = Enumerated $ maybe (Left 0) Right (toProtoEnumMay 0) + isDefault = (== 0) . either id fromProtoEnum . enumerated instance HasDefault (UnpackedVec a) where def = mempty @@ -215,20 +222,22 @@ def = M.empty isDefault = M.null --- TODO: Determine if we have a reason for rendering fixed32/sfixed as Fixed --- Word32/Int32 in generated datatypes; for other field types, we omit the --- newtype wrappers in the type signature but un/wrap them as needed in the --- encode/decodeMessage implementations. These Fixed wrappers can probably be --- removed and the type interface would be more consistent with other types, but --- until that occurs, the following two instances are needed. --- --- Tracked by https://github.com/awakesecurity/proto3-suite/issues/30. - --- | Used in generated records to represent @sfixed32@ -instance HasDefault (Fixed Int32) - --- | Used in generated records to represent @sfixed64@ -instance HasDefault (Fixed Int64) +class GenericHasDefault (f :: * -> *) where + genericDef :: f x +instance HasDefault f => GenericHasDefault (K1 i f) where + genericDef = K1 (def @f) +instance (GenericHasDefault f, GenericHasDefault g) => GenericHasDefault (f :*: g) where + genericDef = genericDef @f :*: genericDef @g +instance (GenericHasDefault f, GenericHasDefault g) => GenericHasDefault (f :+: g) where + genericDef = L1 (genericDef @f) +instance GenericHasDefault U1 where + genericDef = U1 -- unit constructor +instance (Constructor i, GenericHasDefault f) => GenericHasDefault (C1 i f) where + genericDef = M1 (genericDef @f) +instance (Datatype i, GenericHasDefault f) => GenericHasDefault (D1 i f) where + genericDef = M1 (genericDef @f) +instance (Selector i, GenericHasDefault f) => GenericHasDefault (S1 i f) where + genericDef = M1 (genericDef @f) -- | This class captures those types whose names need to appear in .proto files. -- @@ -251,46 +260,44 @@ -- -- This class can be derived whenever a sum type is an instance of 'Generic', -- and only consists of zero-argument constructors. The derived instance should --- be compatible with derived `Enum` instances, in the sense that +-- be compatible with `ProtoEnum` instances, in the sense that -- --- > map (toEnum . fst) enumerate +-- > map (fromJust . toProtoEnumMay . snd) enumerate -- -- should enumerate all values of the type without runtime errors. -class Enum a => Finite a where +class ProtoEnum a => Finite a where -- | Enumerate values of a finite type, along with names of constructors. - enumerate :: IsString string => Proxy# a -> [(string, Int)] + enumerate :: IsString string => Proxy# a -> [(string, Int32)] - default enumerate :: (IsString string, GenericFinite (Rep a)) - => Proxy# a -> [(string, Int)] - enumerate _ = snd (genericEnumerate (proxy# :: Proxy# (Rep a)) 0) + default enumerate :: + (IsString string, Generic a, GenericFinite (Rep a)) => + Proxy# a -> [(string, Int32)] + enumerate _ = + fmap (fromProtoEnum . (to :: Rep a p -> a)) <$> genericEnumerate -- | Generate metadata for an enum type. enum :: (Finite e, Named e) => Proxy# e -> DotProtoDefinition -enum pr = DotProtoEnum (Single $ nameOf pr) (map enumField $ enumerate pr) +enum pr = DotProtoEnum "" (Single $ nameOf pr) (map enumField $ enumerate pr) where enumField (name, value) = DotProtoEnumField (Single name) value [] class GenericFinite (f :: * -> *) where - genericEnumerate :: IsString string => Proxy# f -> Int -> (Int, [(string, Int)]) + genericEnumerate :: IsString string => [(string, f p)] instance ( GenericFinite f , GenericFinite g ) => GenericFinite (f :+: g) where - genericEnumerate _ i = - let (j, e1) = genericEnumerate (proxy# :: Proxy# f) i - (k, e2) = genericEnumerate (proxy# :: Proxy# g) j - in (k, e1 <> e2) + genericEnumerate = + (fmap L1 <$> genericEnumerate) <> + (fmap R1 <$> genericEnumerate) -instance Constructor c => GenericFinite (M1 C c f) where - genericEnumerate _ i = (i + 1, [ (fromString name, i) ]) +instance Constructor c => GenericFinite (M1 C c U1) where + genericEnumerate = [ (fromString name, M1 U1) ] where name = conName (undefined :: M1 C c f ()) instance GenericFinite f => GenericFinite (M1 D t f) where - genericEnumerate _ = genericEnumerate (proxy# :: Proxy# f) - -instance GenericFinite f => GenericFinite (M1 S t f) where - genericEnumerate _ = genericEnumerate (proxy# :: Proxy# f) + genericEnumerate = fmap M1 <$> genericEnumerate -- | This class captures those types which correspond to primitives in -- the protocol buffers specification. @@ -373,7 +380,7 @@ primType _ = SFixed64 instance Primitive Bool where - encodePrimitive = Encode.enum + encodePrimitive = Encode.bool decodePrimitive = Decode.bool primType _ = Bool @@ -407,11 +414,12 @@ decodePrimitive = Decode.lazyByteString primType _ = Bytes -instance forall e. (Bounded e, Named e, Enum e) => Primitive (Enumerated e) where - encodePrimitive num = Encode.enum num . enumify . enumerated - where enumify (Left i) = i - enumify (Right x) = fromEnum x - decodePrimitive = coerce @(Parser RawPrimitive (Either Int e)) @(Parser RawPrimitive (Enumerated e)) Decode.enum +instance forall e. (Named e, ProtoEnum e) => Primitive (Enumerated e) where + encodePrimitive num = either (Encode.int32 num) (Encode.enum num) . enumerated + decodePrimitive = coerce + @(Parser RawPrimitive (Either Int32 e)) + @(Parser RawPrimitive (Enumerated e)) + Decode.enum primType _ = Named (Single (nameOf (proxy# :: Proxy# e))) instance (Primitive a) => Primitive (ForceEmit a) where @@ -448,7 +456,7 @@ , dotProtoFieldType = ty , dotProtoFieldName = Anonymous , dotProtoFieldOptions = packingOption - , dotProtoFieldComment = Nothing + , dotProtoFieldComment = "" } where packingOption = maybe [] (toDotProtoOption . isPacked) packing @@ -475,7 +483,7 @@ instance MessageField TL.Text instance MessageField B.ByteString instance MessageField BL.ByteString -instance (Bounded e, Named e, Enum e) => MessageField (Enumerated e) +instance (Named e, ProtoEnum e) => MessageField (Enumerated e) instance (Ord k, Primitive k, MessageField k, Primitive v, MessageField v) => MessageField (M.Map k v) where encodeMessageField num = foldMap (Encode.embedded num . encodeMessage (fieldNumber 1)) . M.toList @@ -484,7 +492,7 @@ -- -- > When parsing from the wire or when merging, if there are duplicate map -- > keys the last key seen is used. - decodeMessageField = M.fromList . fromList + decodeMessageField = M.fromList . Foldable.toList <$> repeated (Decode.embedded' (decodeMessage (fieldNumber 1))) protoType _ = messageField (Map (primType (proxy# :: Proxy# k)) (primType (proxy# :: Proxy# v))) Nothing @@ -495,7 +503,7 @@ -- -- > When parsing from the wire or when merging, if there are duplicate map -- > keys the last key seen is used. - decodeMessageField = M.fromList . fromList + decodeMessageField = M.fromList . Foldable.toList <$> repeated (Decode.embedded' (decodeMessage (fieldNumber 1))) protoType _ = messageField (Map (primType (proxy# :: Proxy# k)) (Named . Single $ nameOf (proxy# :: Proxy# v))) Nothing @@ -511,30 +519,32 @@ instance Primitive a => MessageField (UnpackedVec a) where encodeMessageField = foldMap . encodePrimitive - decodeMessageField = UnpackedVec . fromList <$> repeated decodePrimitive + decodeMessageField = + UnpackedVec . fromList . Foldable.toList <$> repeated decodePrimitive protoType _ = messageField (Repeated $ primType (proxy# :: Proxy# a)) (Just DotProto.UnpackedField) instance forall a. (Named a, Message a) => MessageField (NestedVec a) where encodeMessageField fn = foldMap (Encode.embedded fn . encodeMessage (fieldNumber 1)) . coerce @(NestedVec a) @(Vector a) - decodeMessageField = fmap (coerce @(Vector a) @(NestedVec a) . fromList) - (repeated (Decode.embedded' oneMsg)) + decodeMessageField = + fmap (coerce @(Vector a) @(NestedVec a) . fromList . Foldable.toList) + (repeated (Decode.embedded' oneMsg)) where oneMsg :: Parser RawMessage a oneMsg = decodeMessage (fieldNumber 1) protoType _ = messageField (NestedRepeated . Named . Single $ nameOf (proxy# :: Proxy# a)) Nothing -instance (Bounded e, Enum e, Named e) => MessageField (PackedVec (Enumerated e)) where +instance (Named e, ProtoEnum e) => MessageField (PackedVec (Enumerated e)) where encodeMessageField fn = omittingDefault (Encode.packedVarints fn) . foldMap omit where -- omit values which are outside the enum range omit :: Enumerated e -> PackedVec Word64 - omit (Enumerated (Right e)) = pure . fromIntegral . fromEnum $ e + omit (Enumerated (Right e)) = pure . fromIntegral . fromProtoEnum $ e omit _ = mempty decodeMessageField = decodePacked (foldMap retain <$> Decode.packedVarints @Word64) where -- retain only those values which are inside the enum range - retain = foldMap (pure . Enumerated. Right) . toEnumMay . fromIntegral + retain = foldMap (pure . Enumerated . Right) . toProtoEnumMay . fromIntegral protoType _ = messageField (Repeated . Named . Single $ nameOf (proxy# :: Proxy# e)) (Just DotProto.PackedField) instance MessageField (PackedVec Bool) where @@ -613,7 +623,7 @@ @(Parser RawField (Commented comments e)) decodeMessageField protoType p = (protoType (lowerProxy1 p)) - { dotProtoFieldComment = Just (symbolVal (lowerProxy2 p)) } + { dotProtoFieldComment = symbolVal (lowerProxy2 p) } where lowerProxy1 :: forall f (a :: k). Proxy# (f a) -> Proxy# a lowerProxy1 _ = proxy# @@ -625,7 +635,7 @@ :: Parser RawPrimitive [a] -> Parser RawField (PackedVec a) decodePacked = Parser - . fmap (fmap pack) + . fmap (fmap (pack . Foldable.toList)) . TR.traverse . runParser where @@ -658,7 +668,8 @@ -- | Generate metadata for a message type. message :: (Message a, Named a) => Proxy# a -> DotProtoDefinition -message proxy = DotProtoMessage (Single $ nameOf proxy) +message proxy = DotProtoMessage "" + (Single $ nameOf proxy) (DotProtoMessageField <$> dotProto proxy) -- * Generic Instances diff --git a/src/Proto3/Suite/DhallPB.hs b/src/Proto3/Suite/DhallPB.hs --- a/src/Proto3/Suite/DhallPB.hs +++ b/src/Proto3/Suite/DhallPB.hs @@ -28,7 +28,7 @@ instance Dhall.Interpret a => Dhall.Interpret (Enumerated a) -instance Dhall.Interpret a => Dhall.Interpret (Either Int a) +instance Dhall.Interpret a => Dhall.Interpret (Either Int32 a) -------------------------------------------------------------------------------- -- Interpret the strict and lazy ByteString types @@ -114,7 +114,7 @@ instance Dhall.Inject a => Dhall.Inject (Enumerated a) -instance Dhall.Inject a => Dhall.Inject (Either Int a) +instance Dhall.Inject a => Dhall.Inject (Either Int32 a) -------------------------------------------------------------------------------- -- Inject integer scalar types diff --git a/src/Proto3/Suite/DotProto.hs b/src/Proto3/Suite/DotProto.hs --- a/src/Proto3/Suite/DotProto.hs +++ b/src/Proto3/Suite/DotProto.hs @@ -3,3 +3,5 @@ import Proto3.Suite.DotProto.AST as M import Proto3.Suite.DotProto.Parsing as M import Proto3.Suite.DotProto.Rendering as M +-- exported for testing +import Proto3.Suite.DotProto.Internal as M (fieldLikeName, prefixedEnumFieldName, typeLikeName) diff --git a/src/Proto3/Suite/DotProto/AST.hs b/src/Proto3/Suite/DotProto/AST.hs --- a/src/Proto3/Suite/DotProto/AST.hs +++ b/src/Proto3/Suite/DotProto/AST.hs @@ -1,6 +1,7 @@ -- | Fairly straightforward AST encoding of the .proto grammar {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE RecordWildCards #-} module Proto3.Suite.DotProto.AST @@ -19,17 +20,22 @@ , DotProtoValue(..) , DotProtoPrimType(..) , Packing(..) - , Path(..) + , Path(..), fakePath , DotProtoType(..) , DotProtoEnumValue , DotProtoEnumPart(..) , Streaming(..) , DotProtoServicePart(..) + , RPCMethod(..) , DotProtoMessagePart(..) , DotProtoField(..) , DotProtoReservedField(..) ) where +import Control.Applicative +import Control.Monad +import Data.Int (Int32) +import qualified Data.List.NonEmpty as NE import Data.String (IsString) import qualified Filesystem.Path.CurrentOS as FP import Numeric.Natural @@ -63,8 +69,12 @@ instance Show PackageName where show = show . getPackageName -newtype Path = Path { components :: [String] } deriving (Show, Eq, Ord) +newtype Path = Path { components :: NE.NonEmpty String } deriving (Show, Eq, Ord) +-- Used for testing +fakePath :: Path +fakePath = Path ("fakePath" NE.:| []) + data DotProtoIdentifier = Single String | Dots Path @@ -127,23 +137,26 @@ -- | Top-level protocol definitions data DotProtoDefinition - = DotProtoMessage DotProtoIdentifier [DotProtoMessagePart] - | DotProtoEnum DotProtoIdentifier [DotProtoEnumPart] - | DotProtoService DotProtoIdentifier [DotProtoServicePart] + = DotProtoMessage String DotProtoIdentifier [DotProtoMessagePart] + | DotProtoEnum String DotProtoIdentifier [DotProtoEnumPart] + | DotProtoService String DotProtoIdentifier [DotProtoServicePart] deriving (Show, Eq) + instance Arbitrary DotProtoDefinition where arbitrary = oneof [arbitraryMessage, arbitraryEnum] where arbitraryMessage = do + comment <- pure mempty -- until parser supports comments identifier <- arbitrarySingleIdentifier parts <- smallListOf arbitrary - return (DotProtoMessage identifier parts) + return (DotProtoMessage comment identifier parts) arbitraryEnum = do + comment <- pure mempty -- until parser supports comments identifier <- arbitrarySingleIdentifier parts <- smallListOf arbitrary - return (DotProtoEnum identifier parts) + return (DotProtoEnum comment identifier parts) -- | Tracks misc metadata about the AST data DotProtoMeta = DotProtoMeta @@ -158,7 +171,7 @@ } deriving (Show, Eq) instance Arbitrary DotProtoMeta where - arbitrary = pure . DotProtoMeta . Path $ [] + arbitrary = pure (DotProtoMeta fakePath) -- | This data structure represents a .proto file -- The actual source order of protobuf statements isn't meaningful so @@ -264,7 +277,7 @@ instance Arbitrary DotProtoType where arbitrary = oneof [fmap Prim arbitrary] -type DotProtoEnumValue = Int +type DotProtoEnumValue = Int32 data DotProtoEnumPart = DotProtoEnumField DotProtoIdentifier DotProtoEnumValue [DotProtoOption] @@ -293,45 +306,40 @@ instance Arbitrary Streaming where arbitrary = elements [Streaming, NonStreaming] --- [refactor] add named accessors to ServiceRPC --- break this into two types data DotProtoServicePart - = DotProtoServiceRPC DotProtoIdentifier - (DotProtoIdentifier, Streaming) - (DotProtoIdentifier, Streaming) - [DotProtoOption] + = DotProtoServiceRPCMethod RPCMethod | DotProtoServiceOption DotProtoOption | DotProtoServiceEmpty deriving (Show, Eq) instance Arbitrary DotProtoServicePart where arbitrary = oneof - [ arbitraryServiceRPC - , arbitraryServiceOption + [ DotProtoServiceRPCMethod <$> arbitrary + , DotProtoServiceOption <$> arbitrary ] - where - arbitraryServiceRPC = do - identifier <- arbitrarySingleIdentifier - rpcClause0 <- arbitraryRPCClause - rpcClause1 <- arbitraryRPCClause - options <- smallListOf arbitrary - return (DotProtoServiceRPC identifier rpcClause0 rpcClause1 options) - where - arbitraryRPCClause = do - identifier <- arbitraryIdentifier - streaming <- arbitrary - return (identifier, streaming) - arbitraryServiceOption = do - option <- arbitrary - return (DotProtoServiceOption option) +data RPCMethod = RPCMethod + { rpcMethodName :: DotProtoIdentifier + , rpcMethodRequestType :: DotProtoIdentifier + , rpcMethodRequestStreaming :: Streaming + , rpcMethodResponseType :: DotProtoIdentifier + , rpcMethodResponseStreaming :: Streaming + , rpcMethodOptions :: [DotProtoOption] + } deriving (Show, Eq) +instance Arbitrary RPCMethod where + arbitrary = do + rpcMethodName <- arbitrarySingleIdentifier + rpcMethodRequestType <- arbitraryIdentifier + rpcMethodRequestStreaming <- arbitrary + rpcMethodResponseType <- arbitraryIdentifier + rpcMethodResponseStreaming <- arbitrary + rpcMethodOptions <- smallListOf arbitrary + return RPCMethod{..} + data DotProtoMessagePart = DotProtoMessageField DotProtoField - | DotProtoMessageOneOf - { dotProtoOneOfName :: DotProtoIdentifier - , dotProtoOneOfFields :: [DotProtoField] - } + | DotProtoMessageOneOf DotProtoIdentifier [DotProtoField] | DotProtoMessageDefinition DotProtoDefinition | DotProtoMessageReserved [DotProtoReservedField] deriving (Show, Eq) @@ -349,9 +357,9 @@ return (DotProtoMessageField field) arbitraryOneOf = do - dotProtoOneOfName <- arbitrarySingleIdentifier - dotProtoOneOfFields <- smallListOf arbitrary - return (DotProtoMessageOneOf {..}) + name <- arbitrarySingleIdentifier + fields <- smallListOf arbitrary + return (DotProtoMessageOneOf name fields) arbitraryDefinition = do definition <- arbitrary @@ -369,7 +377,7 @@ , dotProtoFieldType :: DotProtoType , dotProtoFieldName :: DotProtoIdentifier , dotProtoFieldOptions :: [DotProtoOption] - , dotProtoFieldComment :: Maybe String + , dotProtoFieldComment :: String } | DotProtoEmptyField deriving (Show, Eq) @@ -381,7 +389,7 @@ dotProtoFieldName <- arbitraryIdentifier dotProtoFieldOptions <- smallListOf arbitrary -- TODO: Generate random comments once the parser supports comments - dotProtoFieldComment <- pure Nothing + dotProtoFieldComment <- pure mempty return (DotProtoField {..}) data DotProtoReservedField @@ -412,9 +420,10 @@ _arbitraryService :: Gen DotProtoDefinition _arbitraryService = do + comment <- pure mempty -- until parser supports comments identifier <- arbitrarySingleIdentifier parts <- smallListOf arbitrary - return (DotProtoService identifier parts) + return (DotProtoService comment identifier parts) arbitraryIdentifierName :: Gen String arbitraryIdentifierName = do @@ -429,7 +438,7 @@ arbitraryPathIdentifier = do name <- arbitraryIdentifierName names <- smallListOf1 arbitraryIdentifierName - pure . Dots . Path $ name:names + pure . Dots . Path $ name NE.:| names arbitraryNestedIdentifier :: Gen DotProtoIdentifier arbitraryNestedIdentifier = do diff --git a/src/Proto3/Suite/DotProto/AST/Lens.hs b/src/Proto3/Suite/DotProto/AST/Lens.hs new file mode 100644 --- /dev/null +++ b/src/Proto3/Suite/DotProto/AST/Lens.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE TemplateHaskell #-} +module Proto3.Suite.DotProto.AST.Lens where + +import Control.Lens.TH +import Proto3.Suite.DotProto.AST + +makePrisms ''DotProtoDefinition +makePrisms ''DotProtoMessagePart + diff --git a/src/Proto3/Suite/DotProto/Generate.hs b/src/Proto3/Suite/DotProto/Generate.hs --- a/src/Proto3/Suite/DotProto/Generate.hs +++ b/src/Proto3/Suite/DotProto/Generate.hs @@ -1,2150 +1,1818 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE ViewPatterns #-} - -{-| This module provides functions to generate Haskell declarations for protobuf - messages --} - -module Proto3.Suite.DotProto.Generate - ( CompileError(..) - , TypeContext - - , compileDotProtoFile - , compileDotProtoFileOrDie - , hsModuleForDotProto - , renderHsModuleForDotProto - , readDotProtoWithContext - - -- * Utilities - , isPackable - - -- * Exposed for unit-testing - , fieldLikeName - , prefixedEnumFieldName - , typeLikeName - ) where - -import Control.Applicative -import Control.Arrow ((&&&)) -import Control.Monad.Except -import Control.Lens (ix, over) -import Data.Bifunctor (first) -import Data.Char -import Data.Coerce -import Data.Either (partitionEithers) -import Data.List (find, intercalate, nub, sortBy, - stripPrefix) -import qualified Data.Map as M -import Data.Maybe (catMaybes, fromMaybe) -import Data.Monoid -import Data.Ord (comparing) -import qualified Data.Set as S -import Data.String (fromString) -import qualified Data.Text as T -import Filesystem.Path.CurrentOS ((), (<.>)) -import qualified Filesystem.Path.CurrentOS as FP -import Language.Haskell.Pretty -import Language.Haskell.Syntax -import Language.Haskell.Parser (ParseResult(..), parseModule) -import qualified NeatInterpolation as Neat -import Prelude hiding (FilePath) -import Proto3.Suite.DotProto -import Proto3.Suite.DotProto.Rendering (Pretty(..)) -import Proto3.Suite.DotProto.Internal -import Proto3.Wire.Types (FieldNumber (..)) -import System.IO (writeFile, readFile) -import Text.Parsec (ParseError) -import Turtle (FilePath) -import qualified Turtle -import Turtle.Format ((%)) -import qualified Turtle.Format as F - --- * Public interface - -data CompileError - = CircularImport FilePath - | CompileParseError ParseError - | InternalEmptyModulePath - | InternalError String - | InvalidMethodName DotProtoIdentifier - | InvalidTypeName String - | InvalidMapKeyType String - | NoPackageDeclaration - | NoSuchType DotProtoIdentifier - | Unimplemented String - deriving (Show, Eq) - -#if !(MIN_VERSION_mtl(2,2,2)) -liftEither :: MonadError e m => Either e a -> m a -liftEither x = - case x of - Left e -> throwError e - Right a -> return a -#endif - --- | Generate a Haskell module corresponding to a @.proto@ file -compileDotProtoFile - :: [FilePath] - -- ^ Haskell modules containing instances used to override default generated - -- instances - -> FilePath - -- ^ Output directory - -> [FilePath] - -- ^ List of search paths - -> FilePath - -- ^ Path to @.proto@ file (relative to search path) - -> IO (Either CompileError ()) -compileDotProtoFile - extraInstanceFiles - outputDirectory - searchPaths - dotProtoPath = runExceptT $ do - (dotProto, importTypeContext) <- do - ExceptT (readDotProtoWithContext searchPaths dotProtoPath) - - let DotProto { protoMeta } = dotProto - let DotProtoMeta { metaModulePath } = protoMeta - let Path { components } = metaModulePath - - when (null components) (throwError InternalEmptyModulePath) - - typeLikeComponents <- traverse typeLikeName components - - let relativePath = FP.concat (map fromString typeLikeComponents) <.> "hs" - let modulePath = outputDirectory relativePath - - Turtle.mktree (Turtle.directory modulePath) - - listOfExtraInstances <- traverse getExtraInstances extraInstanceFiles - - let extraInstances = mconcat listOfExtraInstances - - haskellModule <- do - renderHsModuleForDotProto extraInstances dotProto importTypeContext - - liftIO (writeFile (FP.encodeString modulePath) haskellModule) - --- | As 'compileDotProtoFile', except terminates the program with an error --- message on failure. -compileDotProtoFileOrDie - :: [FilePath] - -- ^ Haskell modules containing instances used to override default generated - -- instances - -> FilePath - -- ^ Output directory - -> [FilePath] - -- ^ List of search paths - -> FilePath - -- ^ Path to @.proto@ file (relative to search path) - -> IO () -compileDotProtoFileOrDie - extraInstanceFiles - outputDirectory - searchPaths - dotProtoPath = do - compileResult <- do - compileDotProtoFile - extraInstanceFiles - outputDirectory - searchPaths - dotProtoPath - - case compileResult of - Left e -> do - -- TODO: pretty print the error messages - let errText = Turtle.format Turtle.w e - let dotProtoPathText = Turtle.format Turtle.fp dotProtoPath - dieLines [Neat.text| - Error: failed to compile "${dotProtoPathText}": - - ${errText} - |] - _ -> pure () - -getExtraInstances - :: (MonadIO m, MonadError CompileError m) - => FilePath -> m ([HsImportDecl], [HsDecl]) -getExtraInstances extraInstanceFile = do - let extraInstanceFileString = FP.encodeString extraInstanceFile - - parseRes <- parseModule <$> liftIO (readFile extraInstanceFileString) - - case parseRes of - ParseOk (HsModule _srcloc _mod _es idecls decls) -> do - let isInstDecl HsInstDecl{} = True - isInstDecl _ = False - - return (idecls, filter isInstDecl decls) --TODO give compile result - - ParseFailed srcLoc err -> do - let srcLocText = Turtle.format Turtle.w srcLoc - - let errText = T.pack err - - let message = [Neat.text| - Error: Failed to parse instance file - - ${srcLocText}: ${errText} - |] - - internalError (T.unpack message) - --- | Compile a 'DotProto' AST into a 'String' representing the Haskell --- source of a module implementing types and instances for the .proto --- messages and enums. -renderHsModuleForDotProto - :: MonadError CompileError m - => ([HsImportDecl],[HsDecl]) -> DotProto -> TypeContext -> m String -renderHsModuleForDotProto extraInstanceFiles dotProto importCtxt = do - haskellModule <- hsModuleForDotProto extraInstanceFiles dotProto importCtxt - return (T.unpack header ++ prettyPrint haskellModule) - where - header = [Neat.text| - {-# LANGUAGE DeriveGeneric #-} - {-# LANGUAGE DeriveAnyClass #-} - {-# LANGUAGE DataKinds #-} - {-# LANGUAGE GADTs #-} - {-# LANGUAGE TypeApplications #-} - {-# LANGUAGE OverloadedStrings #-} - {-# OPTIONS_GHC -fno-warn-unused-imports #-} - {-# OPTIONS_GHC -fno-warn-name-shadowing #-} - {-# OPTIONS_GHC -fno-warn-unused-matches #-} - - -- | Generated by Haskell protocol buffer compiler. DO NOT EDIT! - |] - --- | Compile a Haskell module AST given a 'DotProto' package AST. --- Instances given in @eis@ override those otherwise generated. -hsModuleForDotProto - :: MonadError CompileError m - => ([HsImportDecl], [HsDecl]) - -- ^ Extra user-define instances that override default generated instances - -> DotProto - -- ^ - -> TypeContext - -- ^ - -> m HsModule -hsModuleForDotProto - _ - DotProto { protoMeta = DotProtoMeta { metaModulePath = Path [] } } - _ = - throwError InternalEmptyModulePath -hsModuleForDotProto - (extraImports, extraInstances) - dotProto@DotProto - { protoPackage = DotProtoPackageSpec packageIdentifier - , protoMeta = DotProtoMeta { metaModulePath = modulePath } - , protoDefinitions - } - importTypeContext = do - moduleName <- modulePathModName modulePath - - typeContextImports <- ctxtImports importTypeContext - - let importDeclarations = - concat [ defaultImports hasService, extraImports, typeContextImports ] - - typeContext <- dotProtoTypeContext dotProto - - let toDotProtoDeclaration = - dotProtoDefinitionD packageIdentifier (typeContext <> importTypeContext) - - let instances = instancesForModule moduleName extraInstances - - listOfDeclarations <- traverse toDotProtoDeclaration protoDefinitions - - let overridenDeclarations = - replaceHsInstDecls instances (mconcat listOfDeclarations) - - return (module_ moduleName Nothing importDeclarations overridenDeclarations) - where - hasService = not (null [ () | DotProtoService {} <- protoDefinitions ]) - -hsModuleForDotProto _ _ _ = - throwError NoPackageDeclaration - --- This very specific function will only work for the qualification on the very first type --- in the object of an instance declaration. Those are the only sort of instance declarations --- generated within this code, so it suffices. -instancesForModule :: Module -> [HsDecl] -> [HsDecl] -instancesForModule m = foldr go [] - where go x xs = case x of - HsInstDecl a b c (HsTyCon (Qual tm i):ts) d -> - if m == tm then HsInstDecl a b c (HsTyCon (UnQual i):ts) d:xs else xs - _ -> xs - --- | For each thing in @base@ replaces it if it finds a matching @override@ -replaceHsInstDecls :: [HsDecl] -> [HsDecl] -> [HsDecl] -replaceHsInstDecls overrides base = concatMap mbReplace base - where -- instances defined separately from data type definition: - mbReplace hid@(HsInstDecl _ _ qn tys _) = - (: []) . fromMaybe hid $ search qn tys - - -- instances listed in "deriving" clause of data type definition: - mbReplace (HsDataDecl loc ctx tyn names def insts) = - let (filtered,customized) = partitionEithers (map (deriv tyn) insts) - in HsDataDecl loc ctx tyn names def filtered : customized - - -- irrelevant declarations remain unchanged: - mbReplace hid = [hid] - - deriv tyn qn = maybe (Left qn) Right $ search qn [HsTyCon (UnQual tyn)] - - search qn tys = find (\x -> Just (unQual qn,tys) == getSig x) overrides - - getSig (HsInstDecl _ _ qn tys _) = Just (unQual qn,tys) - getSig _ = Nothing - - unQual (Qual _ n) = Just n - unQual (UnQual n) = Just n - unQual (Special _) = Nothing - --- | Parses the file at the given path and produces an AST along with a --- 'TypeContext' representing all types from imported @.proto@ files, using the --- first parameter as a list of paths to search for imported files. Terminates --- with exit code 1 when an included file cannot be found in the search path. -readDotProtoWithContext - :: [FilePath] - -> FilePath - -> IO (Either CompileError (DotProto, TypeContext)) -readDotProtoWithContext [] dotProtoPath = do - -- If we're not given a search path, default to using the current working - -- directory, as `protoc` does - cwd <- Turtle.pwd - readDotProtoWithContext [cwd] dotProtoPath - -readDotProtoWithContext searchPaths toplevelProto = runExceptT $ do - findProto searchPaths toplevelProto >>= \case - Found mp fp -> parse mp fp - BadModulePath e -> fatalBadModulePath toplevelProto e - NotFound -> dieLines [Neat.text| - Error: failed to find file "${toplevelProtoText}", after looking in - the following locations (controlled via the --includeDir switch(es)): - - $searchPathsText - |] - where - parse mp fp = parseProtoFile mp fp >>= \case - Right dp -> do - let importIt = readImportTypeContext searchPaths toplevelProto (S.singleton toplevelProto) - tc <- mconcat <$> mapM importIt (protoImports dp) - pure (dp, tc) - Left err -> throwError (CompileParseError err) - - searchPathsText = T.unlines (Turtle.format (" "%F.fp) . ( toplevelProto) <$> searchPaths) - toplevelProtoText = Turtle.format F.fp toplevelProto - -readImportTypeContext - :: (MonadError CompileError m, MonadIO m) - => [FilePath] - -> FilePath - -> S.Set FilePath - -> DotProtoImport - -> m TypeContext -readImportTypeContext searchPaths toplevelFP alreadyRead (DotProtoImport _ path) - | path `S.member` alreadyRead = throwError (CircularImport path) - | otherwise = - do import_ <- liftEither . first CompileParseError =<< importProto searchPaths toplevelFP path - case protoPackage import_ of - DotProtoPackageSpec importPkg -> - do importTypeContext <- dotProtoTypeContext import_ - let importTypeContext' = flip fmap importTypeContext $ \tyInfo -> - tyInfo { dotProtoTypeInfoPackage = DotProtoPackageSpec importPkg - , dotProtoTypeInfoModulePath = metaModulePath . protoMeta $ import_ - } - qualifiedTypeContext = M.fromList <$> - mapM (\(nm, tyInfo) -> (,tyInfo) <$> concatDotProtoIdentifier importPkg nm) - (M.assocs importTypeContext') - - importTypeContext'' <- (importTypeContext' <>) <$> qualifiedTypeContext - (importTypeContext'' <>) . mconcat <$> sequence - [ readImportTypeContext searchPaths toplevelFP (S.insert path alreadyRead) importImport - | importImport@(DotProtoImport DotProtoImportPublic _) <- protoImports import_ - ] - _ -> throwError NoPackageDeclaration - --- * Type-tracking data structures - --- | Whether a definition is an enumeration or a message -data DotProtoKind = DotProtoKindEnum - | DotProtoKindMessage - deriving (Show, Eq, Ord, Enum, Bounded) - --- | Information about messages and enumerations -data DotProtoTypeInfo = DotProtoTypeInfo - { dotProtoTypeInfoPackage :: DotProtoPackageSpec - -- ^ The package this type is defined in - , dotProtoTypeInfoParent :: DotProtoIdentifier - -- ^ The message this type is nested under, or 'Anonymous' if it's top-level - , dotProtoTypeChildContext :: TypeContext - -- ^ The context that should be used for declarations within the - -- scope of this type - , dotProtoTypeInfoKind :: DotProtoKind - -- ^ Whether this type is an enumeration or message - , dotProtoTypeInfoModulePath :: Path - -- ^ The include-relative module path used when importing this module - } deriving Show - --- | A mapping from .proto type identifiers to their type information -type TypeContext = M.Map DotProtoIdentifier DotProtoTypeInfo - --- ** Generating type contexts from ASTs - -dotProtoTypeContext :: MonadError CompileError m => DotProto -> m TypeContext -dotProtoTypeContext DotProto { protoDefinitions - , protoMeta = DotProtoMeta modulePath - } - = mconcat <$> mapM (definitionTypeContext modulePath) protoDefinitions - -definitionTypeContext - :: MonadError CompileError m => Path -> DotProtoDefinition -> m TypeContext -definitionTypeContext modulePath (DotProtoMessage msgIdent parts) = - do childTyContext <- - mapM updateDotProtoTypeInfoParent =<< - (mconcat <$> sequenceA - [ definitionTypeContext modulePath def - | DotProtoMessageDefinition def <- parts ]) - - qualifiedChildTyContext <- M.fromList <$> - mapM (\(nm, tyInfo) -> (,tyInfo) <$> - concatDotProtoIdentifier msgIdent nm) - (M.assocs childTyContext) - - pure (M.singleton msgIdent - (DotProtoTypeInfo DotProtoNoPackage Anonymous - childTyContext DotProtoKindMessage modulePath) <> - qualifiedChildTyContext) - where updateDotProtoTypeInfoParent tyInfo = - do dotProtoTypeInfoParent <- - concatDotProtoIdentifier msgIdent (dotProtoTypeInfoParent tyInfo) - pure tyInfo { dotProtoTypeInfoParent } -definitionTypeContext modulePath (DotProtoEnum enumIdent _) = - pure (M.singleton enumIdent - (DotProtoTypeInfo DotProtoNoPackage Anonymous mempty DotProtoKindEnum modulePath)) -definitionTypeContext _ _ = pure mempty - -concatDotProtoIdentifier :: MonadError CompileError m - => DotProtoIdentifier -> DotProtoIdentifier -> m DotProtoIdentifier - -concatDotProtoIdentifier Qualified{} _ = internalError "concatDotProtoIdentifier: Qualified" -concatDotProtoIdentifier _ Qualified{} = internalError "concatDotProtoIdentifier Qualified" - -concatDotProtoIdentifier Anonymous Anonymous = pure Anonymous -concatDotProtoIdentifier Anonymous b = pure b -concatDotProtoIdentifier a Anonymous = pure a - -concatDotProtoIdentifier (Single a) b = concatDotProtoIdentifier (Dots (Path [a])) b -concatDotProtoIdentifier a (Single b) = concatDotProtoIdentifier a (Dots (Path [b])) - -concatDotProtoIdentifier (Dots (Path a)) (Dots (Path b)) = pure . Dots . Path $ a ++ b - --- | Given a type context, generates the import statements necessary --- to import all the required types. -ctxtImports :: MonadError CompileError m => TypeContext -> m [HsImportDecl] -ctxtImports tyCtxt = - do imports <- nub <$> sequence - [ modulePathModName modulePath - | DotProtoTypeInfo { dotProtoTypeInfoModulePath = modulePath } - <- M.elems tyCtxt - ] - pure [ importDecl_ modName True Nothing Nothing | modName <- imports ] - --- * Functions to convert 'DotProtoType' into Haskell types - --- Convert a dot proto type to a Haskell type -dptToHsType :: MonadError CompileError m => TypeContext -> DotProtoType -> m HsType -dptToHsType = foldDPT dptToHsContType dpptToHsType - --- Convert a dot proto type to a wrapped Haskell type -dptToHsTypeWrapped :: MonadError CompileError m => [DotProtoOption] -> TypeContext -> DotProtoType -> m HsType -dptToHsTypeWrapped opts = - foldDPT - -- The wrapper for the collection type replaces the native haskell - -- collection type, so try that first. - (\ctxt ty -> maybe (dptToHsContType ctxt ty) id (dptToHsWrappedContType ctxt opts ty)) - -- Always wrap the primitive type. - (\ctxt ty -> dpptToHsTypeWrapper ty <$> dpptToHsType ctxt ty) - -foldDPT :: MonadError CompileError m - => (TypeContext -> DotProtoType -> HsType -> HsType) - -> (TypeContext -> DotProtoPrimType -> m HsType) - -> TypeContext - -> DotProtoType - -> m HsType -foldDPT dptToHsCont foldPrim ctxt dpt = - let - prim = foldPrim ctxt - go = foldDPT dptToHsCont foldPrim ctxt - cont = dptToHsCont ctxt dpt - in - case dpt of - Prim pType -> cont <$> prim pType - Optional pType -> cont <$> prim pType - Repeated pType -> cont <$> prim pType - NestedRepeated pType -> cont <$> prim pType - Map k v | validMapKey k -> HsTyApp . cont <$> prim k <*> go (Prim v) -- need to 'Nest' message types - | otherwise -> throwError $ InvalidMapKeyType (show $ pPrint k) - --- Translate DotProtoType constructors to wrapped Haskell container types --- (for Message serde instances). -dptToHsWrappedContType :: TypeContext -> [DotProtoOption] -> DotProtoType -> Maybe (HsType -> HsType) -dptToHsWrappedContType ctxt opts = \case - Prim (Named tyName) - | isMessage ctxt tyName -> Just $ HsTyApp (protobufType_ "Nested") - Repeated (Named tyName) - | isMessage ctxt tyName -> Just $ HsTyApp (protobufType_ "NestedVec") - Repeated ty - | isUnpacked opts -> Just $ HsTyApp (protobufType_ "UnpackedVec") - | isPacked opts -> Just $ HsTyApp (protobufType_ "PackedVec") - | isPackable ctxt ty -> Just $ HsTyApp (protobufType_ "PackedVec") - | otherwise -> Just $ HsTyApp (protobufType_ "UnpackedVec") - _ -> Nothing - --- Translate DotProtoType to Haskell container types. -dptToHsContType :: TypeContext -> DotProtoType -> HsType -> HsType -dptToHsContType ctxt = \case - Prim (Named tyName) | isMessage ctxt tyName - -> HsTyApp $ primType_ "Maybe" - Optional _ -> HsTyApp $ primType_ "Maybe" - Repeated _ -> HsTyApp $ primType_ "Vector" - NestedRepeated _ -> HsTyApp $ primType_ "Vector" - Map _ _ -> HsTyApp $ primType_ "Map" - _ -> id - --- Haskell wrapper for primitive dot proto types -dpptToHsTypeWrapper :: DotProtoPrimType -> HsType -> HsType -dpptToHsTypeWrapper = \case - SInt32 -> HsTyApp (protobufType_ "Signed") - SInt64 -> HsTyApp (protobufType_ "Signed") - SFixed32 -> HsTyApp (protobufType_ "Signed") . HsTyApp (protobufType_ "Fixed") - SFixed64 -> HsTyApp (protobufType_ "Signed") . HsTyApp (protobufType_ "Fixed") - Fixed32 -> HsTyApp (protobufType_ "Fixed") - Fixed64 -> HsTyApp (protobufType_ "Fixed") - _ -> id - --- Convert a dot proto prim type to an unwrapped Haskell type -dpptToHsType :: MonadError CompileError m => TypeContext -> DotProtoPrimType -> m HsType -dpptToHsType ctxt = \case - Int32 -> pure $ primType_ "Int32" - Int64 -> pure $ primType_ "Int64" - SInt32 -> pure $ primType_ "Int32" - SInt64 -> pure $ primType_ "Int64" - UInt32 -> pure $ primType_ "Word32" - UInt64 -> pure $ primType_ "Word64" - Fixed32 -> pure $ primType_ "Word32" - Fixed64 -> pure $ primType_ "Word64" - SFixed32 -> pure $ primType_ "Int32" - SFixed64 -> pure $ primType_ "Int64" - String -> pure $ primType_ "Text" - Bytes -> pure $ primType_ "ByteString" - Bool -> pure $ primType_ "Bool" - Float -> pure $ primType_ "Float" - Double -> pure $ primType_ "Double" - Named msgName -> - case M.lookup msgName ctxt of - Just ty@(DotProtoTypeInfo { dotProtoTypeInfoKind = DotProtoKindEnum }) -> - HsTyApp (protobufType_ "Enumerated") <$> msgTypeFromDpTypeInfo ty msgName - Just ty -> msgTypeFromDpTypeInfo ty msgName - Nothing -> noSuchTypeError msgName - - -validMapKey :: DotProtoPrimType -> Bool -validMapKey = (`elem` [ Int32, Int64, SInt32, SInt64, UInt32, UInt64 - , Fixed32, Fixed64, SFixed32, SFixed64 - , String, Bool]) - -isMessage :: TypeContext -> DotProtoIdentifier -> Bool -isMessage ctxt n = Just DotProtoKindMessage == (dotProtoTypeInfoKind <$> M.lookup n ctxt) - -isPacked :: [DotProtoOption] -> Bool -isPacked opts = - case find (\(DotProtoOption name _) -> name == Single "packed") opts of - Just (DotProtoOption _ (BoolLit x)) -> x - _ -> False - -isUnpacked :: [DotProtoOption] -> Bool -isUnpacked opts = - case find (\(DotProtoOption name _) -> name == Single "packed") opts of - Just (DotProtoOption _ (BoolLit x)) -> not x - _ -> False - --- | Returns 'True' if the given primitive type is packable. The 'TypeContext' --- is used to distinguish Named enums and messages, only the former of which are --- packable. -isPackable :: TypeContext -> DotProtoPrimType -> Bool -isPackable _ Bytes = False -isPackable _ String = False -isPackable _ Int32 = True -isPackable _ Int64 = True -isPackable _ SInt32 = True -isPackable _ SInt64 = True -isPackable _ UInt32 = True -isPackable _ UInt64 = True -isPackable _ Fixed32 = True -isPackable _ Fixed64 = True -isPackable _ SFixed32 = True -isPackable _ SFixed64 = True -isPackable _ Bool = True -isPackable _ Float = True -isPackable _ Double = True -isPackable ctxt (Named tyName) = - Just DotProtoKindEnum == (dotProtoTypeInfoKind <$> M.lookup tyName ctxt) - --- *** Helper functions for names - --- | Generate the Haskell type name for a 'DotProtoTypeInfo' for a message / --- enumeration being compiled. NB: We ignore the 'dotProtoTypeInfoPackage' --- field of the 'DotProtoTypeInfo' parameter, instead demanding that we have --- been provided with a valid module path in its 'dotProtoTypeInfoModulePath' --- field. The latter describes the name of the Haskell module being generated. -msgTypeFromDpTypeInfo :: MonadError CompileError m - => DotProtoTypeInfo -> DotProtoIdentifier -> m HsType -msgTypeFromDpTypeInfo - DotProtoTypeInfo { dotProtoTypeInfoParent = p - , dotProtoTypeInfoModulePath = modulePath - } - ident - | Path [] <- modulePath = throwError InternalEmptyModulePath - | otherwise = do - modName <- modulePathModName modulePath - identName <- nestedTypeName p =<< dpIdentUnqualName ident - pure $ HsTyCon (Qual modName (HsIdent identName)) - --- | Given a 'DotProtoIdentifier' for the parent type and the unqualified name --- of this type, generate the corresponding Haskell name -nestedTypeName :: MonadError CompileError m => DotProtoIdentifier -> String -> m String -nestedTypeName Anonymous nm = typeLikeName nm -nestedTypeName (Single parent) nm = intercalate "_" <$> sequenceA [ typeLikeName parent , typeLikeName nm ] -nestedTypeName (Dots (Path parents)) nm = intercalate "_" . (<>[nm]) <$> mapM typeLikeName parents -nestedTypeName (Qualified {}) _ = internalError "nestedTypeName: Qualified" - -haskellName, jsonpbName, grpcName, protobufName, proxyName - :: String -> HsQName -haskellName name = Qual (Module "Hs") (HsIdent name) -jsonpbName name = Qual (Module "HsJSONPB") (HsIdent name) -grpcName name = Qual (Module "HsGRPC") (HsIdent name) -protobufName name = Qual (Module "HsProtobuf") (HsIdent name) -proxyName name = Qual (Module "Proxy") (HsIdent name) - -#ifdef DHALL -hsDhallPB :: String -hsDhallPB = "HsDhallPb" - -dhallPBName :: String -> HsQName -dhallPBName name = Qual (Module hsDhallPB) (HsIdent name) -#endif - -camelCased :: String -> String -camelCased s = do - (prev, cur) <- zip (Nothing:map Just s) (map Just s ++ [Nothing]) - case (prev, cur) of - (Just '_', Just x) | isAlpha x -> pure (toUpper x) - (Just '_', Nothing) -> pure '_' - (Just '_', Just '_') -> pure '_' - (_, Just '_') -> empty - (_, Just x) -> pure x - (_, _) -> empty - -typeLikeName :: MonadError CompileError m => String -> m String -typeLikeName ident@(firstChar:remainingChars) - | isUpper firstChar = pure (camelCased ident) - | isLower firstChar = pure (camelCased (toUpper firstChar:remainingChars)) - | firstChar == '_' = pure (camelCased ('X':ident)) -typeLikeName ident = invalidTypeNameError ident - -fieldLikeName :: String -> String -fieldLikeName ident@(firstChar:_) - | isUpper firstChar = let (prefix, suffix) = span isUpper ident - in map toLower prefix ++ suffix -fieldLikeName ident = ident - -prefixedEnumFieldName :: String -> String -> String -prefixedEnumFieldName enumName fieldName = enumName <> fieldName - -prefixedConName :: MonadError CompileError m => String -> String -> m String -prefixedConName msgName conName = - (msgName ++) <$> typeLikeName conName - --- TODO: This should be ~:: MessageName -> FieldName -> ...; same elsewhere, the --- String types are a bit of a hassle. -prefixedFieldName :: MonadError CompileError m => String -> String -> m String -prefixedFieldName msgName fieldName = - (fieldLikeName msgName ++) <$> typeLikeName fieldName - -dpIdentUnqualName :: MonadError CompileError m => DotProtoIdentifier -> m String -dpIdentUnqualName (Single name) = pure name -dpIdentUnqualName (Dots (Path names)) = pure (last names) -dpIdentUnqualName (Qualified _ next) = dpIdentUnqualName next -dpIdentUnqualName Anonymous = internalError "dpIdentUnqualName: Anonymous" - -dpIdentQualName :: MonadError CompileError m => DotProtoIdentifier -> m String -dpIdentQualName (Single name) = pure name -dpIdentQualName (Dots (Path names)) = pure (intercalate "." names) -dpIdentQualName (Qualified _ _) = internalError "dpIdentQualName: Qualified" -dpIdentQualName Anonymous = internalError "dpIdentQualName: Anonymous" - -modulePathModName :: MonadError CompileError m => Path -> m Module -modulePathModName (Path []) = throwError InternalEmptyModulePath -modulePathModName (Path comps) = Module <$> (intercalate "." <$> mapM typeLikeName comps) - -_pkgIdentModName :: MonadError CompileError m => DotProtoIdentifier -> m Module -_pkgIdentModName (Single s) = Module <$> typeLikeName s -_pkgIdentModName (Dots (Path paths)) = Module <$> (intercalate "." <$> mapM typeLikeName paths) -_pkgIdentModName _ = internalError "pkgIdentModName: Malformed package name" - --- * Generate instances for a 'DotProto' package - -dotProtoDefinitionD - :: MonadError CompileError m - => DotProtoIdentifier -> TypeContext -> DotProtoDefinition -> m [HsDecl] -dotProtoDefinitionD _ ctxt (DotProtoMessage messageName dotProtoMessage) = - dotProtoMessageD ctxt Anonymous messageName dotProtoMessage -dotProtoDefinitionD _ _ (DotProtoEnum messageName dotProtoEnum) = - dotProtoEnumD Anonymous messageName dotProtoEnum -dotProtoDefinitionD pkgIdent ctxt (DotProtoService serviceName dotProtoService) = - dotProtoServiceD pkgIdent ctxt serviceName dotProtoService - --- | Generate 'Named' instance for a type in this package -namedInstD :: String -> HsDecl -namedInstD messageName = - instDecl_ (protobufName "Named") - [ type_ messageName ] - [ HsFunBind [nameOfDecl] ] - where - nameOfDecl = match_ (HsIdent "nameOf") [HsPWildCard] - (HsUnGuardedRhs (apply fromStringE - [ HsLit (HsString messageName) ])) - [] - --- ** Generate types and instances for .proto messages - --- | Generate data types, 'Bounded', 'Enum', 'FromJSONPB', 'Named', 'Message', --- 'ToJSONPB' instances as appropriate for the given 'DotProtoMessagePart's -dotProtoMessageD - :: MonadError CompileError m - => TypeContext - -> DotProtoIdentifier - -> DotProtoIdentifier - -> [DotProtoMessagePart] - -> m [HsDecl] -dotProtoMessageD ctxt parentIdent messageIdent message = do - messageName <- nestedTypeName parentIdent =<< dpIdentUnqualName messageIdent - - let ctxt' = maybe mempty dotProtoTypeChildContext (M.lookup messageIdent ctxt) <> ctxt - - messagePartFieldD (DotProtoMessageField (DotProtoField _ ty fieldName _ _)) = do - fullName <- prefixedFieldName messageName =<< dpIdentUnqualName fieldName - fullTy <- dptToHsType ctxt' ty - pure [ ([HsIdent fullName], HsUnBangedTy fullTy ) ] - - messagePartFieldD (DotProtoMessageOneOf fieldName _) = do - fullName <- prefixedFieldName messageName =<< dpIdentUnqualName fieldName - qualTyName <- prefixedConName messageName =<< dpIdentUnqualName fieldName - let fullTy = HsTyApp (HsTyCon (haskellName "Maybe")) . type_ $ qualTyName - pure [ ([HsIdent fullName], HsUnBangedTy fullTy) ] - - messagePartFieldD _ = pure [] - - nestedDecls :: MonadError CompileError m => DotProtoDefinition -> m [HsDecl] - nestedDecls (DotProtoMessage subMsgName subMessageDef) = do - parentIdent' <- concatDotProtoIdentifier parentIdent messageIdent - dotProtoMessageD ctxt' parentIdent' subMsgName subMessageDef - - nestedDecls (DotProtoEnum subEnumName subEnumDef) = do - parentIdent' <- concatDotProtoIdentifier parentIdent messageIdent - dotProtoEnumD parentIdent' subEnumName subEnumDef - - nestedDecls _ = pure [] - - nestedOneOfDecls :: MonadError CompileError m - => DotProtoIdentifier -> [DotProtoField] -> m [HsDecl] - nestedOneOfDecls identifier fields = do - fullName <- prefixedConName messageName =<< dpIdentUnqualName identifier - let oneOfCons (DotProtoField _ ty fieldName _ _) = do - consTy <- case ty of - Prim msg@(Named msgName) - | Just DotProtoKindMessage <- dotProtoTypeInfoKind <$> M.lookup msgName ctxt' - -> -- Do not wrap message summands with Maybe. - dpptToHsType ctxt' msg - - _ -> dptToHsType ctxt' ty - - consName <- prefixedConName fullName =<< dpIdentUnqualName fieldName - let ident = HsIdent consName - pure (conDecl_ ident [HsUnBangedTy consTy], ident) - - oneOfCons DotProtoEmptyField = internalError "field type : empty field" - - (cons, idents) <- fmap unzip (mapM oneOfCons fields) - - fieldNames <- mapM (dpIdentUnqualName . dotProtoFieldName) fields - - toSchemaInstance <- toSchemaInstanceDeclaration fullName fieldNames (Just idents) - - pure [ dataDecl_ fullName cons defaultMessageDeriving - , namedInstD fullName - , toSchemaInstance - -#ifdef DHALL - , dhallInterpretInstDecl fullName - , dhallInjectInstDecl fullName -#endif - ] - - conDecl <- recDecl_ (HsIdent messageName) . mconcat <$> - mapM messagePartFieldD message - - nestedDecls_ <- mconcat <$> - sequence [ nestedDecls def | DotProtoMessageDefinition def <- message] - - nestedOneofs_ <- mconcat <$> - sequence [ nestedOneOfDecls ident fields | DotProtoMessageOneOf ident fields <- message ] - - messageInst <- messageInstD ctxt' parentIdent messageIdent message - - toJSONPBInst <- toJSONPBMessageInstD ctxt' parentIdent messageIdent message - fromJSONPBInst <- fromJSONPBMessageInstD ctxt' parentIdent messageIdent message - - fieldNames <- sequence $ do - messagePart <- message - dotProtoIdentifier <- case messagePart of - DotProtoMessageField dotProtoField -> - return (dotProtoFieldName dotProtoField) - DotProtoMessageOneOf dotProtoIdentifier _ -> - return dotProtoIdentifier - _ -> empty - return (dpIdentUnqualName dotProtoIdentifier) - - toSchemaInstance <- toSchemaInstanceDeclaration messageName fieldNames Nothing - - pure $ [ dataDecl_ messageName [ conDecl ] defaultMessageDeriving - , namedInstD messageName - , messageInst - , toJSONPBInst - , fromJSONPBInst - -- Generate Aeson instances in terms of JSONPB instances - , toJSONInstDecl messageName - , fromJSONInstDecl messageName - -- And the Swagger ToSchema instance corresponding to JSONPB encodings - , toSchemaInstance - -#ifdef DHALL - -- Generate Dhall instances - , dhallInterpretInstDecl messageName - , dhallInjectInstDecl messageName -#endif - ] - <> nestedOneofs_ - <> nestedDecls_ - --- *** Generate Protobuf 'Message' instances - -messageInstD - :: MonadError CompileError m - => TypeContext - -> DotProtoIdentifier -> DotProtoIdentifier - -> [DotProtoMessagePart] - -> m HsDecl -messageInstD ctxt parentIdent msgIdent messageParts = do - msgName <- nestedTypeName parentIdent =<< dpIdentUnqualName msgIdent - qualifiedFields <- getQualifiedFields msgName messageParts - - let encodeMessageField QualifiedField{recordFieldName, fieldInfo} = - let recordFieldName' = HsVar (unqual_ (coerce recordFieldName)) in - case fieldInfo of - FieldNormal _fieldName fieldNum dpType options -> do - fieldE <- wrapE ctxt options dpType recordFieldName' - pure $ apply encodeMessageFieldE [ fieldNumberE fieldNum, fieldE ] - - FieldOneOf OneofField{subfields} -> do - -- Create all pattern match & expr for each constructor: - -- Constructor y -> encodeMessageField num (Nested (Just y)) -- for embedded messages - -- Constructor y -> encodeMessageField num (ForceEmit y) -- for everything else - let mkAlt (OneofSubfield fieldNum conName _ dpType options) = do - let isMaybe - | Prim (Named tyName) <- dpType - = Just DotProtoKindMessage == fmap dotProtoTypeInfoKind (M.lookup tyName ctxt) - | otherwise - = False - - let wrapJust = HsParen . HsApp (HsVar (haskellName "Just")) - - xE <- (if isMaybe then id else fmap forceEmitE) - . wrapE ctxt options dpType - . (if isMaybe then wrapJust else id) - $ HsVar (unqual_ "y") - - pure $ alt_ (HsPApp (unqual_ conName) [patVar "y"]) - (HsUnGuardedAlt (apply encodeMessageFieldE [fieldNumberE fieldNum, xE])) - [] - - alts <- mapM mkAlt subfields - - pure $ HsCase recordFieldName' - [ alt_ (HsPApp (haskellName "Nothing") []) - (HsUnGuardedAlt memptyE) - [] - , alt_ (HsPApp (haskellName "Just") [patVar "x"]) - (HsUnGuardedAlt (HsCase (HsVar (unqual_ "x")) alts)) - [] - ] - - let decodeMessageField QualifiedField{fieldInfo} = do - case fieldInfo of - FieldNormal _fieldName fieldNum dpType options -> - unwrapE ctxt options dpType $ apply atE [ decodeMessageFieldE, fieldNumberE fieldNum ] - - FieldOneOf OneofField{subfields} -> do - -- create a list of (fieldNumber, Cons <$> parser) - let subfieldParserE (OneofSubfield fieldNumber consName _ dpType options) = do - let fE = case dpType of - Prim (Named tyName) - | Just DotProtoKindMessage <- dotProtoTypeInfoKind <$> M.lookup tyName ctxt - -> HsParen (HsApp fmapE (HsVar (unqual_ consName))) - _ -> HsParen (HsInfixApp (HsVar (haskellName "Just")) - composeOp - (HsVar (unqual_ consName))) - - alts <- unwrapE ctxt options dpType decodeMessageFieldE - - pure $ HsTuple - [ fieldNumberE fieldNumber - , HsInfixApp (apply pureE [ fE ]) apOp alts - ] - - parsers <- mapM subfieldParserE subfields - - pure $ apply oneofE [ HsVar (haskellName "Nothing") - , HsList parsers - ] - - let dotProtoE = HsList - [ apply dotProtoFieldC - [ fieldNumberE fieldNum - , dpTypeE dpType - , dpIdentE fieldIdent - , HsList (map optionE options) - , maybeE (HsLit . HsString) comments - ] - | DotProtoMessageField (DotProtoField fieldNum dpType fieldIdent options comments) - <- messageParts - ] - - let punnedFieldsP = - [ HsPFieldPat (unqual_ fieldName) (HsPVar (HsIdent fieldName)) - | QualifiedField (coerce -> fieldName) _ <- qualifiedFields - ] - - encodedFields <- mapM encodeMessageField qualifiedFields - decodedFields <- mapM decodeMessageField qualifiedFields - - let encodeMessageE = apply mconcatE [ HsList encodedFields] - let decodeMessageE = foldl (\f -> HsInfixApp f apOp) - (apply pureE [ HsVar (unqual_ msgName) ]) - decodedFields - - let encodeMessageDecl = match_ (HsIdent "encodeMessage") - [HsPWildCard, HsPRec (unqual_ msgName) punnedFieldsP] - (HsUnGuardedRhs encodeMessageE) [] - let decodeMessageDecl = match_ (HsIdent "decodeMessage") [ HsPWildCard ] - (HsUnGuardedRhs decodeMessageE) [] - let dotProtoDecl = match_ (HsIdent "dotProto") [HsPWildCard] - (HsUnGuardedRhs dotProtoE) [] - - pure $ instDecl_ (protobufName "Message") - [ type_ msgName ] - [ HsFunBind [ encodeMessageDecl ] - , HsFunBind [ decodeMessageDecl ] - , HsFunBind [ dotProtoDecl ] - ] - - --- *** Generate ToJSONPB/FromJSONPB instances - -toJSONPBMessageInstD - :: MonadError CompileError m - => TypeContext - -> DotProtoIdentifier - -> DotProtoIdentifier - -> [DotProtoMessagePart] - -> m HsDecl -toJSONPBMessageInstD _ctxt parentIdent msgIdent messageParts = do - msgName <- nestedTypeName parentIdent =<< dpIdentUnqualName msgIdent - qualFields <- getQualifiedFields msgName messageParts - - -- E.g. - -- "another" .= f2 -- always succeeds (produces default value on missing field) - let defPairE fldName fldNum = - HsInfixApp (HsLit (HsString (coerce fldName))) - toJSONPBOp - (HsVar (unqual_ (fieldBinder fldNum))) - -- E.g. - -- HsJSONPB.pair "name" f4 -- fails on missing field - let pairE fldNm varNm = - apply (HsVar (jsonpbName "pair")) - [ HsLit (HsString (coerce fldNm)) - , HsVar (unqual_ varNm) - ] - - -- Suppose we have a sum type Foo, nested inside a message Bar. - -- We want to generate the following: - -- - -- > toJSONPB (Bar foo more stuff) = - -- > HsJSONPB.object - -- > [ (let encodeFoo = ( :: 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 +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE ViewPatterns #-} + +{-| This module provides functions to generate Haskell declarations for protobuf + messages +-} + +module Proto3.Suite.DotProto.Generate + ( CompileError(..) + , TypeContext + , CompileArgs(..) + , compileDotProtoFile + , compileDotProtoFileOrDie + , hsModuleForDotProto + , renderHsModuleForDotProto + , readDotProtoWithContext + ) where + +import Control.Applicative +import Control.Lens ((&), ix, over, has, filtered) +import Control.Monad.Except +import Data.Char +import Data.Coerce +import Data.Either (partitionEithers) +import Data.List (find, intercalate, nub, sortBy, stripPrefix) +import qualified Data.List.NonEmpty as NE +import qualified Data.Map as M +import Data.Maybe (fromMaybe) +import Data.Monoid +import Data.Ord (comparing) +import qualified Data.Set as S +import Data.String (fromString) +import qualified Data.Text as T +import Filesystem.Path.CurrentOS ((), (<.>)) +import qualified Filesystem.Path.CurrentOS as FP +import Language.Haskell.Parser (ParseResult(..), parseModule) +import Language.Haskell.Pretty +import Language.Haskell.Syntax +import qualified NeatInterpolation as Neat +import Prelude hiding (FilePath) +import Proto3.Suite.DotProto +import Proto3.Suite.DotProto.AST.Lens +import Proto3.Suite.DotProto.Internal +import Proto3.Suite.DotProto.Rendering (Pretty(..)) +import Proto3.Wire.Types (FieldNumber (..)) +import System.IO (writeFile, readFile) +import qualified Turtle +import Turtle (FilePath) + + +-- +-- * Public interface +-- + +data CompileArgs = CompileArgs + { includeDir :: [FilePath] + , extraInstanceFiles :: [FilePath] + , inputProto :: FilePath + , outputDir :: FilePath + } + +-- | Generate a Haskell module corresponding to a @.proto@ file +compileDotProtoFile :: CompileArgs -> IO (Either CompileError ()) +compileDotProtoFile CompileArgs{..} = runExceptT $ do + (dotProto, importTypeContext) <- readDotProtoWithContext includeDir inputProto + + modulePathPieces <- traverse typeLikeName . components . metaModulePath . protoMeta $ dotProto + + let relativePath = FP.concat (map fromString $ NE.toList modulePathPieces) <.> "hs" + let modulePath = outputDir relativePath + + Turtle.mktree (Turtle.directory modulePath) + + extraInstances <- foldMapM getExtraInstances extraInstanceFiles + + haskellModule <- renderHsModuleForDotProto extraInstances dotProto importTypeContext + + liftIO (writeFile (FP.encodeString modulePath) haskellModule) + +-- | As 'compileDotProtoFile', except terminates the program with an error +-- message on failure. +compileDotProtoFileOrDie :: CompileArgs -> IO () +compileDotProtoFileOrDie args = compileDotProtoFile args >>= \case + Left e -> do + -- TODO: pretty print the error messages + let errText = Turtle.format Turtle.w e + let dotProtoPathText = Turtle.format Turtle.fp (inputProto args) + dieLines [Neat.text| + Error: failed to compile "${dotProtoPathText}": + + ${errText} + |] + _ -> pure () + +-- | Compile a 'DotProto' AST into a 'String' representing the Haskell +-- source of a module implementing types and instances for the .proto +-- messages and enums. +renderHsModuleForDotProto + :: MonadError CompileError m + => ([HsImportDecl],[HsDecl]) -> DotProto -> TypeContext -> m String +renderHsModuleForDotProto extraInstanceFiles dotProto importCtxt = do + haskellModule <- hsModuleForDotProto extraInstanceFiles dotProto importCtxt + return (T.unpack header ++ prettyPrint haskellModule) + where + header = [Neat.text| + {-# LANGUAGE DeriveGeneric #-} + {-# LANGUAGE DeriveAnyClass #-} + {-# LANGUAGE DataKinds #-} + {-# LANGUAGE GADTs #-} + {-# LANGUAGE TypeApplications #-} + {-# LANGUAGE OverloadedStrings #-} + {-# OPTIONS_GHC -fno-warn-unused-imports #-} + {-# OPTIONS_GHC -fno-warn-name-shadowing #-} + {-# OPTIONS_GHC -fno-warn-unused-matches #-} + + -- | Generated by Haskell protocol buffer compiler. DO NOT EDIT! + |] + +-- | Compile a Haskell module AST given a 'DotProto' package AST. +-- Instances given in @eis@ override those otherwise generated. +hsModuleForDotProto + :: MonadError CompileError m + => ([HsImportDecl], [HsDecl]) + -- ^ Extra user-define instances that override default generated instances + -> DotProto + -- ^ + -> TypeContext + -- ^ + -> m HsModule +hsModuleForDotProto + (extraImports, extraInstances) + dotProto@DotProto{ protoMeta = DotProtoMeta { metaModulePath = modulePath } + , protoPackage + , protoDefinitions + } + importTypeContext + = do + packageIdentifier <- protoPackageName protoPackage + moduleName <- modulePathModName modulePath + + typeContextImports <- ctxtImports importTypeContext + + let hasService = has (traverse._DotProtoService) protoDefinitions + + let importDeclarations = + concat [ defaultImports hasService, extraImports, typeContextImports ] + + typeContext <- dotProtoTypeContext dotProto + + let toDotProtoDeclaration = + dotProtoDefinitionD packageIdentifier (typeContext <> importTypeContext) + + let extraInstances' = instancesForModule moduleName extraInstances + + decls <- replaceHsInstDecls extraInstances' <$> + foldMapM toDotProtoDeclaration protoDefinitions + + return (module_ moduleName Nothing importDeclarations decls) + +getExtraInstances + :: (MonadIO m, MonadError CompileError m) + => FilePath -> m ([HsImportDecl], [HsDecl]) +getExtraInstances extraInstanceFile = do + + contents <- liftIO (readFile (FP.encodeString extraInstanceFile)) + + case parseModule contents of + ParseOk (HsModule _srcloc _mod _es idecls decls) -> do + let isInstDecl HsInstDecl{} = True + isInstDecl _ = False + + return (idecls, filter isInstDecl decls) --TODO give compile result + + ParseFailed srcLoc err -> do + let srcLocText = Turtle.format Turtle.w srcLoc + + let errText = T.pack err + + let message = [Neat.text| + Error: Failed to parse instance file + + ${srcLocText}: ${errText} + |] + + internalError (T.unpack message) + +-- | This very specific function will only work for the qualification on the very first type +-- in the object of an instance declaration. Those are the only sort of instance declarations +-- generated within this code, so it suffices. +instancesForModule :: Module -> [HsDecl] -> [HsDecl] +instancesForModule m = foldr go [] + where go x xs = case x of + HsInstDecl a b c (HsTyCon (Qual tm i):ts) d -> + if m == tm then HsInstDecl a b c (HsTyCon (UnQual i):ts) d:xs else xs + _ -> xs + +-- | For each thing in @base@ replaces it if it finds a matching @override@ +replaceHsInstDecls :: [HsDecl] -> [HsDecl] -> [HsDecl] +replaceHsInstDecls overrides base = concatMap mbReplace base + where + -- instances defined separately from data type definition: + mbReplace hid@(HsInstDecl _ _ qn tys _) = + (: []) . fromMaybe hid $ search qn tys + + -- instances listed in "deriving" clause of data type definition: + mbReplace (HsDataDecl loc ctx tyn names def insts) = + let (uncustomized, customized) = partitionEithers (map (deriv tyn) insts) + in HsDataDecl loc ctx tyn names def uncustomized : customized + + -- irrelevant declarations remain unchanged: + mbReplace hid = [hid] + + deriv tyn qn = maybe (Left qn) Right $ search qn [HsTyCon (UnQual tyn)] + + search qn tys = find (\x -> Just (unQual qn,tys) == getSig x) overrides + + getSig (HsInstDecl _ _ qn tys _) = Just (unQual qn,tys) + getSig _ = Nothing + + unQual (Qual _ n) = Just n + unQual (UnQual n) = Just n + unQual (Special _) = Nothing + +-- | Parses the file at the given path and produces an AST along with a +-- 'TypeContext' representing all types from imported @.proto@ files, using the +-- first parameter as a list of paths to search for imported files. Terminates +-- with exit code 1 when an included file cannot be found in the search path. +readDotProtoWithContext + :: (MonadError CompileError m, MonadIO m) + => [FilePath] + -> FilePath + -> m (DotProto, TypeContext) +readDotProtoWithContext [] toplevelProto = do + -- If we're not given a search path, default to using the current working + -- directory, as `protoc` does + cwd <- Turtle.pwd + readDotProtoWithContext [cwd] toplevelProto + +readDotProtoWithContext searchPaths toplevelProto = do + dp <- importProto searchPaths toplevelProto toplevelProto + let importIt = readImportTypeContext searchPaths toplevelProto (S.singleton toplevelProto) + tc <- foldMapM importIt (protoImports dp) + pure (dp, tc) + +-- | Build the type context for an import, resolving transitive imports. +readImportTypeContext + :: (MonadError CompileError m, MonadIO m) + => [FilePath] + -> FilePath + -> S.Set FilePath + -> DotProtoImport + -> m TypeContext +readImportTypeContext searchPaths toplevelFP alreadyRead (DotProtoImport _ path) + | path `S.member` alreadyRead = throwError (CircularImport path) + | otherwise = do + import_ <- importProto searchPaths toplevelFP path + importPkg <- protoPackageName (protoPackage import_) + + let fixImportTyInfo tyInfo = + tyInfo { dotProtoTypeInfoPackage = DotProtoPackageSpec importPkg + , dotProtoTypeInfoModulePath = metaModulePath . protoMeta $ import_ + } + importTypeContext <- fmap fixImportTyInfo <$> dotProtoTypeContext import_ + + qualifiedTypeContext <- mapKeysM (concatDotProtoIdentifier importPkg) importTypeContext + + let isPublic (DotProtoImport q _) = q == DotProtoImportPublic + transitiveImportsTC <- + foldMapOfM (traverse . filtered isPublic) + (readImportTypeContext searchPaths toplevelFP (S.insert path alreadyRead)) + (protoImports import_) + + pure $ importTypeContext <> qualifiedTypeContext <> transitiveImportsTC + +-- | Given a type context, generates the Haskell import statements necessary +-- to import all the required types. +ctxtImports :: MonadError CompileError m => TypeContext -> m [HsImportDecl] +ctxtImports = fmap (map mkImport . nub) + . traverse (modulePathModName . dotProtoTypeInfoModulePath) + . M.elems + where + mkImport modName = importDecl_ modName True Nothing Nothing + +-------------------------------------------------------------------------------- +-- +-- * Helper functions for Haskell code generation +-- + +-- ** Names + +-- | Generate the Haskell type name for a 'DotProtoTypeInfo' for a message / +-- enumeration being compiled. NB: We ignore the 'dotProtoTypeInfoPackage' +-- field of the 'DotProtoTypeInfo' parameter, instead demanding that we have +-- been provided with a valid module path in its 'dotProtoTypeInfoModulePath' +-- field. The latter describes the name of the Haskell module being generated. +msgTypeFromDpTypeInfo :: MonadError CompileError m + => DotProtoTypeInfo -> DotProtoIdentifier -> m HsType +msgTypeFromDpTypeInfo DotProtoTypeInfo{..} ident = do + modName <- modulePathModName dotProtoTypeInfoModulePath + identName <- qualifiedMessageName dotProtoTypeInfoParent ident + pure $ HsTyCon (Qual modName (HsIdent identName)) + +haskellName, jsonpbName, grpcName, protobufName, proxyName :: String -> HsQName +haskellName name = Qual (Module "Hs") (HsIdent name) +jsonpbName name = Qual (Module "HsJSONPB") (HsIdent name) +grpcName name = Qual (Module "HsGRPC") (HsIdent name) +protobufName name = Qual (Module "HsProtobuf") (HsIdent name) +proxyName name = Qual (Module "Proxy") (HsIdent name) + +modulePathModName :: MonadError CompileError m => Path -> m Module +modulePathModName (Path comps) = Module . intercalate "." <$> traverse typeLikeName (NE.toList comps) + +_pkgIdentModName :: MonadError CompileError m => DotProtoIdentifier -> m Module +_pkgIdentModName (Single s) = Module <$> typeLikeName s +_pkgIdentModName (Dots path) = modulePathModName path +_pkgIdentModName x = throwError (InvalidPackageName x) + + +-- ** Dhall + +#ifdef DHALL +hsDhallPB :: String +hsDhallPB = "HsDhallPb" + +dhallPBName :: String -> HsQName +dhallPBName name = Qual (Module hsDhallPB) (HsIdent name) + +-- *** Generate Dhall Interpret and Inject generic instances + +dhallInterpretInstDecl :: String -> HsDecl +dhallInterpretInstDecl typeName = + instDecl_ (dhallPBName "Interpret") + [ type_ typeName ] + [ ] + +dhallInjectInstDecl :: String -> HsDecl +dhallInjectInstDecl typeName = + instDecl_ (dhallPBName "Inject") + [ type_ typeName ] + [ ] +#endif + +-- ** Helpers to wrap/unwrap types for protobuf (de-)serialization + +coerceE :: Bool -> HsType -> HsType -> Maybe HsExp +coerceE _ from to | from == to = Nothing +coerceE unsafe from to = Just $ HsApp (HsApp coerceF (typeApp from)) (typeApp to) + where + -- Do not add linebreaks to typeapps as that causes parse errors + pp = prettyPrintStyleMode style{mode=OneLineMode} defaultMode + typeApp ty = uvar_ ("@("++ pp ty ++ ")") + coerceF | unsafe = HsVar (haskellName "unsafeCoerce") + | otherwise = HsVar (haskellName "coerce") + +wrapE :: MonadError CompileError m => TypeContext -> [DotProtoOption] -> DotProtoType -> HsExp -> m HsExp +wrapE ctxt opts dpt e = maybe e (\f -> apply f [e]) <$> + (coerceE (isMap dpt) <$> dptToHsType ctxt dpt <*> dptToHsTypeWrapped opts ctxt dpt) + +unwrapE :: MonadError CompileError m => TypeContext -> [DotProtoOption] -> DotProtoType -> HsExp -> m HsExp +unwrapE ctxt opts dpt e = maybe e (\f -> apply f [e]) <$> + (coerceE (isMap dpt) <$> overParser (dptToHsTypeWrapped opts ctxt dpt) <*> overParser (dptToHsType ctxt dpt)) + where + overParser = fmap $ HsTyApp (HsTyVar (HsIdent "_")) + + +-------------------------------------------------------------------------------- +-- +-- * Functions to convert 'DotProtoType' into Haskell types +-- + +-- | Convert a dot proto type to a Haskell type +dptToHsType :: MonadError CompileError m => TypeContext -> DotProtoType -> m HsType +dptToHsType = foldDPT dptToHsContType dpptToHsType + +-- | Convert a dot proto type to a wrapped Haskell type +dptToHsTypeWrapped :: MonadError CompileError m => [DotProtoOption] -> TypeContext -> DotProtoType -> m HsType +dptToHsTypeWrapped opts = + foldDPT + -- The wrapper for the collection type replaces the native haskell + -- collection type, so try that first. + (\ctxt ty -> maybe (dptToHsContType ctxt ty) id (dptToHsWrappedContType ctxt opts ty)) + -- Always wrap the primitive type. + (\ctxt ty -> dpptToHsTypeWrapper ty <$> dpptToHsType ctxt ty) + +foldDPT :: MonadError CompileError m + => (TypeContext -> DotProtoType -> HsType -> HsType) + -> (TypeContext -> DotProtoPrimType -> m HsType) + -> TypeContext + -> DotProtoType + -> m HsType +foldDPT dptToHsCont foldPrim ctxt dpt = + let + prim = foldPrim ctxt + go = foldDPT dptToHsCont foldPrim ctxt + cont = dptToHsCont ctxt dpt + in + case dpt of + Prim pType -> cont <$> prim pType + Optional pType -> cont <$> prim pType + Repeated pType -> cont <$> prim pType + NestedRepeated pType -> cont <$> prim pType + Map k v | validMapKey k -> HsTyApp . cont <$> prim k <*> go (Prim v) -- need to 'Nest' message types + | otherwise -> throwError $ InvalidMapKeyType (show $ pPrint k) + +-- | Translate DotProtoType constructors to wrapped Haskell container types +-- (for Message serde instances). +dptToHsWrappedContType :: TypeContext -> [DotProtoOption] -> DotProtoType -> Maybe (HsType -> HsType) +dptToHsWrappedContType ctxt opts = \case + Prim (Named tyName) + | isMessage ctxt tyName -> Just $ HsTyApp (protobufType_ "Nested") + Repeated (Named tyName) + | isMessage ctxt tyName -> Just $ HsTyApp (protobufType_ "NestedVec") + Repeated ty + | isUnpacked opts -> Just $ HsTyApp (protobufType_ "UnpackedVec") + | isPacked opts -> Just $ HsTyApp (protobufType_ "PackedVec") + | isPackable ctxt ty -> Just $ HsTyApp (protobufType_ "PackedVec") + | otherwise -> Just $ HsTyApp (protobufType_ "UnpackedVec") + _ -> Nothing + +-- | Translate DotProtoType to Haskell container types. +dptToHsContType :: TypeContext -> DotProtoType -> HsType -> HsType +dptToHsContType ctxt = \case + Prim (Named tyName) | isMessage ctxt tyName + -> HsTyApp $ primType_ "Maybe" + Optional _ -> HsTyApp $ primType_ "Maybe" + Repeated _ -> HsTyApp $ primType_ "Vector" + NestedRepeated _ -> HsTyApp $ primType_ "Vector" + Map _ _ -> HsTyApp $ primType_ "Map" + _ -> id + +-- | Haskell wrapper for primitive dot proto types +dpptToHsTypeWrapper :: DotProtoPrimType -> HsType -> HsType +dpptToHsTypeWrapper = \case + SInt32 -> HsTyApp (protobufType_ "Signed") + SInt64 -> HsTyApp (protobufType_ "Signed") + SFixed32 -> HsTyApp (protobufType_ "Signed") . HsTyApp (protobufType_ "Fixed") + SFixed64 -> HsTyApp (protobufType_ "Signed") . HsTyApp (protobufType_ "Fixed") + Fixed32 -> HsTyApp (protobufType_ "Fixed") + Fixed64 -> HsTyApp (protobufType_ "Fixed") + _ -> id + +-- | Convert a dot proto prim type to an unwrapped Haskell type +dpptToHsType :: MonadError CompileError m => TypeContext -> DotProtoPrimType -> m HsType +dpptToHsType ctxt = \case + Int32 -> pure $ primType_ "Int32" + Int64 -> pure $ primType_ "Int64" + SInt32 -> pure $ primType_ "Int32" + SInt64 -> pure $ primType_ "Int64" + UInt32 -> pure $ primType_ "Word32" + UInt64 -> pure $ primType_ "Word64" + Fixed32 -> pure $ primType_ "Word32" + Fixed64 -> pure $ primType_ "Word64" + SFixed32 -> pure $ primType_ "Int32" + SFixed64 -> pure $ primType_ "Int64" + String -> pure $ primType_ "Text" + Bytes -> pure $ primType_ "ByteString" + Bool -> pure $ primType_ "Bool" + Float -> pure $ primType_ "Float" + Double -> pure $ primType_ "Double" + Named msgName -> + case M.lookup msgName ctxt of + Just ty@(DotProtoTypeInfo { dotProtoTypeInfoKind = DotProtoKindEnum }) -> + HsTyApp (protobufType_ "Enumerated") <$> msgTypeFromDpTypeInfo ty msgName + Just ty -> msgTypeFromDpTypeInfo ty msgName + Nothing -> noSuchTypeError msgName + + +validMapKey :: DotProtoPrimType -> Bool +validMapKey = (`elem` [ Int32, Int64, SInt32, SInt64, UInt32, UInt64 + , Fixed32, Fixed64, SFixed32, SFixed64 + , String, Bool]) + + +-------------------------------------------------------------------------------- +-- +-- * Code generation +-- + +-- ** Generate instances for a 'DotProto' package + +dotProtoDefinitionD :: MonadError CompileError m + => DotProtoIdentifier -> TypeContext -> DotProtoDefinition -> m [HsDecl] +dotProtoDefinitionD pkgIdent ctxt = \case + DotProtoMessage _ messageName messageParts -> + dotProtoMessageD ctxt Anonymous messageName messageParts + + DotProtoEnum _ enumName enumParts -> + dotProtoEnumD Anonymous enumName enumParts + + DotProtoService _ serviceName serviceParts -> + dotProtoServiceD pkgIdent ctxt serviceName serviceParts + +-- | Generate 'Named' instance for a type in this package +namedInstD :: String -> HsDecl +namedInstD messageName = + instDecl_ (protobufName "Named") + [ type_ messageName ] + [ HsFunBind [nameOfDecl] ] + where + nameOfDecl = match_ (HsIdent "nameOf") [HsPWildCard] + (HsUnGuardedRhs (apply fromStringE + [ str_ messageName ])) + [] + +hasDefaultInstD :: String -> HsDecl +hasDefaultInstD messageName = + instDecl_ (protobufName "HasDefault") + [ type_ messageName ] + [ ] + +-- ** Generate types and instances for .proto messages + +-- | Generate data types, 'Bounded', 'Enum', 'FromJSONPB', 'Named', 'Message', +-- 'ToJSONPB' instances as appropriate for the given 'DotProtoMessagePart's +dotProtoMessageD + :: forall m + . MonadError CompileError m + => TypeContext + -> DotProtoIdentifier + -> DotProtoIdentifier + -> [DotProtoMessagePart] + -> m [HsDecl] +dotProtoMessageD ctxt parentIdent messageIdent messageParts = do + messageName <- qualifiedMessageName parentIdent messageIdent + + let mkDataDecl flds = + dataDecl_ messageName + [ recDecl_ (HsIdent messageName) flds ] + defaultMessageDeriving + + let getName = \case + DotProtoMessageField fld -> [dotProtoFieldName fld] + DotProtoMessageOneOf ident _ -> [ident] + _ -> [] + + foldMapM id + [ sequence + [ mkDataDecl <$> foldMapM (messagePartFieldD messageName) messageParts + , pure (namedInstD messageName) + , pure (hasDefaultInstD messageName) + , messageInstD ctxt' parentIdent messageIdent messageParts + + , toJSONPBMessageInstD ctxt' parentIdent messageIdent messageParts + , fromJSONPBMessageInstD ctxt' parentIdent messageIdent messageParts + + -- Generate Aeson instances in terms of JSONPB instances + , pure (toJSONInstDecl messageName) + , pure (fromJSONInstDecl messageName) + + -- And the Swagger ToSchema instance corresponding to JSONPB encodings + , toSchemaInstanceDeclaration messageName Nothing + =<< foldMapM (traverse dpIdentUnqualName . getName) messageParts + +#ifdef DHALL + -- Generate Dhall instances + , pure (dhallInterpretInstDecl messageName) + , pure (dhallInjectInstDecl messageName) +#endif + ] + + -- Nested regular and oneof message decls + , foldMapOfM (traverse . _DotProtoMessageDefinition) + nestedDecls + messageParts + + , foldMapOfM (traverse . _DotProtoMessageOneOf) + (uncurry $ nestedOneOfDecls messageName) + messageParts + ] + + where + ctxt' :: TypeContext + ctxt' = maybe mempty dotProtoTypeChildContext (M.lookup messageIdent ctxt) + <> ctxt + + messagePartFieldD :: String -> DotProtoMessagePart -> m [([HsName], HsBangType)] + messagePartFieldD messageName (DotProtoMessageField DotProtoField{..}) = do + fullName <- prefixedFieldName messageName =<< dpIdentUnqualName dotProtoFieldName + fullTy <- dptToHsType ctxt' dotProtoFieldType + pure [ ([HsIdent fullName], HsUnBangedTy fullTy ) ] + + messagePartFieldD messageName (DotProtoMessageOneOf fieldName _) = do + fullName <- prefixedFieldName messageName =<< dpIdentUnqualName fieldName + qualTyName <- prefixedConName messageName =<< dpIdentUnqualName fieldName + let fullTy = HsTyApp (HsTyCon (haskellName "Maybe")) . type_ $ qualTyName + pure [ ([HsIdent fullName], HsUnBangedTy fullTy) ] + + messagePartFieldD _ _ = pure [] + + nestedDecls :: DotProtoDefinition -> m [HsDecl] + nestedDecls (DotProtoMessage _ subMsgName subMessageDef) = do + parentIdent' <- concatDotProtoIdentifier parentIdent messageIdent + dotProtoMessageD ctxt' parentIdent' subMsgName subMessageDef + + nestedDecls (DotProtoEnum _ subEnumName subEnumDef) = do + parentIdent' <- concatDotProtoIdentifier parentIdent messageIdent + dotProtoEnumD parentIdent' subEnumName subEnumDef + + nestedDecls _ = pure [] + + nestedOneOfDecls :: String -> DotProtoIdentifier -> [DotProtoField] -> m [HsDecl] + nestedOneOfDecls messageName identifier fields = do + fullName <- prefixedConName messageName =<< dpIdentUnqualName identifier + + (cons, idents) <- fmap unzip (mapM (oneOfCons fullName) fields) + + toSchemaInstance <- toSchemaInstanceDeclaration fullName (Just idents) + =<< mapM (dpIdentUnqualName . dotProtoFieldName) fields + + pure [ dataDecl_ fullName cons defaultMessageDeriving + , namedInstD fullName + , toSchemaInstance + +#ifdef DHALL + , dhallInterpretInstDecl fullName + , dhallInjectInstDecl fullName +#endif + ] + + oneOfCons :: String -> DotProtoField -> m (HsConDecl, HsName) + oneOfCons fullName DotProtoField{..} = do + consTy <- case dotProtoFieldType of + Prim msg@(Named msgName) + | isMessage ctxt' msgName + -> -- Do not wrap message summands with Maybe. + dpptToHsType ctxt' msg + + _ -> dptToHsType ctxt' dotProtoFieldType + + consName <- prefixedConName fullName =<< dpIdentUnqualName dotProtoFieldName + let ident = HsIdent consName + pure (conDecl_ ident [HsUnBangedTy consTy], ident) + + oneOfCons _ DotProtoEmptyField = internalError "field type : empty field" + +-- *** Generate Protobuf 'Message' instances + +messageInstD + :: forall m + . MonadError CompileError m + => TypeContext + -> DotProtoIdentifier + -> DotProtoIdentifier + -> [DotProtoMessagePart] + -> m HsDecl +messageInstD ctxt parentIdent msgIdent messageParts = do + msgName <- qualifiedMessageName parentIdent msgIdent + qualifiedFields <- getQualifiedFields msgName messageParts + + encodedFields <- mapM encodeMessageField qualifiedFields + decodedFields <- mapM decodeMessageField qualifiedFields + + let encodeMessageDecl = match_ (HsIdent "encodeMessage") + [HsPWildCard, HsPRec (unqual_ msgName) punnedFieldsP] + (HsUnGuardedRhs encodeMessageE) [] + + encodeMessageE = apply mconcatE [HsList encodedFields] + + punnedFieldsP = map (fp . coerce . recordFieldName) qualifiedFields + where fp nm = HsPFieldPat (unqual_ nm) (HsPVar (HsIdent nm)) + + + let decodeMessageDecl = match_ (HsIdent "decodeMessage") [ HsPWildCard ] + (HsUnGuardedRhs decodeMessageE) [] + + decodeMessageE = foldl (\f -> HsInfixApp f apOp) + (apply pureE [ uvar_ msgName ]) + decodedFields + + let dotProtoDecl = match_ (HsIdent "dotProto") [HsPWildCard] + (HsUnGuardedRhs dotProtoE) [] + + dotProtoE = HsList $ do + DotProtoMessageField DotProtoField{..} <- messageParts + pure $ apply dotProtoFieldC + [ fieldNumberE dotProtoFieldNumber + , dpTypeE dotProtoFieldType + , dpIdentE dotProtoFieldName + , HsList (map optionE dotProtoFieldOptions) + , str_ dotProtoFieldComment + ] + + + pure $ instDecl_ (protobufName "Message") + [ type_ msgName ] + [ HsFunBind [ encodeMessageDecl ] + , HsFunBind [ decodeMessageDecl ] + , HsFunBind [ dotProtoDecl ] + ] + where + encodeMessageField :: QualifiedField -> m HsExp + encodeMessageField QualifiedField{recordFieldName, fieldInfo} = + let recordFieldName' = uvar_ (coerce recordFieldName) in + case fieldInfo of + FieldNormal _fieldName fieldNum dpType options -> do + fieldE <- wrapE ctxt options dpType recordFieldName' + pure $ apply encodeMessageFieldE [ fieldNumberE fieldNum, fieldE ] + + FieldOneOf OneofField{subfields} -> do + alts <- mapM mkAlt subfields + pure $ HsCase recordFieldName' + [ alt_ (HsPApp (haskellName "Nothing") []) + (HsUnGuardedAlt memptyE) + [] + , alt_ (HsPApp (haskellName "Just") [patVar "x"]) + (HsUnGuardedAlt (HsCase (uvar_ "x") alts)) + [] + ] + where + -- Create all pattern match & expr for each constructor: + -- Constructor y -> encodeMessageField num (Nested (Just y)) -- for embedded messages + -- Constructor y -> encodeMessageField num (ForceEmit y) -- for everything else + mkAlt (OneofSubfield fieldNum conName _ dpType options) = do + let isMaybe + | Prim (Named tyName) <- dpType + = isMessage ctxt tyName + | otherwise + = False + + let wrapJust = HsParen . HsApp (HsVar (haskellName "Just")) + + xE <- (if isMaybe then id else fmap forceEmitE) + . wrapE ctxt options dpType + . (if isMaybe then wrapJust else id) + $ uvar_ "y" + + pure $ alt_ (HsPApp (unqual_ conName) [patVar "y"]) + (HsUnGuardedAlt (apply encodeMessageFieldE [fieldNumberE fieldNum, xE])) + [] + + + decodeMessageField :: QualifiedField -> m HsExp + decodeMessageField QualifiedField{fieldInfo} = + case fieldInfo of + FieldNormal _fieldName fieldNum dpType options -> + unwrapE ctxt options dpType $ apply atE [ decodeMessageFieldE, fieldNumberE fieldNum ] + + FieldOneOf OneofField{subfields} -> do + parsers <- mapM subfieldParserE subfields + pure $ apply oneofE [ HsVar (haskellName "Nothing") + , HsList parsers + ] + where + -- create a list of (fieldNumber, Cons <$> parser) + subfieldParserE (OneofSubfield fieldNumber consName _ dpType options) = do + let fE | Prim (Named tyName) <- dpType, isMessage ctxt tyName + = HsParen (HsApp fmapE (uvar_ consName)) + | otherwise + = HsParen (HsInfixApp (HsVar (haskellName "Just")) + composeOp + (uvar_ consName)) + + alts <- unwrapE ctxt options dpType decodeMessageFieldE + + pure $ HsTuple + [ fieldNumberE fieldNumber + , HsInfixApp (apply pureE [ fE ]) apOp alts + ] + + +-- *** Generate ToJSONPB/FromJSONPB instances + +toJSONPBMessageInstD + :: MonadError CompileError m + => TypeContext + -> DotProtoIdentifier + -> DotProtoIdentifier + -> [DotProtoMessagePart] + -> m HsDecl +toJSONPBMessageInstD _ctxt parentIdent msgIdent messageParts = do + msgName <- qualifiedMessageName parentIdent msgIdent + qualFields <- getQualifiedFields msgName messageParts + + let applyE nm oneofNm = + apply (HsVar (jsonpbName nm)) + [ HsList (foldQF defPairE (oneofCaseE oneofNm) <$> qualFields) ] + + let patBinder = foldQF (const fieldBinder) (oneofSubDisjunctBinder . subfields) + let matchE nm appNm oneofAppNm = + match_ + (HsIdent nm) + [ HsPApp (unqual_ msgName) + (patVar . patBinder <$> qualFields) ] + (HsUnGuardedRhs (applyE appNm oneofAppNm)) + [] + + pure $ instDecl_ (jsonpbName "ToJSONPB") + [ type_ msgName ] + [ HsFunBind [matchE "toJSONPB" "object" "objectOrNull"] + , HsFunBind [matchE "toEncodingPB" "pairs" "pairsOrNull" ] + ] + + where + -- E.g. + -- "another" .= f2 -- always succeeds (produces default value on missing field) + defPairE fldName fldNum = + HsInfixApp (str_ (coerce fldName)) + toJSONPBOp + (uvar_ (fieldBinder fldNum)) + + -- E.g. + -- HsJSONPB.pair "name" f4 -- fails on missing field + pairE fldNm varNm = + apply (HsVar (jsonpbName "pair")) + [ str_ (coerce fldNm) , uvar_ varNm] + + -- Suppose we have a sum type Foo, nested inside a message Bar. + -- We want to generate the following: + -- + -- > toJSONPB (Bar foo more stuff) = + -- > HsJSONPB.object + -- > [ (let encodeFoo = ( :: Options -> Value) + -- > in \option -> if optEmitNamedOneof option + -- > then ("Foo" .= (PB.objectOrNull [encodeFoo] option)) option + -- > else encodeFoo option + -- > ) + -- > , + -- > , + -- > ] + oneofCaseE retJsonCtor (OneofField typeName subfields) = + HsParen + $ HsLet [ HsFunBind [ match_ (HsIdent caseName) [] (HsUnGuardedRhs caseExpr) [] ] ] + $ HsLambda l [patVar optsStr] (HsIf dontInline noInline yesInline) + where + optsStr = "options" + opts = uvar_ optsStr + + caseName = "encode" <> over (ix 0) toUpper typeName + caseBnd = uvar_ caseName + + dontInline = HsApp (HsVar (jsonpbName "optEmitNamedOneof")) opts + + noInline = HsApp (HsParen (HsInfixApp (str_ typeName) + toJSONPBOp + (apply (HsVar (jsonpbName retJsonCtor)) + [ HsList [caseBnd], opts ]))) + opts + + yesInline = HsApp caseBnd opts + + + -- E.g. + -- case f4_or_f9 of + -- Just (SomethingPickOneName f4) + -- -> HsJSONPB.pair "name" f4 + -- Just (SomethingPickOneSomeid f9) + -- -> HsJSONPB.pair "someid" f9 + -- Nothing + -- -> mempty + caseExpr = HsParen $ + HsCase disjunctName (altEs <> [fallthroughE]) + where + disjunctName = uvar_ (oneofSubDisjunctBinder subfields) + altEs = do + sub@(OneofSubfield _ conName pbFldNm _ _) <- subfields + let patVarNm = oneofSubBinder sub + pure $ alt_ (HsPApp (haskellName "Just") + [ HsPParen + (HsPApp (unqual_ conName) [patVar patVarNm]) + ] + ) + (HsUnGuardedAlt (pairE pbFldNm patVarNm)) + [] + fallthroughE = + alt_ (HsPApp (haskellName "Nothing") []) + (HsUnGuardedAlt memptyE) + [] + +fromJSONPBMessageInstD + :: MonadError CompileError m + => TypeContext + -> DotProtoIdentifier + -> DotProtoIdentifier + -> [DotProtoMessagePart] + -> m HsDecl +fromJSONPBMessageInstD _ctxt parentIdent msgIdent messageParts = do + msgName <- qualifiedMessageName parentIdent msgIdent + qualFields <- getQualifiedFields msgName messageParts + + let parseJSONPBE = + apply (HsVar (jsonpbName "withObject")) + [ str_ msgName + , HsParen (HsLambda l [lambdaPVar] fieldAps) + ] + where + fieldAps = foldl (\f -> HsInfixApp f apOp) + (apply pureE [ uvar_ msgName ]) + (foldQF normalParserE oneofParserE <$> qualFields) + + let parseJSONPBDecl = + match_ (HsIdent "parseJSONPB") [] (HsUnGuardedRhs parseJSONPBE) [] + + pure (instDecl_ (jsonpbName "FromJSONPB") + [ type_ msgName ] + [ HsFunBind [ parseJSONPBDecl ] ]) + where + lambdaPVar = patVar "obj" + lambdaVar = uvar_ "obj" + + -- E.g., for message + -- message Something { oneof name_or_id { string name = _; int32 someid = _; } } + -- + -- ==> + -- + -- (let parseSomethingNameOrId parseObj = + -- in ((obj .: "nameOrId") Hs.>>= + -- (HsJSONPB.withObject "nameOrId" parseSomethingNameOrId)) + -- <|> + -- (parseSomethingNameOrId obj) + -- ) + oneofParserE (OneofField oneofType fields) = + HsParen $ + HsLet [ HsFunBind [ match_ (HsIdent letBndStr) [patVar letArgStr ] + (HsUnGuardedRhs tryParseDisjunctsE) [] + ] + ] + (HsInfixApp parseWrapped altOp parseUnwrapped) + where + oneofTyLit = str_ oneofType -- FIXME + + letBndStr = "parse" <> over (ix 0) toUpper oneofType + letBndName = uvar_ letBndStr + letArgStr = "parseObj" + letArgName = uvar_ letArgStr + + parseWrapped = HsParen $ + HsInfixApp (HsParen (HsInfixApp lambdaVar parseJSONPBOp oneofTyLit)) + bindOp + (apply (HsVar (jsonpbName "withObject")) [ oneofTyLit , letBndName ]) + + parseUnwrapped = HsParen (HsApp letBndName lambdaVar) + + -- parseSomethingNameOrId parseObj = + -- Hs.msum + -- [ (Just . SomethingPickOneName) <$> (HsJSONPB.parseField parseObj "name") + -- , (Just . SomethingPickOneSomeid) <$> (HsJSONPB.parseField parseObj "someid") + -- , pure Nothing + -- ] + tryParseDisjunctsE = + HsApp msumE (HsList (map subParserE fields <> fallThruE)) + where + fallThruE + = [ HsApp pureE (HsVar (haskellName "Nothing")) ] + subParserE OneofSubfield{subfieldConsName, subfieldName} + = HsInfixApp + (HsInfixApp (HsVar (haskellName "Just")) + composeOp + (uvar_ subfieldConsName)) + fmapOp + (apply (HsVar (jsonpbName "parseField")) + [ letArgName + , str_ (coerce subfieldName)]) + + -- E.g. obj .: "someid" + normalParserE fldNm _ = + HsInfixApp lambdaVar + parseJSONPBOp + (str_(coerce fldNm)) + +-- *** Generate default Aeson To/FromJSON and Swagger ToSchema instances +-- (These are defined in terms of ToJSONPB) + +toJSONInstDecl :: String -> HsDecl +toJSONInstDecl typeName = + instDecl_ (jsonpbName "ToJSON") + [ type_ typeName ] + [ HsFunBind [ match_ (HsIdent "toJSON") [] + (HsUnGuardedRhs (HsVar (jsonpbName "toAesonValue"))) [] + ] + , HsFunBind [ match_ (HsIdent "toEncoding") [] + (HsUnGuardedRhs (HsVar (jsonpbName "toAesonEncoding"))) [] + ] + ] + +fromJSONInstDecl :: String -> HsDecl +fromJSONInstDecl typeName = + instDecl_ (jsonpbName "FromJSON") + [ type_ typeName ] + [ HsFunBind [match_ (HsIdent "parseJSON") [] + (HsUnGuardedRhs (HsVar (jsonpbName "parseJSONPB"))) [] + ] + ] + + +-- *** Generate `ToSchema` instance + +toSchemaInstanceDeclaration + :: MonadError CompileError m + => String + -- ^ Name of the message type to create an instance for + -> Maybe [HsName] + -- ^ Oneof constructors + -> [String] + -- ^ Field names + -> m HsDecl +toSchemaInstanceDeclaration messageName maybeConstructors fieldNames = do + qualifiedFieldNames <- mapM (prefixedFieldName messageName) fieldNames + + let messageConstructor = HsCon (UnQual (HsIdent messageName)) + + let _namedSchemaNameExpression = HsApp justC (str_ messageName) + + -- { _paramSchemaType = HsJSONPB.SwaggerObject + -- } + let paramSchemaUpdates = + [ HsFieldUpdate _paramSchemaType _paramSchemaTypeExpression + ] + where + _paramSchemaType = jsonpbName "_paramSchemaType" + +#if MIN_VERSION_swagger2(2,4,0) + _paramSchemaTypeExpression = HsApp justC (HsVar (jsonpbName "SwaggerObject")) +#else + _paramSchemaTypeExpression = HsVar (jsonpbName "SwaggerObject") +#endif + + let _schemaParamSchemaExpression = HsRecUpdate memptyE paramSchemaUpdates + + -- [ ("fieldName0", qualifiedFieldName0) + -- , ("fieldName1", qualifiedFieldName1) + -- ... + -- ] + let properties = HsList $ do + (fieldName, qualifiedFieldName) <- zip fieldNames qualifiedFieldNames + return (HsTuple [ str_ fieldName, uvar_ qualifiedFieldName ]) + + let _schemaPropertiesExpression = + HsApp (HsVar (jsonpbName "insOrdFromList")) properties + + -- { _schemaParamSchema = ... + -- , _schemaProperties = ... + -- , ... + -- } + let schemaUpdates = normalUpdates ++ extraUpdates + where + normalUpdates = + [ HsFieldUpdate _schemaParamSchema _schemaParamSchemaExpression + , HsFieldUpdate _schemaProperties _schemaPropertiesExpression + ] + + extraUpdates = + case maybeConstructors of + Just _ -> + [ HsFieldUpdate _schemaMinProperties justOne + , HsFieldUpdate _schemaMaxProperties justOne + ] + Nothing -> + [] + + _schemaParamSchema = jsonpbName "_schemaParamSchema" + _schemaProperties = jsonpbName "_schemaProperties" + _schemaMinProperties = jsonpbName "_schemaMinProperties" + _schemaMaxProperties = jsonpbName "_schemaMaxProperties" + + justOne = HsApp justC (HsLit (HsInt 1)) + + let _namedSchemaSchemaExpression = HsRecUpdate memptyE schemaUpdates + + -- { _namedSchemaName = ... + -- , _namedSchemaSchema = ... + -- } + let namedSchemaUpdates = + [ HsFieldUpdate _namedSchemaName _namedSchemaNameExpression + , HsFieldUpdate _namedSchemaSchema _namedSchemaSchemaExpression + ] + where + _namedSchemaName = jsonpbName "_namedSchemaName" + _namedSchemaSchema = jsonpbName "_namedSchemaSchema" + + let namedSchema = HsRecConstr (jsonpbName "NamedSchema") namedSchemaUpdates + + let toDeclareName fieldName = "declare_" ++ fieldName + + let toArgument fieldName = HsApp asProxy declare + where + declare = uvar_ (toDeclareName fieldName) + + asProxy = HsVar (jsonpbName "asProxy") + + -- do let declare_fieldName0 = HsJSONPB.declareSchemaRef + -- qualifiedFieldName0 <- declare_fieldName0 Proxy.Proxy + -- let declare_fieldName1 = HsJSONPB.declareSchemaRef + -- qualifiedFieldName1 <- declare_fieldName1 Proxy.Proxy + -- ... + -- let _ = pure MessageName <*> HsJSONPB.asProxy declare_fieldName0 <*> HsJSONPB.asProxy declare_fieldName1 <*> ... + -- return (...) + let expressionForMessage = + HsDo (bindingStatements ++ inferenceStatement ++ [ returnStatement ]) + where + bindingStatements = do + (fieldName, qualifiedFieldName) <- zip fieldNames qualifiedFieldNames + + let declareIdentifier = HsIdent (toDeclareName fieldName) + + let stmt0 = HsLetStmt [ HsFunBind + [ HsMatch l declareIdentifier [] + (HsUnGuardedRhs (HsVar (jsonpbName "declareSchemaRef"))) [] + ] + ] + + let stmt1 = HsGenerator l (HsPVar (HsIdent qualifiedFieldName)) + (HsApp (HsVar (UnQual declareIdentifier)) + (HsCon (proxyName "Proxy"))) + [ stmt0, stmt1] + + + inferenceStatement = + if null fieldNames then [] else [ HsLetStmt [ patternBind ] ] + where + arguments = map toArgument fieldNames + + patternBind = HsPatBind l HsPWildCard + (HsUnGuardedRhs (applicativeApply messageConstructor arguments)) [] + + returnStatement = HsQualifier (HsApp returnE (HsParen namedSchema)) + + -- do let declare_fieldName0 = HsJSONPB.declareSchemaRef + -- let _ = pure ConstructorName0 <*> HsJSONPB.asProxy declare_fieldName0 + -- qualifiedFieldName0 <- declare_fieldName0 Proxy.Proxy + -- let declare_fieldName1 = HsJSONPB.declareSchemaRef + -- let _ = pure ConstructorName1 <*> HsJSONPB.asProxy declare_fieldName1 + -- qualifiedFieldName1 <- declare_fieldName1 Proxy.Proxy + -- ... + -- return (...) + let expressionForOneOf constructors = + HsDo (bindingStatements ++ [ returnStatement ]) + where + bindingStatements = do + (fieldName, qualifiedFieldName, constructor) + <- zip3 fieldNames qualifiedFieldNames constructors + + let declareIdentifier = HsIdent (toDeclareName fieldName) + + let stmt0 = HsLetStmt [ HsFunBind + [ HsMatch l declareIdentifier [] + (HsUnGuardedRhs (HsVar (jsonpbName "declareSchemaRef"))) [] + ] + ] + let stmt1 = HsGenerator l (HsPVar (HsIdent qualifiedFieldName)) + (HsApp (HsVar (UnQual declareIdentifier)) + (HsCon (proxyName "Proxy"))) + let inferenceStatement = + if null fieldNames then [] else [ HsLetStmt [ patternBind ] ] + where + arguments = [ toArgument fieldName ] + + patternBind = HsPatBind l HsPWildCard + (HsUnGuardedRhs (applicativeApply (HsCon (UnQual constructor)) arguments)) [] + + [stmt0, stmt1] ++ inferenceStatement + + + returnStatement = HsQualifier (HsApp returnE (HsParen namedSchema)) + + let instanceDeclaration = + instDecl_ className [ classArgument ] [ classDeclaration ] + where + className = jsonpbName "ToSchema" + + classArgument = HsTyCon (UnQual (HsIdent messageName)) + + classDeclaration = HsFunBind [ match ] + where + match = match_ matchName [ HsPWildCard ] rightHandSide [] + where + expression = case maybeConstructors of + Nothing -> expressionForMessage + Just constructors -> expressionForOneOf constructors + + rightHandSide = HsUnGuardedRhs expression + + matchName = HsIdent "declareNamedSchema" + + return instanceDeclaration + + +-- ** Generate types and instances for .proto enums + +dotProtoEnumD + :: MonadError CompileError m + => DotProtoIdentifier + -> DotProtoIdentifier + -> [DotProtoEnumPart] + -> m [HsDecl] +dotProtoEnumD parentIdent enumIdent enumParts = do + enumName <- qualifiedMessageName parentIdent enumIdent + + let enumeratorDecls = + [ (i, conIdent) | DotProtoEnumField conIdent i _options <- enumParts ] + + case enumeratorDecls of + [] -> throwError $ EmptyEnumeration enumName + (i, conIdent) : _ + | i == 0 -> return () + | otherwise -> throwError $ NonzeroFirstEnumeration enumName conIdent i + + enumCons <- fmap (sortBy (comparing fst)) $ + traverse (traverse + (fmap (prefixedEnumFieldName enumName) . dpIdentUnqualName)) + enumeratorDecls + + let enumConNames = map snd enumCons + + minBoundD = + [ match_ (HsIdent "minBound") + [] + (HsUnGuardedRhs (uvar_ (head enumConNames))) + [] + ] + + maxBoundD = + [ match_ (HsIdent "maxBound") + [] + (HsUnGuardedRhs (uvar_ (last enumConNames))) + [] + ] + + compareD = + [ match_ (HsIdent "compare") + [ patVar "x", patVar "y" ] + (HsUnGuardedRhs + (HsApp + (HsApp + (HsVar (haskellName "compare")) + (HsParen + (HsApp (HsVar(protobufName "fromProtoEnum")) + (uvar_ "x") + ) + ) + ) + (HsParen + (HsApp (HsVar (protobufName "fromProtoEnum")) + (uvar_ "y") + ) + ) + ) + ) + [] + ] + + fromProtoEnumD = + [ match_ (HsIdent "fromProtoEnum") [ HsPApp (unqual_ conName) [] ] + (HsUnGuardedRhs (intE conIdx)) + [] + | (conIdx, conName) <- enumCons + ] + + toProtoEnumMayD = + [ match_ (HsIdent "toProtoEnumMay") + [ intP conIdx ] + (HsUnGuardedRhs (HsApp justC (uvar_ conName))) + [] + | (conIdx, conName) <- enumCons ] ++ + [ match_ (HsIdent "toProtoEnumMay") + [ HsPWildCard ] + (HsUnGuardedRhs nothingC) + [] + ] + + parseJSONPBDecls :: [HsMatch] + parseJSONPBDecls = foldr ((:) . matchConName) [mismatch] enumConNames + where + matchConName conName = match_ (HsIdent "parseJSONPB") [pat conName] + (HsUnGuardedRhs + (HsApp pureE (uvar_ conName))) + [] + + pat nm = HsPApp (jsonpbName "String") [ HsPLit (HsString (tryStripEnumName nm)) ] + + tryStripEnumName = fromMaybe <*> stripPrefix enumName + + mismatch = match_ (HsIdent "parseJSONPB") [patVar "v"] + (HsUnGuardedRhs + (apply (HsVar (jsonpbName "typeMismatch")) + [ str_ enumName, uvar_ "v" ])) + [] + + + toJSONPBDecl = + match_ (HsIdent "toJSONPB") [ patVar "x", HsPWildCard ] + (HsUnGuardedRhs + (HsApp (HsVar (jsonpbName "enumFieldString")) + (uvar_ "x"))) + [] + + toEncodingPBDecl = + match_ (HsIdent "toEncodingPB") [ patVar "x", HsPWildCard ] + (HsUnGuardedRhs + (HsApp (HsVar (jsonpbName "enumFieldEncoding")) + (uvar_ "x"))) + [] + + pure [ dataDecl_ enumName + [ conDecl_ (HsIdent con) [] | con <- enumConNames ] + defaultEnumDeriving + , namedInstD enumName + , hasDefaultInstD enumName + , instDecl_ (haskellName "Bounded") [ type_ enumName ] + [ HsFunBind minBoundD + , HsFunBind maxBoundD + ] + , instDecl_ (haskellName "Ord") [ type_ enumName ] + [ HsFunBind compareD ] + , instDecl_ (protobufName "ProtoEnum") [ type_ enumName ] + [ HsFunBind toProtoEnumMayD + , HsFunBind fromProtoEnumD + ] + , instDecl_ (jsonpbName "ToJSONPB") [ type_ enumName ] + [ HsFunBind [toJSONPBDecl] + , HsFunBind [toEncodingPBDecl] + ] + , instDecl_ (jsonpbName "FromJSONPB") [ type_ enumName ] + [ HsFunBind parseJSONPBDecls ] + -- Generate Aeson instances in terms of JSONPB instances + , toJSONInstDecl enumName + , fromJSONInstDecl enumName + +#ifdef DHALL + -- Generate Dhall instances + , dhallInterpretInstDecl enumName + , dhallInjectInstDecl enumName +#endif + + -- And the Finite instance, used to infer a Swagger ToSchema instance + -- for this enumerated type. + , instDecl_ (protobufName "Finite") [ type_ enumName ] [] + ] + +-- ** Generate code for dot proto services + +dotProtoServiceD + :: MonadError CompileError m + => DotProtoIdentifier + -> TypeContext + -> DotProtoIdentifier + -> [DotProtoServicePart] + -> m [HsDecl] +dotProtoServiceD pkgIdent ctxt serviceIdent service = do + serviceName <- typeLikeName =<< dpIdentUnqualName serviceIdent + packageName <- dpIdentQualName pkgIdent + + let endpointPrefix = "/" ++ packageName ++ "." ++ serviceName ++ "/" + + let serviceFieldD (DotProtoServiceRPCMethod RPCMethod{..}) = do + fullName <- prefixedFieldName serviceName =<< dpIdentUnqualName rpcMethodName + + methodName <- case rpcMethodName of + Single nm -> pure nm + _ -> invalidMethodNameError rpcMethodName + + requestTy <- dpptToHsType ctxt (Named rpcMethodRequestType) + responseTy <- dpptToHsType ctxt (Named rpcMethodResponseType) + + let streamingType = + case (rpcMethodRequestStreaming, rpcMethodResponseStreaming) of + (Streaming, Streaming) -> biDiStreamingC + (Streaming, NonStreaming) -> clientStreamingC + (NonStreaming, Streaming) -> serverStreamingC + (NonStreaming, NonStreaming) -> normalC + + pure [ ( endpointPrefix ++ methodName + , fullName, rpcMethodRequestStreaming, rpcMethodResponseStreaming + , HsUnBangedTy $ + HsTyFun (tyApp (HsTyVar (HsIdent "request")) + [streamingType, requestTy, responseTy]) + (tyApp ioT + [tyApp (HsTyVar (HsIdent "response")) + [streamingType, responseTy] + ] + ) + ) + ] + + serviceFieldD _ = pure [] + + fieldsD <- foldMapM serviceFieldD service + + serverFuncName <- prefixedFieldName serviceName "server" + clientFuncName <- prefixedFieldName serviceName "client" + + let conDecl = recDecl_ (HsIdent serviceName) + [ ([HsIdent hsName], ty) | (_, hsName, _, _, ty) <- fieldsD ] + + let serverT = tyApp (HsTyCon (unqual_ serviceName)) + [ serverRequestT, serverResponseT ] + + let serviceServerTypeD = + HsTypeSig l [ HsIdent serverFuncName ] + (HsQualType [] (HsTyFun serverT (HsTyFun serviceOptionsC ioActionT))) + + let serviceServerD = HsFunBind [serverFuncD] + where + serverFuncD = + match_ (HsIdent serverFuncName) + [ HsPRec (unqual_ serviceName) + [ HsPFieldPat (unqual_ methodName) (HsPVar (HsIdent methodName)) + | (_, methodName, _, _, _) <- fieldsD + ] + , HsPApp (unqual_ "ServiceOptions") + [ patVar "serverHost" + , patVar "serverPort" + , patVar "useCompression" + , patVar "userAgentPrefix" + , patVar "userAgentSuffix" + , patVar "initialMetadata" + , patVar "sslConfig" + , patVar "logger" + ] + ] + (HsUnGuardedRhs (apply serverLoopE [ serverOptsE ])) + [] + + handlerE handlerC adapterE methodName hsName = + apply handlerC [ apply methodNameC [ str_ methodName ] + , apply adapterE [ uvar_ hsName ] + ] + + update u v = HsFieldUpdate (unqual_ u) (uvar_ v) + + serverOptsE = HsRecUpdate defaultOptionsE + [ HsFieldUpdate (grpcName "optNormalHandlers") $ + HsList [ handlerE unaryHandlerC convertServerHandlerE endpointName hsName + | (endpointName, hsName, NonStreaming, NonStreaming, _) <- fieldsD + ] + + , HsFieldUpdate (grpcName "optClientStreamHandlers") $ + HsList [ handlerE clientStreamHandlerC convertServerReaderHandlerE endpointName hsName + | (endpointName, hsName, Streaming, NonStreaming, _) <- fieldsD + ] + + + , HsFieldUpdate (grpcName "optServerStreamHandlers") $ + HsList [ handlerE serverStreamHandlerC convertServerWriterHandlerE endpointName hsName + | (endpointName, hsName, NonStreaming, Streaming, _) <- fieldsD + ] + + + , HsFieldUpdate (grpcName "optBiDiStreamHandlers") $ + HsList [ handlerE biDiStreamHandlerC convertServerRWHandlerE endpointName hsName + | (endpointName, hsName, Streaming, Streaming, _) <- fieldsD + ] + + , update "optServerHost" "serverHost" + , update "optServerPort" "serverPort" + , update "optUseCompression" "useCompression" + , update "optUserAgentPrefix" "userAgentPrefix" + , update "optUserAgentSuffix" "userAgentSuffix" + , update "optInitialMetadata" "initialMetadata" + , update "optSSLConfig" "sslConfig" + , update "optLogger" "logger" + ] + + + let clientT = tyApp (HsTyCon (unqual_ serviceName)) [ clientRequestT, clientResultT ] + + let serviceClientTypeD = + HsTypeSig l [ HsIdent clientFuncName ] + (HsQualType [] (HsTyFun grpcClientT (HsTyApp ioT clientT))) + + let serviceClientD = HsFunBind [ clientFuncD ] + where + clientFuncD = match_ (HsIdent clientFuncName) + [ HsPVar (HsIdent "client") ] + ( HsUnGuardedRhs clientRecE ) [] + + clientRecE = foldl (\f -> HsInfixApp f apOp) + (apply pureE [ uvar_ serviceName ]) + [ HsParen $ HsInfixApp clientRequestE' apOp (registerClientMethodE endpointName) + | (endpointName, _, _, _, _) <- fieldsD + ] + + clientRequestE' = apply pureE [ apply clientRequestE [ uvar_ "client" ] ] + + registerClientMethodE endpoint = + apply clientRegisterMethodE [ uvar_ "client" + , apply methodNameC [ str_ endpoint ] + ] + + pure [ HsDataDecl l [] (HsIdent serviceName) + [ HsIdent "request", HsIdent "response" ] + [ conDecl ] defaultServiceDeriving + + , serviceServerTypeD + , serviceServerD + + , serviceClientTypeD + , serviceClientD + ] + +-------------------------------------------------------------------------------- + +-- +-- * Common Haskell expressions, constructors, and operators +-- + +dotProtoFieldC, primC, optionalC, repeatedC, nestedRepeatedC, namedC, mapC, + fieldNumberC, singleC, dotsC, pathC, nestedC, anonymousC, dotProtoOptionC, + identifierC, stringLitC, intLitC, floatLitC, boolLitC, trueC, falseC, + unaryHandlerC, clientStreamHandlerC, serverStreamHandlerC, biDiStreamHandlerC, + methodNameC, nothingC, justC, forceEmitC, mconcatE, encodeMessageFieldE, + fromStringE, decodeMessageFieldE, pureE, returnE, memptyE, msumE, atE, oneofE, + fmapE, defaultOptionsE, serverLoopE, convertServerHandlerE, + convertServerReaderHandlerE, convertServerWriterHandlerE, + convertServerRWHandlerE, clientRegisterMethodE, clientRequestE :: HsExp + +dotProtoFieldC = HsVar (protobufName "DotProtoField") +primC = HsVar (protobufName "Prim") +optionalC = HsVar (protobufName "Optional") +repeatedC = HsVar (protobufName "Repeated") +nestedRepeatedC = HsVar (protobufName "NestedRepeated") +namedC = HsVar (protobufName "Named") +mapC = HsVar (protobufName "Map") +fieldNumberC = HsVar (protobufName "FieldNumber") +singleC = HsVar (protobufName "Single") +pathC = HsVar (protobufName "Path") +dotsC = HsVar (protobufName "Dots") +nestedC = HsVar (protobufName "Nested") +anonymousC = HsVar (protobufName "Anonymous") +dotProtoOptionC = HsVar (protobufName "DotProtoOption") +identifierC = HsVar (protobufName "Identifier") +stringLitC = HsVar (protobufName "StringLit") +intLitC = HsVar (protobufName "IntLit") +floatLitC = HsVar (protobufName "FloatLit") +boolLitC = HsVar (protobufName "BoolLit") +forceEmitC = HsVar (protobufName "ForceEmit") +encodeMessageFieldE = HsVar (protobufName "encodeMessageField") +decodeMessageFieldE = HsVar (protobufName "decodeMessageField") +atE = HsVar (protobufName "at") +oneofE = HsVar (protobufName "oneof") + +trueC = HsVar (haskellName "True") +falseC = HsVar (haskellName "False") +nothingC = HsVar (haskellName "Nothing") +justC = HsVar (haskellName "Just") +mconcatE = HsVar (haskellName "mconcat") +fromStringE = HsVar (haskellName "fromString") +pureE = HsVar (haskellName "pure") +returnE = HsVar (haskellName "return") +memptyE = HsVar (haskellName "mempty") +msumE = HsVar (haskellName "msum") +fmapE = HsVar (haskellName "fmap") + +unaryHandlerC = HsVar (grpcName "UnaryHandler") +clientStreamHandlerC = HsVar (grpcName "ClientStreamHandler") +serverStreamHandlerC = HsVar (grpcName "ServerStreamHandler") +biDiStreamHandlerC = HsVar (grpcName "BiDiStreamHandler") +methodNameC = HsVar (grpcName "MethodName") +defaultOptionsE = HsVar (grpcName "defaultOptions") +serverLoopE = HsVar (grpcName "serverLoop") +convertServerHandlerE = HsVar (grpcName "convertGeneratedServerHandler") +convertServerReaderHandlerE = HsVar (grpcName "convertGeneratedServerReaderHandler") +convertServerWriterHandlerE = HsVar (grpcName "convertGeneratedServerWriterHandler") +convertServerRWHandlerE = HsVar (grpcName "convertGeneratedServerRWHandler") +clientRegisterMethodE = HsVar (grpcName "clientRegisterMethod") +clientRequestE = HsVar (grpcName "clientRequest") + +biDiStreamingC, serverStreamingC, clientStreamingC, normalC, serviceOptionsC, + ioActionT, serverRequestT, serverResponseT, clientRequestT, clientResultT, + ioT, grpcClientT :: HsType +biDiStreamingC = HsTyCon (Qual (Module "'HsGRPC") (HsIdent "BiDiStreaming")) +serverStreamingC = HsTyCon (Qual (Module "'HsGRPC") (HsIdent "ServerStreaming")) +clientStreamingC = HsTyCon (Qual (Module "'HsGRPC") (HsIdent "ClientStreaming")) +normalC = HsTyCon (Qual (Module "'HsGRPC") (HsIdent "Normal")) +serviceOptionsC = HsTyCon (Qual (Module "HsGRPC") (HsIdent "ServiceOptions")) +serverRequestT = HsTyCon (grpcName "ServerRequest") +serverResponseT = HsTyCon (grpcName "ServerResponse") +clientRequestT = HsTyCon (grpcName "ClientRequest") +clientResultT = HsTyCon (grpcName "ClientResult") +grpcClientT = HsTyCon (grpcName "Client") +ioActionT = tyApp ioT [ HsTyTuple [] ] +ioT = HsTyCon (haskellName "IO") + +apOp :: HsQOp +apOp = HsQVarOp (UnQual (HsSymbol "<*>")) + +fmapOp :: HsQOp +fmapOp = HsQVarOp (UnQual (HsSymbol "<$>")) + +composeOp :: HsQOp +composeOp = HsQVarOp (Qual haskellNS (HsSymbol ".")) + +bindOp :: HsQOp +bindOp = HsQVarOp (Qual haskellNS (HsSymbol ">>=")) + +altOp :: HsQOp +altOp = HsQVarOp (UnQual (HsSymbol "<|>")) + +toJSONPBOp :: HsQOp +toJSONPBOp = HsQVarOp (UnQual (HsSymbol ".=")) + +parseJSONPBOp :: HsQOp +parseJSONPBOp = HsQVarOp (UnQual (HsSymbol ".:")) + +neConsOp :: HsQOp +neConsOp = HsQVarOp (Qual haskellNS (HsSymbol ":|")) + +intE :: Integral a => a -> HsExp +intE x = (if x < 0 then HsParen else id) . HsLit . HsInt . fromIntegral $ x + +intP :: Integral a => a -> HsPat +intP x = (if x < 0 then HsPParen else id) . HsPLit . HsInt . fromIntegral $ x + +-- ** Expressions for protobuf-wire types + +forceEmitE :: HsExp -> HsExp +forceEmitE = HsParen . HsApp forceEmitC + +fieldNumberE :: FieldNumber -> HsExp +fieldNumberE = HsParen . HsApp fieldNumberC . intE . getFieldNumber + +dpIdentE :: DotProtoIdentifier -> HsExp +dpIdentE (Single n) = apply singleC [ str_ n ] +dpIdentE (Dots (Path (n NE.:| ns))) + = apply dotsC [ apply pathC [ HsParen (HsInfixApp (str_ n) neConsOp (HsList (map str_ ns))) ] ] +dpIdentE (Qualified a b) = apply nestedC [ dpIdentE a, dpIdentE b ] +dpIdentE Anonymous = anonymousC + +dpValueE :: DotProtoValue -> HsExp +dpValueE (Identifier nm) = apply identifierC [ dpIdentE nm ] +dpValueE (StringLit s) = apply stringLitC [ str_ s ] +dpValueE (IntLit i) = apply intLitC [ HsLit (HsInt (fromIntegral i)) ] +dpValueE (FloatLit f) = apply floatLitC [ HsLit (HsFrac (toRational f)) ] +dpValueE (BoolLit True) = apply boolLitC [ trueC ] +dpValueE (BoolLit False) = apply boolLitC [ falseC ] + +optionE :: DotProtoOption -> HsExp +optionE (DotProtoOption name value) = + apply dotProtoOptionC [ dpIdentE name, dpValueE value ] + +-- | Translate a dot proto type to its Haskell AST type +dpTypeE :: DotProtoType -> HsExp +dpTypeE (Prim p) = apply primC [ dpPrimTypeE p ] +dpTypeE (Optional p) = apply optionalC [ dpPrimTypeE p ] +dpTypeE (Repeated p) = apply repeatedC [ dpPrimTypeE p ] +dpTypeE (NestedRepeated p) = apply nestedRepeatedC [ dpPrimTypeE p ] +dpTypeE (Map k v) = apply mapC [ dpPrimTypeE k, dpPrimTypeE v] + + +-- | Translate a dot proto primitive type to a Haskell AST primitive type. +dpPrimTypeE :: DotProtoPrimType -> HsExp +dpPrimTypeE ty = + let wrap = HsVar . protobufName in + case ty of + Named n -> apply namedC [ dpIdentE n ] + + Int32 -> wrap "Int32" + Int64 -> wrap "Int64" + SInt32 -> wrap "SInt32" + SInt64 -> wrap "SInt64" + UInt32 -> wrap "UInt32" + UInt64 -> wrap "UInt64" + Fixed32 -> wrap "Fixed32" + Fixed64 -> wrap "Fixed64" + SFixed32 -> wrap "SFixed32" + SFixed64 -> wrap "SFixed64" + String -> wrap "String" + Bytes -> wrap "Bytes" + Bool -> wrap "Bool" + Float -> wrap "Float" + Double -> wrap "Double" + +defaultImports :: Bool -> [HsImportDecl] +defaultImports usesGrpc = + [ importDecl_ (m "Prelude") & qualified haskellNS & everything + , importDecl_ (m "Proto3.Suite.Class") & qualified protobufNS & everything +#ifdef DHALL + , importDecl_ (m "Proto3.Suite.DhallPB") & qualified (m hsDhallPB) & everything +#endif + , importDecl_ (m "Proto3.Suite.DotProto") & qualified protobufNS & everything + , importDecl_ (m "Proto3.Suite.JSONPB") & qualified jsonpbNS & everything + , importDecl_ (m "Proto3.Suite.JSONPB") & unqualified & selecting [s".=", s".:"] + , importDecl_ (m "Proto3.Suite.Types") & qualified protobufNS & everything + , importDecl_ (m "Proto3.Wire") & qualified protobufNS & everything + , importDecl_ (m "Control.Applicative") & qualified haskellNS & everything + , importDecl_ (m "Control.Applicative") & unqualified & selecting [s"<*>", s"<|>", s"<$>"] + , importDecl_ (m "Control.DeepSeq") & qualified haskellNS & everything + , importDecl_ (m "Control.Monad") & qualified haskellNS & everything + , importDecl_ (m "Data.ByteString") & qualified haskellNS & everything + , importDecl_ (m "Data.Coerce") & qualified haskellNS & everything + , importDecl_ (m "Data.Int") & qualified haskellNS & selecting [i"Int16", i"Int32", i"Int64"] + , importDecl_ (m "Data.List.NonEmpty") & qualified haskellNS & selecting [HsIThingAll (HsIdent "NonEmpty")] + , importDecl_ (m "Data.Map") & qualified haskellNS & selecting [i"Map", i"mapKeysMonotonic"] + , importDecl_ (m "Data.Proxy") & qualified proxyNS & everything + , importDecl_ (m "Data.String") & qualified haskellNS & selecting [i"fromString"] + , importDecl_ (m "Data.Text.Lazy") & qualified haskellNS & selecting [i"Text"] + , importDecl_ (m "Data.Vector") & qualified haskellNS & selecting [i"Vector"] + , importDecl_ (m "Data.Word") & qualified haskellNS & selecting [i"Word16", i"Word32", i"Word64"] + , importDecl_ (m "GHC.Enum") & qualified haskellNS & everything + , importDecl_ (m "GHC.Generics") & qualified haskellNS & everything + , importDecl_ (m "Unsafe.Coerce") & qualified haskellNS & everything + ] + <> + (if not usesGrpc then [] else + [ importDecl_ (m "Network.GRPC.HighLevel.Generated") & alias grpcNS & everything + , importDecl_ (m "Network.GRPC.HighLevel.Client") & alias grpcNS & everything + , importDecl_ (m "Network.GRPC.HighLevel.Server") & alias grpcNS & hiding [i"serverLoop"] + , importDecl_ (m "Network.GRPC.HighLevel.Server.Unregistered") & alias grpcNS & selecting [i"serverLoop"] + ]) + where + m = Module + i = HsIVar . HsIdent + s = HsIVar . HsSymbol + + grpcNS = m "HsGRPC" + jsonpbNS = m "HsJSONPB" + protobufNS = m "HsProtobuf" + proxyNS = m "Proxy" + + -- staged constructors for importDecl + qualified :: Module -> (Bool -> Maybe Module -> a) -> a + qualified m' f = f True (Just m') + + unqualified :: (Bool -> Maybe Module -> a) -> a + unqualified f = f False Nothing + + -- import unqualified AND also under a namespace + alias :: Module -> (Bool -> Maybe Module -> a) -> a + alias m' f = f False (Just m') + + selecting :: [HsImportSpec] -> (Maybe (Bool, [HsImportSpec]) -> a) -> a + selecting is f = f (Just (False, is)) + + hiding :: [HsImportSpec] -> (Maybe (Bool, [HsImportSpec]) -> a) -> a + hiding is f = f (Just (True, is)) + + everything :: (Maybe (Bool, [HsImportSpec]) -> a) -> a + everything f = f Nothing + +haskellNS :: Module +haskellNS = Module "Hs" + +defaultMessageDeriving :: [HsQName] +defaultMessageDeriving = map haskellName [ "Show", "Eq", "Ord", "Generic", "NFData" ] + +defaultEnumDeriving :: [HsQName] +defaultEnumDeriving = map haskellName [ "Show", "Eq", "Generic", "NFData" ] + +defaultServiceDeriving :: [HsQName] +defaultServiceDeriving = map haskellName [ "Generic" ] + +-------------------------------------------------------------------------------- +-- +-- * Wrappers around haskell-src-exts constructors +-- + +apply :: HsExp -> [HsExp] -> HsExp +apply f = HsParen . foldl HsApp f + +applicativeApply :: HsExp -> [HsExp] -> HsExp +applicativeApply f = foldl snoc nil + where + nil = HsApp pureE f + + snoc g x = HsInfixApp g apOp x + +tyApp :: HsType -> [HsType] -> HsType +tyApp = foldl HsTyApp + +module_ :: Module -> Maybe [HsExportSpec] -> [HsImportDecl] -> [HsDecl] -> HsModule +module_ = HsModule l + +importDecl_ :: Module -> Bool -> Maybe Module -> Maybe (Bool, [HsImportSpec]) -> HsImportDecl +importDecl_ = HsImportDecl l + +dataDecl_ :: String -> [HsConDecl] -> [HsQName] -> HsDecl +dataDecl_ messageName = HsDataDecl l [] (HsIdent messageName) [] + +recDecl_ :: HsName -> [([HsName], HsBangType)] -> HsConDecl +recDecl_ = HsRecDecl l + +conDecl_ :: HsName -> [HsBangType] -> HsConDecl +conDecl_ = HsConDecl l + +instDecl_ :: HsQName -> [HsType] -> [HsDecl] -> HsDecl +instDecl_ = HsInstDecl l [] + +match_ :: HsName -> [HsPat] -> HsRhs -> [HsDecl] -> HsMatch +match_ = HsMatch l + +unqual_ :: String -> HsQName +unqual_ = UnQual . HsIdent + +uvar_ :: String -> HsExp +uvar_ = HsVar . unqual_ + +protobufType_, primType_ :: String -> HsType +protobufType_ = HsTyCon . protobufName +primType_ = HsTyCon . haskellName + +type_ :: String -> HsType +type_ = HsTyCon . unqual_ + +patVar :: String -> HsPat +patVar = HsPVar . HsIdent + +alt_ :: HsPat -> HsGuardedAlts -> [HsDecl] -> HsAlt +alt_ = HsAlt l + +str_ :: String -> HsExp +str_ = HsLit . HsString -- | For some reason, haskell-src-exts needs this 'SrcLoc' parameter -- for some data constructors. Its value does not affect diff --git a/src/Proto3/Suite/DotProto/Generate/Swagger.hs b/src/Proto3/Suite/DotProto/Generate/Swagger.hs --- a/src/Proto3/Suite/DotProto/Generate/Swagger.hs +++ b/src/Proto3/Suite/DotProto/Generate/Swagger.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-} @@ -17,7 +18,11 @@ ) where +#if MIN_VERSION_swagger2(2,4,0) +import Control.Lens ((&), (?~)) +#else import Control.Lens ((&), (.~), (?~)) +#endif import Data.Aeson (Value (String)) import Data.Aeson.Encode.Pretty (encodePretty) import Data.ByteString (ByteString) @@ -55,7 +60,11 @@ declareNamedSchema _ = return (NamedSchema Nothing schema_) where schema_ = mempty +#if MIN_VERSION_swagger2(2,4,0) + & type_ ?~ SwaggerArray +#else & type_ .~ SwaggerArray +#endif & items ?~ SwaggerItemsObject (Inline byteSchema) {-| This is a convenience function that uses type inference to select the @@ -66,7 +75,7 @@ -- | Pretty-prints a schema. Useful when playing around with schemas in the -- REPL. -ppSchema :: ToSchema a => proxy a -> IO () +ppSchema :: ToSchema a => Proxy a -> IO () ppSchema = LC8.putStrLn . encodePretty . toSchema -- | JSONPB schemas for protobuf enumerations @@ -77,7 +86,11 @@ let enumMemberNames = dropPrefix . fst <$> enumerate (proxy# :: Proxy# e) return $ NamedSchema (Just enumName) $ mempty +#if MIN_VERSION_swagger2(2,4,0) + & type_ ?~ SwaggerString +#else & type_ .~ SwaggerString +#endif & enum_ ?~ fmap String enumMemberNames instance ToSchema (Fixed Int32) where diff --git a/src/Proto3/Suite/DotProto/Internal.hs b/src/Proto3/Suite/DotProto/Internal.hs --- a/src/Proto3/Suite/DotProto/Internal.hs +++ b/src/Proto3/Suite/DotProto/Internal.hs @@ -1,31 +1,84 @@ -- | This module provides misc internal helpers and utilities +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} {-# LANGUAGE ViewPatterns #-} module Proto3.Suite.DotProto.Internal where +import Control.Applicative import qualified Control.Foldl as FL -import Control.Lens (over) +import Control.Lens (Lens', lens, over) import Control.Lens.Cons (_head) -import Data.Char (toUpper) +import Control.Monad +import Control.Monad.Except +import Data.Bifunctor (first) +import Data.Char +import Data.Coerce +import Data.Either +import Data.Foldable +import Data.Functor.Compose +import Data.Int (Int32) +import Data.List (find, intercalate) +import qualified Data.List.NonEmpty as NE +import qualified Data.Map as M import Data.Maybe (fromMaybe) +import Data.Semigroup (Semigroup(..)) import qualified Data.Text as T -import System.FilePath (isPathSeparator) -import qualified Filesystem.Path.CurrentOS as FP +import Data.Tuple (swap) import Filesystem.Path.CurrentOS (()) +import qualified Filesystem.Path.CurrentOS as FP import qualified NeatInterpolation as Neat import Prelude hiding (FilePath) -import Proto3.Suite.DotProto +import Proto3.Suite.DotProto.AST +import Proto3.Suite.DotProto.AST.Lens +import Proto3.Suite.DotProto.Parsing +import Proto3.Wire.Types (FieldNumber (..)) +import System.FilePath (isPathSeparator) import Text.Parsec (ParseError) +import qualified Turtle import Turtle (ExitCode (..), FilePath, MonadIO, Text) -import qualified Turtle import Turtle.Format ((%)) import qualified Turtle.Format as F +------------------------------------------------------------------------------- +-- +-- * Utilities +-- + +#if !(MIN_VERSION_mtl(2,2,2)) +liftEither :: MonadError e m => Either e a -> m a +liftEither = either throwError pure +#endif + +-- | Like 'foldMap', but with an effectful projection. +foldMapM :: + (Foldable t, Monad m, Monoid b, Semigroup b) => (a -> m b) -> t a -> m b +foldMapM f = foldM (\b a -> (b <>) <$> f a) mempty + +-- | Like 'Control.Lens.Getter.Getting', but allows for retrieving the 'r' +-- element in some Applicative context 'm'. +type GettingM r s a = forall m. Applicative m => (a -> Compose m (Const r) a) -> s -> Compose m (Const r) s + +-- | Given an effectful projection from 'a' into a monoid 'r', retrieve the sum +-- of all 'a' values in an 's' structure as targetted by the 'GettingM' optic. +-- Note that the Monoid constraint on 'r' is implicit via 'Const', but we +-- note it in the type for clarity. +foldMapOfM :: (Applicative m, Monoid r) => GettingM r s a -> (a -> m r) -> s -> m r +foldMapOfM l f = fmap getConst . getCompose . l (Compose . fmap Const . f) + +mapKeysM :: (Monad m, Ord k2) => (k1 -> m k2) -> M.Map k1 a -> m (M.Map k2 a) +mapKeysM f = fmap M.fromList . traverse (fmap swap . traverse f . swap) . M.assocs + -- $setup -- >>> :set -XOverloadedStrings @@ -34,6 +87,11 @@ mapM_ Turtle.err msg Turtle.exit (ExitFailure 1) +-------------------------------------------------------------------------------- +-- +-- * Reading files +-- + -- | toModulePath takes an include-relative path to a .proto file and produces a -- "module path" which is used during code generation. -- @@ -65,23 +123,23 @@ -- Left "path contained unexpected .. after canonicalization, please use form x.y.z.proto" -- -- >>> toModulePath "google/protobuf/timestamp.proto" --- Right (Path {components = ["Google","Protobuf","Timestamp"]}) +-- Right (Path {components = "Google" :| ["Protobuf","Timestamp"]}) -- -- >>> toModulePath "a/b/c/google.protobuf.timestamp.proto" --- Right (Path {components = ["A","B","C","Google","Protobuf","Timestamp"]}) +-- Right (Path {components = "A" :| ["B","C","Google","Protobuf","Timestamp"]}) -- -- >>> toModulePath "foo/FiLeName_underscore.and.then.some.dots.proto" --- Right (Path {components = ["Foo","FiLeName_underscore","And","Then","Some","Dots"]}) +-- Right (Path {components = "Foo" :| ["FiLeName_underscore","And","Then","Some","Dots"]}) -- -- >>> toModulePath "foo/bar/././baz/../boggle.proto" --- Right (Path {components = ["Foo","Bar","Boggle"]}) +-- Right (Path {components = "Foo" :| ["Bar","Boggle"]}) -- -- >>> toModulePath "./foo.proto" --- Right (Path {components = ["Foo"]}) +-- Right (Path {components = "Foo" :| []}) -- -- NB: We ignore preceding single '.' characters -- >>> toModulePath ".foo.proto" --- Right (Path {components = ["Foo"]}) +-- Right (Path {components = "Foo" :| []}) toModulePath :: FilePath -> Either String Path toModulePath fp0@(fromMaybe fp0 . FP.stripPrefix "./" -> fp) | Turtle.absolute fp @@ -92,11 +150,11 @@ = case FP.stripPrefix "../" fp of Just{} -> Left "expected include-relative path, but the path started with ../" Nothing - | T.isInfixOf ".." (Turtle.format F.fp . FP.collapse $ fp) + | T.isInfixOf ".." . Turtle.format F.fp . FP.collapse $ fp -> Left "path contained unexpected .. after canonicalization, please use form x.y.z.proto" | otherwise - -> Right - . Path + -> maybe (Left "empty path after canonicalization") (Right . Path) + . NE.nonEmpty . dropWhile null -- Remove a potential preceding empty component which -- arose from a preceding '.' in the input path, which we -- want to ignore. E.g. ".foo.proto" => ["","Foo"]. @@ -108,27 +166,55 @@ . Turtle.dropExtension $ fp -fatalBadModulePath :: MonadIO m => FilePath -> String -> m a -fatalBadModulePath (Turtle.format F.fp -> fp) (T.pack -> rsn) = - dieLines [Neat.text| - Error: failed when computing the "module path" for "${fp}": ${rsn} - - Please ensure that the provided path to a .proto file is specified as - relative to some --includeDir path and that it has the .proto suffix. - |] - -- | @importProto searchPaths toplevel inc@ attempts to import include-relative -- @inc@ after locating it somewhere in the @searchPaths@; @toplevel@ is simply -- the path of toplevel .proto being processed so we can report it in an error -- message. This function terminates the program if it cannot find the file to -- import or if it cannot construct a valid module path from it. -importProto :: MonadIO m - => [FilePath] -> FilePath -> FilePath -> m (Either ParseError DotProto) -importProto paths (Turtle.format F.fp -> toplevelProtoText) protoFP = +importProto :: (MonadIO m, MonadError CompileError m) + => [FilePath] -> FilePath -> FilePath -> m DotProto +importProto paths toplevelProto protoFP = findProto paths protoFP >>= \case - Found mp fp -> parseProtoFile mp fp - BadModulePath e -> fatalBadModulePath protoFP e - NotFound -> dieLines [Neat.text| + Left e + -> dieLines (badModulePathErrorMsg protoFP e) + Right Nothing + | toplevelProto == protoFP + -> dieLines (toplevelNotFoundErrorMsg paths toplevelProto) + | otherwise + -> dieLines (importNotFoundErrorMsg paths toplevelProto protoFP) + Right (Just (mp, fp)) + -> liftEither . first CompileParseError =<< parseProtoFile mp fp + +type FindProtoResult = Either String (Maybe (Path, FilePath)) + +-- | Attempts to locate the first (if any) filename that exists on the given +-- search paths, and constructs the "module path" from the given +-- include-relative filename (2nd parameter). Terminates the program with an +-- error if the given pathname is not relative. +findProto :: MonadIO m => [FilePath] -> FilePath -> m FindProtoResult +findProto searchPaths protoFP + | Turtle.absolute protoFP = dieLines absolutePathErrorMsg + | otherwise = forM (toModulePath protoFP) $ \mp -> + flip Turtle.fold FL.head $ do + sp <- Turtle.select searchPaths + let fp = sp protoFP + True <- Turtle.testfile fp + pure (mp, fp) + +-- * Pretty Error Messages + +badModulePathErrorMsg :: FilePath -> String -> T.Text +badModulePathErrorMsg (Turtle.format F.fp -> fp) (T.pack -> rsn) = + [Neat.text| + Error: failed when computing the "module path" for "${fp}": ${rsn} + + Please ensure that the provided path to a .proto file is specified as + relative to some --includeDir path and that it has the .proto suffix. + |] + +importNotFoundErrorMsg :: [FilePath] -> FilePath -> FilePath -> T.Text +importNotFoundErrorMsg paths toplevelProto protoFP = + [Neat.text| Error: while processing include statements in "${toplevelProtoText}", failed to find the imported file "${protoFPText}", after looking in the following locations (controlled via the --includeDir switch(es)): @@ -136,39 +222,340 @@ $pathsText |] where - pathsText = T.unlines (Turtle.format (" "%F.fp) . ( protoFP) <$> paths) + pathsText = T.unlines (Turtle.format (" "%F.fp) . ( protoFP) <$> paths) + toplevelProtoText = Turtle.format F.fp toplevelProto protoFPText = Turtle.format F.fp protoFP -data FindProtoResult - = Found Path FilePath - | NotFound - | BadModulePath String - deriving (Eq, Show) +toplevelNotFoundErrorMsg :: [FilePath] -> FilePath -> T.Text +toplevelNotFoundErrorMsg searchPaths toplevelProto = + [Neat.text| + Error: failed to find file "${toplevelProtoText}", after looking in + the following locations (controlled via the --includeDir switch(es)): --- | Attempts to locate the first (if any) filename that exists on the given --- search paths, and constructs the "module path" from the given --- include-relative filename (2nd parameter). Terminates the program with an --- error if the given pathname is not relative. -findProto :: MonadIO m => [FilePath] -> FilePath -> m FindProtoResult -findProto searchPaths protoFP - | Turtle.absolute protoFP = dieLines [Neat.text| - Error: Absolute paths to .proto files, whether on the command line or - in include directives, are not currently permitted; rather, all .proto - filenames must be relative to the current directory, or relative to some - search path specified via --includeDir. + $searchPathsText + |] + where + searchPathsText = T.unlines (Turtle.format (" "%F.fp) . ( toplevelProto) <$> searchPaths) + toplevelProtoText = Turtle.format F.fp toplevelProto - This is because we currently use the include-relative name to decide - the structure of the Haskell module tree that we emit during code - generation. - |] - | otherwise = case toModulePath protoFP of - Left e -> pure (BadModulePath e) - Right mp -> do - mfp <- flip Turtle.fold FL.head $ do - sp <- Turtle.select searchPaths - let fp = sp protoFP - True <- Turtle.testfile fp - pure fp - case mfp of - Nothing -> pure NotFound - Just fp -> pure (Found mp fp) +absolutePathErrorMsg :: T.Text +absolutePathErrorMsg = + [Neat.text| + Error: Absolute paths to .proto files, whether on the command line or + in include directives, are not currently permitted; rather, all .proto + filenames must be relative to the current directory, or relative to some + search path specified via --includeDir. + + This is because we currently use the include-relative name to decide + the structure of the Haskell module tree that we emit during code + generation. + |] + +-------------------------------------------------------------------------------- +-- +-- * Type context +-- + +-- | A mapping from .proto type identifiers to their type information +type TypeContext = M.Map DotProtoIdentifier DotProtoTypeInfo + +-- | Information about messages and enumerations +data DotProtoTypeInfo = DotProtoTypeInfo + { dotProtoTypeInfoPackage :: DotProtoPackageSpec + -- ^ The package this type is defined in + , dotProtoTypeInfoParent :: DotProtoIdentifier + -- ^ The message this type is nested under, or 'Anonymous' if it's top-level + , dotProtoTypeChildContext :: TypeContext + -- ^ The context that should be used for declarations within the + -- scope of this type + , dotProtoTypeInfoKind :: DotProtoKind + -- ^ Whether this type is an enumeration or message + , dotProtoTypeInfoModulePath :: Path + -- ^ The include-relative module path used when importing this module + } deriving Show + +tiParent :: Lens' DotProtoTypeInfo DotProtoIdentifier +tiParent = lens dotProtoTypeInfoParent (\d p -> d{ dotProtoTypeInfoParent = p }) + +-- | Whether a definition is an enumeration or a message +data DotProtoKind = DotProtoKindEnum + | DotProtoKindMessage + deriving (Show, Eq, Ord, Enum, Bounded) + +-- ** Generating type contexts from ASTs + +dotProtoTypeContext :: MonadError CompileError m => DotProto -> m TypeContext +dotProtoTypeContext DotProto{..} = + foldMapM (definitionTypeContext (metaModulePath protoMeta)) protoDefinitions + +definitionTypeContext :: MonadError CompileError m + => Path -> DotProtoDefinition -> m TypeContext +definitionTypeContext modulePath (DotProtoMessage _ msgIdent parts) = do + let updateParent = tiParent (concatDotProtoIdentifier msgIdent) + + childTyContext <- foldMapOfM (traverse . _DotProtoMessageDefinition) + (definitionTypeContext modulePath >=> traverse updateParent) + parts + + qualifiedChildTyContext <- mapKeysM (concatDotProtoIdentifier msgIdent) childTyContext + + let tyInfo = DotProtoTypeInfo { dotProtoTypeInfoPackage = DotProtoNoPackage + , dotProtoTypeInfoParent = Anonymous + , dotProtoTypeChildContext = childTyContext + , dotProtoTypeInfoKind = DotProtoKindMessage + , dotProtoTypeInfoModulePath = modulePath + } + + pure $ M.singleton msgIdent tyInfo <> qualifiedChildTyContext + +definitionTypeContext modulePath (DotProtoEnum _ enumIdent _) = do + let tyInfo = DotProtoTypeInfo { dotProtoTypeInfoPackage = DotProtoNoPackage + , dotProtoTypeInfoParent = Anonymous + , dotProtoTypeChildContext = mempty + , dotProtoTypeInfoKind = DotProtoKindEnum + , dotProtoTypeInfoModulePath = modulePath + } + pure (M.singleton enumIdent tyInfo) + +definitionTypeContext _ _ = pure mempty + + +isMessage :: TypeContext -> DotProtoIdentifier -> Bool +isMessage ctxt n = Just DotProtoKindMessage == (dotProtoTypeInfoKind <$> M.lookup n ctxt) + +isPacked :: [DotProtoOption] -> Bool +isPacked opts = + case find (\(DotProtoOption name _) -> name == Single "packed") opts of + Just (DotProtoOption _ (BoolLit x)) -> x + _ -> False + +isUnpacked :: [DotProtoOption] -> Bool +isUnpacked opts = + case find (\(DotProtoOption name _) -> name == Single "packed") opts of + Just (DotProtoOption _ (BoolLit x)) -> not x + _ -> False + +-- | Returns 'True' if the given primitive type is packable. The 'TypeContext' +-- is used to distinguish Named enums and messages, only the former of which are +-- packable. +isPackable :: TypeContext -> DotProtoPrimType -> Bool +isPackable _ Bytes = False +isPackable _ String = False +isPackable _ Int32 = True +isPackable _ Int64 = True +isPackable _ SInt32 = True +isPackable _ SInt64 = True +isPackable _ UInt32 = True +isPackable _ UInt64 = True +isPackable _ Fixed32 = True +isPackable _ Fixed64 = True +isPackable _ SFixed32 = True +isPackable _ SFixed64 = True +isPackable _ Bool = True +isPackable _ Float = True +isPackable _ Double = True +isPackable ctxt (Named tyName) = + Just DotProtoKindEnum == (dotProtoTypeInfoKind <$> M.lookup tyName ctxt) + +isMap :: DotProtoType -> Bool +isMap Map{} = True +isMap _ = False + +-------------------------------------------------------------------------------- +-- +-- * Name resolution +-- + +concatDotProtoIdentifier :: MonadError CompileError m + => DotProtoIdentifier -> DotProtoIdentifier -> m DotProtoIdentifier +concatDotProtoIdentifier i1 i2 = case (i1, i2) of + (Qualified{} , _ ) -> internalError "concatDotProtoIdentifier: Qualified" + (_ , Qualified{} ) -> internalError "concatDotProtoIdentifier Qualified" + (Anonymous , Anonymous ) -> pure Anonymous + (Anonymous , b ) -> pure b + (a , Anonymous ) -> pure a + (Single a , b ) -> concatDotProtoIdentifier (Dots (Path (pure a))) b + (a , Single b ) -> concatDotProtoIdentifier a (Dots (Path (pure b))) + (Dots (Path a), Dots (Path b)) -> pure (Dots (Path (a <> b))) + +camelCased :: String -> String +camelCased s = do + (prev, cur) <- zip (Nothing:map Just s) (map Just s ++ [Nothing]) + case (prev, cur) of + (Just '_', Just x) + | isAlpha x -> pure (toUpper x) + (Just '_', Nothing) -> pure '_' + (Just '_', Just '_') -> pure '_' + (_, Just '_') -> empty + (_, Just x) -> pure x + (_, _) -> empty + +typeLikeName :: MonadError CompileError m => String -> m String +typeLikeName ident@(c:cs) + | isUpper c = pure (camelCased ident) + | isLower c = pure (camelCased (toUpper c : cs)) + | '_' == c = pure (camelCased ('X':ident)) +typeLikeName ident = invalidTypeNameError ident + +fieldLikeName :: String -> String +fieldLikeName ident@(c:_) + | isUpper c = let (prefix, suffix) = span isUpper ident + in map toLower prefix ++ suffix +fieldLikeName ident = ident + +prefixedEnumFieldName :: String -> String -> String +prefixedEnumFieldName enumName fieldName = enumName <> fieldName + +prefixedConName :: MonadError CompileError m => String -> String -> m String +prefixedConName msgName conName = (msgName ++) <$> typeLikeName conName + +-- TODO: This should be ~:: MessageName -> FieldName -> ...; same elsewhere, the +-- String types are a bit of a hassle. +prefixedFieldName :: MonadError CompileError m => String -> String -> m String +prefixedFieldName msgName fieldName = (fieldLikeName msgName ++) <$> typeLikeName fieldName + +dpIdentUnqualName :: MonadError CompileError m => DotProtoIdentifier -> m String +dpIdentUnqualName (Single name) = pure name +dpIdentUnqualName (Dots (Path names)) = pure (NE.last names) +dpIdentUnqualName (Qualified _ next) = dpIdentUnqualName next +dpIdentUnqualName Anonymous = internalError "dpIdentUnqualName: Anonymous" + +dpIdentQualName :: MonadError CompileError m => DotProtoIdentifier -> m String +dpIdentQualName (Single name) = pure name +dpIdentQualName (Dots (Path names)) = pure (intercalate "." (NE.toList names)) +dpIdentQualName (Qualified _ _) = internalError "dpIdentQualName: Qualified" +dpIdentQualName Anonymous = internalError "dpIdentQualName: Anonymous" + +-- | Given a 'DotProtoIdentifier' for the parent type and the unqualified name +-- of this type, generate the corresponding Haskell name +nestedTypeName :: MonadError CompileError m => DotProtoIdentifier -> String -> m String +nestedTypeName Anonymous nm = typeLikeName nm +nestedTypeName (Single parent) nm = intercalate "_" <$> traverse typeLikeName [parent, nm] +nestedTypeName (Dots (Path parents)) nm = intercalate "_" . (<> [nm]) <$> traverse typeLikeName (NE.toList parents) +nestedTypeName (Qualified {}) _ = internalError "nestedTypeName: Qualified" + +qualifiedMessageName :: MonadError CompileError m => DotProtoIdentifier -> DotProtoIdentifier -> m String +qualifiedMessageName parentIdent msgIdent = nestedTypeName parentIdent =<< dpIdentUnqualName msgIdent + +-------------------------------------------------------------------------------- +-- +-- ** Codegen bookkeeping helpers +-- + +-- | Bookeeping for qualified fields +data QualifiedField = QualifiedField + { recordFieldName :: FieldName + , fieldInfo :: FieldInfo + } deriving Show + +-- | Bookkeeping for fields +data FieldInfo + = FieldOneOf OneofField + | FieldNormal FieldName FieldNumber DotProtoType [DotProtoOption] + deriving Show + +-- | Bookkeeping for oneof fields +data OneofField = OneofField + { oneofType :: String + , subfields :: [OneofSubfield] + } deriving Show + +-- | Bookkeeping for oneof subfields +data OneofSubfield = OneofSubfield + { subfieldNumber :: FieldNumber + , subfieldConsName :: String + , subfieldName :: FieldName + , subfieldType :: DotProtoType + , subfieldOptions :: [DotProtoOption] + } deriving Show + +getQualifiedFields :: MonadError CompileError m + => String -> [DotProtoMessagePart] -> m [QualifiedField] +getQualifiedFields msgName msgParts = flip foldMapM msgParts $ \case + DotProtoMessageField DotProtoField{..} -> do + fieldName <- dpIdentUnqualName dotProtoFieldName + qualName <- prefixedFieldName msgName fieldName + pure . (:[]) $ QualifiedField { recordFieldName = coerce qualName + , fieldInfo = FieldNormal (coerce fieldName) + dotProtoFieldNumber + dotProtoFieldType + dotProtoFieldOptions + } + + DotProtoMessageOneOf _ [] -> + throwError (InternalError "getQualifiedFields: encountered oneof with no oneof fields") + + DotProtoMessageOneOf oneofIdent fields -> do + ident <- dpIdentUnqualName oneofIdent + oneofName <- prefixedFieldName msgName ident + oneofTypeName <- prefixedConName msgName ident + + let mkSubfield DotProtoField{..} = do + s <- dpIdentUnqualName dotProtoFieldName + c <- prefixedConName oneofTypeName s + pure [OneofSubfield dotProtoFieldNumber c (coerce s) dotProtoFieldType dotProtoFieldOptions] + mkSubfield DotProtoEmptyField = pure [] + + fieldElems <- foldMapM mkSubfield fields + + pure . (:[]) $ QualifiedField { recordFieldName = coerce oneofName + , fieldInfo = FieldOneOf (OneofField ident fieldElems) + } + _ -> pure [] + +-- | Project qualified fields, given a projection function per field type. +foldQF :: (FieldName -> FieldNumber -> a) -- ^ projection for normal fields + -> (OneofField -> a) -- ^ projection for oneof fields + -> QualifiedField + -> a +foldQF f _ (QualifiedField _ (FieldNormal fldName fldNum _ _)) = f fldName fldNum +foldQF _ g (QualifiedField _ (FieldOneOf fld)) = g fld + +fieldBinder :: FieldNumber -> String +fieldBinder = ("f" ++) . show + +oneofSubBinder :: OneofSubfield -> String +oneofSubBinder = fieldBinder . subfieldNumber + +oneofSubDisjunctBinder :: [OneofSubfield] -> String +oneofSubDisjunctBinder = intercalate "_or_" . fmap oneofSubBinder + +-------------------------------------------------------------------------------- +-- +-- * Errors +-- + +data CompileError + = CircularImport FilePath + | CompileParseError ParseError + | InternalError String + | InvalidPackageName DotProtoIdentifier + | InvalidMethodName DotProtoIdentifier + | InvalidTypeName String + | InvalidMapKeyType String + | NoPackageDeclaration + | NoSuchType DotProtoIdentifier + | NonzeroFirstEnumeration String DotProtoIdentifier Int32 + | EmptyEnumeration String + | Unimplemented String + deriving (Show, Eq) + + +internalError :: MonadError CompileError m => String -> m a +internalError = throwError . InternalError + +invalidTypeNameError :: MonadError CompileError m => String -> m a +invalidTypeNameError = throwError . InvalidTypeName + +_unimplementedError :: MonadError CompileError m => String -> m a +_unimplementedError = throwError . Unimplemented + +invalidMethodNameError :: MonadError CompileError m => DotProtoIdentifier -> m a +invalidMethodNameError = throwError . InvalidMethodName + +noSuchTypeError :: MonadError CompileError m => DotProtoIdentifier -> m a +noSuchTypeError = throwError . NoSuchType + +protoPackageName :: MonadError CompileError m => DotProtoPackageSpec -> m DotProtoIdentifier +protoPackageName (DotProtoPackageSpec name) = pure name +protoPackageName DotProtoNoPackage = throwError NoPackageDeclaration diff --git a/src/Proto3/Suite/DotProto/Parsing.hs b/src/Proto3/Suite/DotProto/Parsing.hs --- a/src/Proto3/Suite/DotProto/Parsing.hs +++ b/src/Proto3/Suite/DotProto/Parsing.hs @@ -1,9 +1,12 @@ -- | 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 #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -fno-warn-unused-do-bind #-} module Proto3.Suite.DotProto.Parsing @@ -13,6 +16,7 @@ import Control.Applicative hiding (empty) import Control.Monad +import qualified Data.List.NonEmpty as NE import Data.Functor import qualified Data.Text as T import qualified Filesystem.Path.CurrentOS as FP @@ -34,16 +38,19 @@ -- 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)) "" +parseProto modulePath = parseProtoWithFile modulePath "" +parseProtoWithFile :: Path -> String -> String -> Either ParseError DotProto +parseProtoWithFile modulePath filePath = parse (runProtoParser (topLevel modulePath)) filePath + -- | @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 +parseProtoFile modulePath (FP.encodeString -> fp) = + parseProtoWithFile modulePath fp <$> Turtle.liftIO (readFile fp) ---------------------------------------- -- convenience @@ -54,9 +61,9 @@ , Parsing, CharParsing, LookAheadParsing) instance TokenParsing ProtoParser where - someSpace = TokenStyle.buildSomeSpaceParser - (ProtoParser someSpace) - TokenStyle.javaCommentStyle + someSpace = TokenStyle.buildSomeSpaceParser + (ProtoParser someSpace) + TokenStyle.javaCommentStyle -- use the default implementation for other methods: -- nesting, semi, highlight, token @@ -76,10 +83,10 @@ -- 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) +_identifier = identifierName `sepBy1` string "." >>= \case + [] -> fail "impossible" + [i] -> pure (Single i) + (i:is) -> pure (Dots (Path (i NE.:| is))) singleIdentifier :: ProtoParser DotProtoIdentifier singleIdentifier = Single <$> token identifierName @@ -232,9 +239,9 @@ -- service statements servicePart :: ProtoParser DotProtoServicePart -servicePart = rpc - <|> (DotProtoServiceOption <$> topOption) - <|> empty $> DotProtoServiceEmpty +servicePart = DotProtoServiceRPCMethod <$> rpc + <|> DotProtoServiceOption <$> topOption + <|> DotProtoServiceEmpty <$ empty rpcOptions :: ProtoParser [DotProtoOption] rpcOptions = braces $ many topOption @@ -245,20 +252,20 @@ -- NB: Distinguish "stream stream.foo" from "stream.foo" try (symbol "stream" *> sid Streaming) <|> sid NonStreaming -rpc :: ProtoParser DotProtoServicePart +rpc :: ProtoParser RPCMethod rpc = do symbol "rpc" - name <- singleIdentifier - subjecttype <- parens rpcClause + rpcMethodName <- singleIdentifier + (rpcMethodRequestType, rpcMethodRequestStreaming) <- parens rpcClause symbol "returns" - returntype <- parens rpcClause - options <- rpcOptions <|> (semi $> []) - return $ DotProtoServiceRPC name subjecttype returntype options + (rpcMethodResponseType, rpcMethodResponseStreaming) <- parens rpcClause + rpcMethodOptions <- rpcOptions <|> (semi $> []) + return RPCMethod{..} service :: ProtoParser DotProtoDefinition service = do symbol "service" name <- singleIdentifier statements <- braces (many servicePart) - return $ DotProtoService name statements + return $ DotProtoService mempty name statements -------------------------------------------------------------------------------- -- message definitions @@ -267,7 +274,7 @@ message = do symbol "message" name <- singleIdentifier body <- braces (many messagePart) - return $ DotProtoMessage name body + return $ DotProtoMessage mempty name body messageOneOf :: ProtoParser DotProtoMessagePart messageOneOf = do symbol "oneof" @@ -299,7 +306,7 @@ mnumber <- fieldNumber moptions <- optionAnnotation semi - return $ DotProtoField mnumber mtype mname moptions Nothing + return $ DotProtoField mnumber mtype mname moptions mempty -------------------------------------------------------------------------------- -- enumerations @@ -322,7 +329,7 @@ enum = do symbol "enum" ename <- singleIdentifier ebody <- braces (many enumStatement) - return $ DotProtoEnum ename ebody + return $ DotProtoEnum mempty ename ebody -------------------------------------------------------------------------------- -- field reservations diff --git a/src/Proto3/Suite/DotProto/Rendering.hs b/src/Proto3/Suite/DotProto/Rendering.hs --- a/src/Proto3/Suite/DotProto/Rendering.hs +++ b/src/Proto3/Suite/DotProto/Rendering.hs @@ -20,6 +20,7 @@ ) where import Data.Char +import qualified Data.List.NonEmpty as NE import qualified Data.Text as T import Filesystem.Path.CurrentOS (toText) #if (MIN_VERSION_base(4,11,0)) @@ -97,19 +98,28 @@ instance Pretty DotProtoOption where pPrint (DotProtoOption key value) = pPrint key <+> PP.text "=" <+> pPrint value +renderComment :: String -> PP.Doc +renderComment = PP.vcat . map ((PP.text "//" <+>) . textIfNonempty) . lines + where + textIfNonempty [] = PP.empty + textIfNonempty text = PP.text text + +-- 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. +vbraces :: PP.Doc -> PP.Doc -> PP.Doc +vbraces header body = header <+> PP.char '{' $$ PP.nest 2 body $$ PP.char '}' + 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 "{" <+>) + defn (DotProtoMessage comment name parts) = renderComment comment $$ + vbraces (PP.text "message" <+> pPrint name) (PP.vcat $ msgPart name <$> parts) + defn (DotProtoEnum comment name parts) = renderComment comment $$ + vbraces (PP.text "enum" <+> pPrint name) (PP.vcat $ enumPart name <$> parts) + defn (DotProtoService comment name parts) = renderComment comment $$ + vbraces (PP.text "service" <+> pPrint name) (PP.vcat $ pPrint <$> parts) msgPart :: DotProtoIdentifier -> DotProtoMessagePart -> PP.Doc msgPart msgName (DotProtoMessageField f) = field msgName f @@ -118,7 +128,7 @@ = 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) + msgPart msgName (DotProtoMessageOneOf name fields) = vbraces (PP.text "oneof" <+> pPrint name) (PP.vcat $ field msgName <$> fields) field :: DotProtoIdentifier -> DotProtoField -> PP.Doc field msgName (DotProtoField number mtype name options comments) @@ -128,14 +138,14 @@ <+> pPrint number <+> optionAnnotation options <> PP.text ";" - <> maybe PP.empty (PP.text . (" // " ++)) comments + $$ PP.nest 2 (renderComment comments) field _ DotProtoEmptyField = PP.empty enumPart :: DotProtoIdentifier -> DotProtoEnumPart -> PP.Doc enumPart msgName (DotProtoEnumField name value options) = roEnumMemberName opts msgName name <+> PP.text "=" - <+> pPrint value + <+> pPrint (fromIntegral value :: Int) <+> optionAnnotation options <> PP.text ";" enumPart _ (DotProtoEnumOption opt) @@ -144,15 +154,15 @@ = PP.empty instance Pretty DotProtoServicePart where - pPrint (DotProtoServiceRPC name (callname, callstrm) (retname, retstrm) options) + pPrint (DotProtoServiceRPCMethod RPCMethod{..}) = PP.text "rpc" - <+> pPrint name - <+> PP.parens (pPrint callstrm <+> pPrint callname) + <+> pPrint rpcMethodName + <+> PP.parens (pPrint rpcMethodRequestStreaming <+> pPrint rpcMethodRequestType) <+> PP.text "returns" - <+> PP.parens (pPrint retstrm <+> pPrint retname) - <+> case options of + <+> PP.parens (pPrint rpcMethodResponseStreaming <+> pPrint rpcMethodResponseType) + <+> case rpcMethodOptions of [] -> PP.text ";" - _ -> PP.braces . PP.vcat $ topOption <$> options + _ -> PP.braces . PP.vcat $ topOption <$> rpcMethodOptions pPrint (DotProtoServiceOption option) = topOption option pPrint DotProtoServiceEmpty = PP.empty @@ -162,7 +172,7 @@ instance Pretty DotProtoIdentifier where pPrint (Single name) = PP.text name - pPrint (Dots (Path names)) = PP.hcat . PP.punctuate (PP.text ".") $ PP.text <$> names + pPrint (Dots (Path names)) = PP.hcat . PP.punctuate (PP.text ".") $ PP.text <$> NE.toList names pPrint (Qualified qualifier identifier) = PP.parens (pPrint qualifier) <> PP.text "." <> pPrint identifier pPrint Anonymous = PP.empty @@ -218,4 +228,4 @@ packageFromDefs :: String -> [DotProtoDefinition] -> DotProto packageFromDefs package defs = - DotProto [] [] (DotProtoPackageSpec $ Single package) defs (DotProtoMeta $ Path []) + DotProto [] [] (DotProtoPackageSpec $ Single package) defs (DotProtoMeta fakePath) diff --git a/src/Proto3/Suite/JSONPB/Class.hs b/src/Proto3/Suite/JSONPB/Class.hs --- a/src/Proto3/Suite/JSONPB/Class.hs +++ b/src/Proto3/Suite/JSONPB/Class.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedLists #-} {-# LANGUAGE RecordWildCards #-} @@ -92,11 +93,14 @@ import qualified Data.Text.Lazy.Encoding as TL import qualified Data.Vector as V import GHC.Exts (Proxy#, proxy#) +import GHC.Generics (Generic) 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 (..)) +import Proto3.Wire.Class (ProtoEnum(..)) +import Test.QuickCheck.Arbitrary (Arbitrary(..)) -- * Typeclass definitions @@ -223,8 +227,11 @@ -- -- > MyMessage (Animal (Cat "Simba")) => { "animal": { "cat": "Simba" } } -- - } deriving Show + } deriving (Eq, Generic, Show) +instance Arbitrary Options where + arbitrary = Options <$> arbitrary <*> arbitrary + -- | Default options for JSON encoding. By default, all options are @True@. defaultOptions :: Options defaultOptions = Options @@ -477,7 +484,7 @@ toJSONPB = enumToJSONPB toJSONPB A.Null toEncodingPB = enumToJSONPB toEncodingPB E.null_ -instance (Bounded e, Enum e, FromJSONPB e) => FromJSONPB (Enumerated e) where +instance (ProtoEnum 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 diff --git a/src/Proto3/Suite/Tutorial.hs b/src/Proto3/Suite/Tutorial.hs --- a/src/Proto3/Suite/Tutorial.hs +++ b/src/Proto3/Suite/Tutorial.hs @@ -33,12 +33,13 @@ 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 +import Proto3.Suite (Enumerated, Nested, NestedVec, PackedVec, + Message, Named, Finite, DotProtoDefinition, + enum, message, packageFromDefs, toProtoFileDef) +import Proto3.Wire.Class (ProtoEnum) -- | -- == Defining Message Types @@ -92,20 +93,20 @@ -- | -- == 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: +-- Enumerated types can be used by deriving the 'Bounded', 'Enum', 'ProtoEnum', +-- '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) +-- > deriving (Bounded, Eq, Enum, Finite, Generic, Named, Ord, ProtoEnum) data Shape = Circle | Square | Triangle - deriving (Bounded, Eq, Enum, Finite, Generic, Named, Ord) + deriving (Bounded, Eq, Enum, Finite, Generic, Named, Ord, ProtoEnum) -- | -- == Generating a .proto file diff --git a/src/Proto3/Suite/Types.hs b/src/Proto3/Suite/Types.hs --- a/src/Proto3/Suite/Types.hs +++ b/src/Proto3/Suite/Types.hs @@ -31,9 +31,11 @@ import Control.DeepSeq (NFData) import GHC.Exts (IsList(..)) import GHC.Generics +import Data.Int (Int32) import Data.Semigroup (Semigroup) import qualified Data.Vector as V import GHC.TypeLits (Symbol) +import Proto3.Wire.Class (ProtoEnum(..)) import Test.QuickCheck (Arbitrary(..)) -- | 'Fixed' provides a way to encode integers in the fixed-width wire formats. @@ -48,16 +50,14 @@ -- | 'Enumerated' lifts any type with an 'IsEnum' instance so that it can be encoded -- with 'HasEncoding'. -newtype Enumerated a = Enumerated { enumerated :: Either Int a } +newtype Enumerated a = Enumerated { enumerated :: Either Int32 a } deriving (Show, Eq, Ord, Generic, NFData , Functor, Foldable, Traversable) -instance (Bounded a, Enum a) => Arbitrary (Enumerated a) where +instance ProtoEnum 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) + return . Enumerated $ maybe (Left i) Right (toProtoEnumMay i) -- | 'PackedVec' provides a way to encode packed lists of basic protobuf types into -- the wire format. diff --git a/tests/ArbitraryGeneratedTestTypes.hs b/tests/ArbitraryGeneratedTestTypes.hs --- a/tests/ArbitraryGeneratedTestTypes.hs +++ b/tests/ArbitraryGeneratedTestTypes.hs @@ -5,9 +5,9 @@ import qualified Data.Text.Lazy as T import qualified Data.Vector as V import qualified Proto3.Suite.Types as DotProto -import Test.QuickCheck (Arbitrary, arbitrary, - arbitraryBoundedEnum, listOf) +import Test.QuickCheck (Arbitrary, arbitrary, listOf) import qualified Test.QuickCheck as QC +import Test.QuickCheck.Arbitrary.Generic (genericArbitrary) import TestProto import qualified TestProtoImport import qualified TestProtoOneof @@ -27,7 +27,7 @@ <*> arbitrary instance Arbitrary WithEnum_TestEnum where - arbitrary = arbitraryBoundedEnum + arbitrary = genericArbitrary instance Arbitrary WithEnum where arbitrary = WithEnum <$> arbitrary @@ -59,7 +59,7 @@ <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbEnums <*> arbEnums where - arbEnums = V.fromList <$> listOf (DotProto.Enumerated . Right <$> arbitraryBoundedEnum) + arbEnums = V.fromList <$> listOf (DotProto.Enumerated . Right <$> genericArbitrary) instance Arbitrary SignedInts where arbitrary = SignedInts <$> arbitrary <*> arbitrary @@ -130,7 +130,7 @@ , TestProtoOneof.SomethingPickOneDummyMsg1 <$> arbitrary , TestProtoOneof.SomethingPickOneDummyMsg2 <$> arbitrary , TestProtoOneof.SomethingPickOneDummyEnum . DotProto.Enumerated . Right - <$> arbitraryBoundedEnum + <$> genericArbitrary ] instance Arbitrary TestProtoOneof.WithImported where diff --git a/tests/Main.hs b/tests/Main.hs --- a/tests/Main.hs +++ b/tests/Main.hs @@ -13,6 +13,7 @@ import qualified Data.ByteString.Char8 as BC import qualified Data.ByteString.Lazy as BL import Data.Either (isRight) +import qualified Data.List.NonEmpty as NE import Data.String import Data.Semigroup ((<>)) import GHC.Exts (fromList, Proxy#) @@ -50,7 +51,6 @@ #ifdef DHALL , dhallTests #endif - ] -------------------------------------------------------------------------------- @@ -223,7 +223,8 @@ testDotProtoParse :: FilePath -> DotProto -> Assertion testDotProtoParse file ast = do contents <- readFile file - case parseProto (Path []) contents of + let path = metaModulePath $ protoMeta ast + case parseProto path contents of Left err -> error $ show err Right result -> ast @=? result @@ -232,7 +233,8 @@ testDotProtoRoundtrip :: DotProto -> Assertion testDotProtoRoundtrip ast = - Right ast @=? parseProto (Path []) (toProtoFileDef ast) + let path = metaModulePath $ protoMeta ast in + Right ast @=? parseProto path (toProtoFileDef ast) dotProtoUnitTests :: TestTree dotProtoUnitTests = testGroup ".proto parsing tests" @@ -244,7 +246,7 @@ ] trivialDotProto :: DotProto -trivialDotProto = DotProto [] [] DotProtoNoPackage [] (DotProtoMeta (Path [])) +trivialDotProto = DotProto [] [] DotProtoNoPackage [] (DotProtoMeta (Path $ "test-files" NE.:| ["trivial"])) dotProtoParseTrivial :: TestTree dotProtoParseTrivial = testCase @@ -263,12 +265,12 @@ dotProtoSimpleMessage :: DotProto dotProtoSimpleMessage = DotProto [] [] DotProtoNoPackage - [ DotProtoMessage (Single "MessageTest") + [ DotProtoMessage "" (Single "MessageTest") [ DotProtoMessageField $ - DotProtoField (fieldNumber 1) (Prim Int32) (Single "testfield") [] Nothing + DotProtoField (fieldNumber 1) (Prim Int32) (Single "testfield") [] "" ] ] - (DotProtoMeta (Path [])) + (DotProtoMeta (Path ("test-files" NE.:| ["simple"]))) dotProtoRoundtripSimpleMessage :: TestTree dotProtoRoundtripSimpleMessage = testCase @@ -281,7 +283,7 @@ where roundtrip :: DotProto -> Property roundtrip ast = let generated = toProtoFileDef ast - in case parseProto (Path []) generated of + in case parseProto fakePath generated of Left err -> error $ formatParseError err generated Right result -> counterexample (formatMismatch ast generated result ) (ast == result) @@ -304,9 +306,10 @@ dotProtoFor :: (Named a, Message a) => Proxy# a -> DotProto dotProtoFor proxy = DotProto [] [] DotProtoNoPackage - [ DotProtoMessage (Single (nameOf proxy)) (DotProtoMessageField <$> dotProto proxy) + [ DotProtoMessage + "" (Single (nameOf proxy)) (DotProtoMessageField <$> dotProto proxy) ] - (DotProtoMeta (Path [])) + (DotProtoMeta (Path $ "mypath" NE.:| [])) showDotProtoFor :: (Named a, Message a) => Proxy# a -> IO () showDotProtoFor proxy = putStrLn . toProtoFileDef $ dotProtoFor proxy diff --git a/tests/TestCodeGen.hs b/tests/TestCodeGen.hs --- a/tests/TestCodeGen.hs +++ b/tests/TestCodeGen.hs @@ -9,6 +9,7 @@ import ArbitraryGeneratedTestTypes () import Control.Applicative import Control.Monad +import Control.Monad.Except import qualified Data.Aeson import qualified Data.ByteString.Lazy as LBS import qualified Data.ByteString.Lazy.Char8 as LBS8 @@ -20,6 +21,7 @@ import qualified Data.Text as T import Prelude hiding (FilePath) import Proto3.Suite.DotProto.Generate +import Proto3.Suite.DotProto (fieldLikeName, prefixedEnumFieldName, typeLikeName) import Proto3.Suite.JSONPB (FromJSONPB (..), Options (..), ToJSONPB (..), eitherDecode, encode, defaultOptions) @@ -41,19 +43,34 @@ 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_") ] + [ 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") ] + [ 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" @@ -67,13 +84,12 @@ ] where enumName = "MyEnum" - tc fieldName = testCase fieldName - $ prefixedEnumFieldName enumName fieldName - @?= (enumName <> fieldName) + tc fieldName = testCase fieldName $ + prefixedEnumFieldName enumName fieldName @?= (enumName <> fieldName) setPythonPath :: IO () -setPythonPath = Turtle.export "PYTHONPATH" =<< do - maybe pyTmpDir ((pyTmpDir <> ":") <>) <$> Turtle.need "PYTHONPATH" +setPythonPath = Turtle.export "PYTHONPATH" =<< + maybe pyTmpDir (\p -> pyTmpDir <> ":" <> p) <$> Turtle.need "PYTHONPATH" simpleEncodeDotProto :: TestTree simpleEncodeDotProto = @@ -81,13 +97,13 @@ $ do compileTestDotProtos -- Compile our generated encoder - (@?= ExitSuccess) =<< Turtle.proc "tests/encode.sh" [hsTmpDir] empty + Turtle.proc "tests/encode.sh" [hsTmpDir] empty >>= (@?= ExitSuccess) -- 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 + Turtle.shell cmd empty >>= (@?= ExitFailure 12) -- Not using bracket so that we can inspect the output to fix the tests Turtle.rmtree hsTmpDir @@ -99,11 +115,11 @@ $ do compileTestDotProtos -- Compile our generated decoder - (@?= ExitSuccess) =<< Turtle.proc "tests/decode.sh" [hsTmpDir] empty + Turtle.proc "tests/decode.sh" [hsTmpDir] empty >>= (@?= ExitSuccess) setPythonPath let cmd = "python tests/send_simple_dot_proto.py | " <> hsTmpDir <> "/simpleDecodeDotProto " - (@?= ExitSuccess) =<< Turtle.shell cmd empty + Turtle.shell cmd empty >>= (@?= ExitSuccess) -- Not using bracket so that we can inspect the output to fix the tests Turtle.rmtree hsTmpDir @@ -113,10 +129,10 @@ -- 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 +dumpAST incs fp = (either (error . show) putStrLn <=< runExceptT) $ do + (dp, tc) <- readDotProtoWithContext incs fp + src <- renderHsModuleForDotProto mempty dp tc + pure src hsTmpDir, pyTmpDir :: IsString a => a hsTmpDir = "test-files/hs-tmp" @@ -126,22 +142,29 @@ compileTestDotProtos = do Turtle.mktree hsTmpDir Turtle.mktree pyTmpDir + let protoFiles = + [ "test_proto.proto" + , "test_proto_import.proto" + , "test_proto_oneof.proto" + , "test_proto_oneof_import.proto" + ] + 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 + compileDotProtoFileOrDie + CompileArgs{ includeDir = ["test-files"] + , extraInstanceFiles = [] + , outputDir = hsTmpDir + , inputProto = protoFile + } + + let cmd = T.concat [ "protoc --python_out=" + , pyTmpDir + , " --proto_path=test-files" + , " test-files/" <> Turtle.format F.fp protoFile + ] + Turtle.shell cmd empty >>= (@?= ExitSuccess) + 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 @@ -233,6 +256,17 @@ -- {"properties":{"dummy":{"maximum":2147483647,"format":"int32","minimum":-2147483648,"type":"integer"}},"type":"object"} -- >>> schemaOf @(Enumerated DummyEnum) -- {"type":"string","enum":["DUMMY0","DUMMY1"]} +-- +-- Generic HasDefault +-- +-- >>> def :: MultipleFields +-- MultipleFields {multipleFieldsMultiFieldDouble = 0.0, multipleFieldsMultiFieldFloat = 0.0, multipleFieldsMultiFieldInt32 = 0, multipleFieldsMultiFieldInt64 = 0, multipleFieldsMultiFieldString = "", multipleFieldsMultiFieldBool = False} +-- >>> def :: WithNesting +-- WithNesting {withNestingNestedMessage = Nothing} +-- >>> def :: WithNestingRepeated +-- WithNestingRepeated {withNestingRepeatedNestedMessages = []} +-- >>> def :: WithEnum +-- WithEnum {withEnumEnumField = Enumerated {enumerated = Right WithEnum_TestEnumENUM1}} -- * Helper quickcheck props diff --git a/tools/canonicalize-proto-file/Main.hs b/tools/canonicalize-proto-file/Main.hs --- a/tools/canonicalize-proto-file/Main.hs +++ b/tools/canonicalize-proto-file/Main.hs @@ -13,7 +13,9 @@ module Main (main) where +import Control.Monad.Except import Data.List (sort, sortOn) +import qualified Data.List.NonEmpty as NE import Data.RangeSet.List (fromRangeList, toRangeList) import Data.Semigroup (Min(..), Option(..)) import Options.Generic @@ -34,7 +36,7 @@ main :: IO () main = do Args{..} :: Args Unwrapped <- unwrapRecord "Dumps a canonicalized .proto file to stdout" - readDotProtoWithContext includeDir proto >>= \case + runExceptT (readDotProtoWithContext includeDir proto) >>= \case Left err -> fail (show err) Right (dp, _) -> putStr (toProtoFile defRenderingOptions (canonicalize dp)) @@ -83,18 +85,18 @@ instance CanonicalRank DotProtoDefinition (Int, DotProtoIdentifier) where canonicalRank = \case - DotProtoEnum name _ -> (1, name) - DotProtoMessage name _ -> (2, name) - DotProtoService name _ -> (3, name) + 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) + 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) @@ -157,8 +159,8 @@ , dotProtoFieldType = canonicalize dotProtoFieldType , dotProtoFieldName = canonicalize dotProtoFieldName , dotProtoFieldOptions = canonicalize dotProtoFieldOptions - , dotProtoFieldComment = Nothing -- In future we might add a command-line - -- option to preserve comments. + , dotProtoFieldComment = "" -- In future we might add a command-line + -- option to preserve comments. } canonicalize DotProtoEmptyField = DotProtoEmptyField @@ -214,22 +216,26 @@ instance CanonicalRank DotProtoServicePart (Either (Maybe DotProtoOption) DotProtoIdentifier) where canonicalRank = \case - DotProtoServiceRPC name _ _ _ -> Right name + DotProtoServiceRPCMethod method -> Right (rpcMethodName method) 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) + DotProtoServiceRPCMethod guts -> + DotProtoServiceRPCMethod (canonicalize guts) DotProtoServiceOption option -> DotProtoServiceOption (canonicalize option) DotProtoServiceEmpty -> DotProtoServiceEmpty +instance Canonicalize RPCMethod where + canonicalize (RPCMethod name reqN reqS rspN rspS options) = + RPCMethod (canonicalize name) + (canonicalize reqN) reqS + (canonicalize rspN) rspS + (canonicalize options) + instance Canonicalize DotProtoValue where canonicalize = \case Identifier name -> Identifier (canonicalize name) @@ -241,7 +247,7 @@ instance Canonicalize DotProtoIdentifier where canonicalize = \case Single part -> Single part - Dots (Path [part]) -> Single part + Dots (Path (part NE.:| [])) -> 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 --- a/tools/compile-proto-file/Main.hs +++ b/tools/compile-proto-file/Main.hs @@ -8,21 +8,36 @@ {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeOperators #-} -import Options.Generic +import Data.Semigroup ((<>)) +import Options.Applicative 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) +parseArgs :: ParserInfo CompileArgs +parseArgs = info parser (fullDesc <> progDesc "Compiles a .proto file to a Haskell module") + where + parser = CompileArgs <$> includes <*> extraInstances <*> proto <*> out + includes = many $ strOption $ + long "includeDir" + <> metavar "DIR" + <> help "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)" + + extraInstances = many $ strOption $ + long "extraInstanceFile" + <> metavar "DIR" + <> help "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." + + proto = strOption $ + long "proto" + <> metavar "FILE" + <> help "Path to input .proto file" + + out = strOption $ + long "out" + <> metavar "FILE" + <> help "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!)" + + main :: IO () -main = do - Args{..} :: Args Unwrapped <- unwrapRecord "Compiles a .proto file to a Haskell module" - compileDotProtoFileOrDie extraInstanceFile out includeDir proto +main = execParser parseArgs >>= compileDotProtoFileOrDie