diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,4 +1,24 @@ +# 0.6.0 +* Support use of ShortText as the Haskell type of a protobuf string. +* Replace OverrideToSchema with String and Bytes in order to clarify which + instances of various type classes are selected, expecially ToSchema. +* To disambiguate "String" in generated code, rename + the qualified import of AST-related identifiers. +* Improve test coverage. + +# 0.5.2 +* Support numeric enumerator codes in JSONPB, + as required by the protobuf standard. +* Handle unrecognized enumerator codes within packed repeated + enumeration fields in the same way as in other enumeration fields. +* Avoid compilation errors in code generated for messages having BytesValue + fields. The errors would trigger only when the "swagger-wrapper-format" + Cabal flag of this package was False. +* Code generated from a .proto file that imports the google.protobuf package + no longer depends upon any Haskell module generated from "wrappers.proto". + Instead the proto3-suite library provides the necessary functionality. + # 0.5.1 * Support newer versions of proto3-wire, bytestring, and turtle * Increase minimum version of base for canonicalize-proto-file from 4.8 to 4.11 diff --git a/proto3-suite.cabal b/proto3-suite.cabal --- a/proto3-suite.cabal +++ b/proto3-suite.cabal @@ -1,6 +1,6 @@ -cabal-version: 2.0 +cabal-version: 2.2 name: proto3-suite -version: 0.5.1 +version: 0.6.0 synopsis: A higher-level API to the proto3-wire library description: This library provides a higher-level API to @@ -38,7 +38,21 @@ Default: False Manual: True +flag large-records + Description: Generate records with smaller core code size using the large-records library + Default: True + Manual: True + +source-repository head + type: git + location: https://github.com/awakesecurity/proto3-suite + +common common + default-extensions: + DeriveDataTypeable DeriveGeneric + library + import: common if flag(dhall) exposed-modules: Proto3.Suite.DhallPB @@ -55,10 +69,20 @@ else hs-source-dirs: src/no-swagger-wrapper-format + if flag(large-records) + -- large-records support uses newer Dhall APIs. So we need at least 1.34. + build-depends: dhall >=1.34 && < 1.39, + large-generics, + large-records + cpp-options: -DLARGE_RECORDS + exposed-modules: Proto3.Suite Proto3.Suite.Class Proto3.Suite.DotProto Proto3.Suite.DotProto.Generate + Proto3.Suite.DotProto.Generate.LargeRecord + Proto3.Suite.DotProto.Generate.Record + Proto3.Suite.DotProto.Generate.Syntax Proto3.Suite.DotProto.AST Proto3.Suite.DotProto.AST.Lens Proto3.Suite.DotProto.Parsing @@ -68,10 +92,13 @@ Proto3.Suite.Types Google.Protobuf.Timestamp + Google.Protobuf.Wrappers.Polymorphic Proto3.Suite.DotProto.Internal Proto3.Suite.JSONPB.Class + other-modules: Turtle.Compat + build-depends: aeson >= 1.1.1.0 && < 2.1, aeson-pretty, attoparsec >= 0.13.0.1, @@ -99,9 +126,11 @@ QuickCheck >=2.10 && <2.15, quickcheck-instances < 0.4, safe ==0.3.*, + split, system-filepath, time, text >= 0.2 && <1.3, + text-short >=0.1.3 && <0.2, transformers >=0.4 && <0.6, turtle < 1.6.0 || >= 1.6.1 && < 1.7.0, vector >=0.11 && < 0.13 @@ -112,6 +141,7 @@ ghc-options: -O2 -Wall test-suite tests + import: common default-language: Haskell2010 type: exitcode-stdio-1.0 main-is: Main.hs @@ -131,12 +161,19 @@ if flag(swagger-wrapper-format) cpp-options: -DSWAGGER_WRAPPER_FORMAT + if flag(large-records) + build-depends: large-generics, + large-records + cpp-options: -DLARGE_RECORDS + autogen-modules: TestProto TestProtoImport TestProtoOneof TestProtoOneofImport + TestProtoWrappers TestProtoNestedMessage + other-modules: ArbitraryGeneratedTestTypes TestCodeGen @@ -144,11 +181,14 @@ TestProtoImport TestProtoOneof TestProtoOneofImport + TestProtoWrappers --TestProtoLeadingDot TestProtoNestedMessage --TestProtoProtocPlugin Test.Proto.Generate.Name Test.Proto.Generate.Name.Gen + Test.Proto.Parse.Gen + Test.Proto.Parse.Option build-depends: aeson >= 1.1.1.0 && < 2.1 @@ -163,6 +203,8 @@ , generic-arbitrary , hedgehog , mtl ==2.2.* + , parsec >= 3.1.9 && <3.2.0 + , pretty ==1.1.* , pretty-show >= 1.6.12 && < 2.0 , proto3-suite , proto3-wire >= 1.2 && < 1.5 @@ -172,6 +214,7 @@ , tasty-hunit >= 0.9 && <0.11 , tasty-quickcheck >= 0.8.4 && <0.11 , text >= 0.2 && <1.3 + , text-short >=0.1.3 && <0.2 , transformers >=0.4 && <0.6 , turtle , vector >=0.11 && < 0.13 diff --git a/src/Google/Protobuf/Wrappers/Polymorphic.hs b/src/Google/Protobuf/Wrappers/Polymorphic.hs new file mode 100644 --- /dev/null +++ b/src/Google/Protobuf/Wrappers/Polymorphic.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +module Google.Protobuf.Wrappers.Polymorphic + ( Wrapped(..) + ) where + +import Control.DeepSeq (NFData) +import Data.Aeson (FromJSON, ToJSON) +import GHC.Generics (Generic) + +-- | A Haskell type representing the standard protobuf wrapper +-- message that is associated with the given Haskell type. +-- +-- Note that if Google ever adds wrappers for "sint..." or "...fixed..." +-- then this newtype could still be used, provided its type parameter +-- involves the appropriate combination of `Proto3.Suite.Types.Signed` +-- and/or `Proto3.Suite.Types.Fixed`. Because the latter two types +-- are themselves newtypes, the corresponding coercions should work. +newtype Wrapped a = Wrapped a + deriving (Foldable, Functor, Generic, Show, Traversable) + deriving newtype (Bounded, Enum, Eq, FromJSON, Monoid, + NFData, Num, Ord, Semigroup, ToJSON) 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 @@ -56,13 +56,18 @@ -- > Left e -> error e -- > Right msg -> msg +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE DerivingVia #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MagicHash #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} @@ -80,6 +85,8 @@ , HasDefault(..) , fromByteString , fromB64 + , coerceOver + , unsafeCoerceOver -- * Documentation , Named(..) @@ -96,7 +103,7 @@ import qualified Data.ByteString as B import qualified Data.ByteString.Base64 as B64 import qualified Data.ByteString.Lazy as BL -import Data.Coerce (coerce) +import Data.Coerce (Coercible, coerce) import qualified Data.Foldable as Foldable import Data.Functor (($>)) import Data.Int (Int32, Int64) @@ -106,6 +113,7 @@ import Data.String (IsString (..)) import qualified Data.Text as T import qualified Data.Text.Lazy as TL +import qualified Data.Text.Short as TS import qualified Data.Traversable as TR import qualified Data.Vector as Vector import Data.Vector (Vector) @@ -113,14 +121,36 @@ import GHC.Exts (fromList, Proxy#, proxy#) import GHC.Generics import GHC.TypeLits -import Proto3.Suite.DotProto as DotProto -import Proto3.Suite.Types as Wire +import Google.Protobuf.Wrappers.Polymorphic (Wrapped(..)) +import Proto3.Suite.DotProto +import qualified Proto3.Suite.Types +import Proto3.Suite.Types hiding (Bytes, String) import Proto3.Wire import Proto3.Wire.Decode (ParseError, Parser (..), RawField, RawMessage, RawPrimitive, runParser) import qualified Proto3.Wire.Decode as Decode import qualified Proto3.Wire.Encode as Encode +import Unsafe.Coerce (unsafeCoerce) +#ifdef LARGE_RECORDS +import qualified Data.Record.Generic as LG +import qualified Data.Record.Generic.GHC as LG +import qualified Data.Record.Generic.Rep as LG +#endif + +-- | Pass through those values that are outside the enum range; +-- this is for forward compatibility as enumerations are extended. +codeFromEnumerated :: ProtoEnum e => Enumerated e -> Int32 +codeFromEnumerated = either id fromProtoEnum . enumerated +{-# INLINE codeFromEnumerated #-} + +-- | Values inside the enum range are in Right, the rest in Left; +-- this is for forward compatibility as enumerations are extended. +codeToEnumerated :: ProtoEnum e => Int32 -> Enumerated e +codeToEnumerated code = + Enumerated $ maybe (Left code) Right (toProtoEnumMay code) +{-# INLINE codeToEnumerated #-} + -- | A class for types with default values per the protocol buffers spec. class HasDefault a where -- | The default value for this type. @@ -173,19 +203,34 @@ instance HasDefault T.Text where def = mempty +deriving via T.Text instance HasDefault (Proto3.Suite.Types.String T.Text) + instance HasDefault TL.Text where def = mempty +deriving via TL.Text instance HasDefault (Proto3.Suite.Types.String TL.Text) + +instance HasDefault TS.ShortText where + def = mempty + +deriving via TS.ShortText instance HasDefault (Proto3.Suite.Types.String TS.ShortText) + instance HasDefault B.ByteString where def = mempty +deriving via B.ByteString instance HasDefault (Proto3.Suite.Types.Bytes B.ByteString) + instance HasDefault BL.ByteString where def = mempty +deriving via BL.ByteString instance HasDefault (Proto3.Suite.Types.Bytes BL.ByteString) + instance ProtoEnum e => HasDefault (Enumerated e) where - def = Enumerated $ maybe (Left 0) Right (toProtoEnumMay 0) - isDefault = (== 0) . either id fromProtoEnum . enumerated + def = codeToEnumerated 0 + isDefault = (== 0) . codeFromEnumerated +deriving via (a :: *) instance HasDefault a => HasDefault (Wrapped a) + instance HasDefault (UnpackedVec a) where def = mempty isDefault = null . unpackedvec @@ -238,6 +283,13 @@ instance (Selector i, GenericHasDefault f) => GenericHasDefault (S1 i f) where genericDef = M1 (genericDef @f) +#ifdef LARGE_RECORDS + +instance (LG.Generic a, LG.Constraints a HasDefault) => GenericHasDefault (LG.ThroughLRGenerics a) where + genericDef = LG.WrapThroughLRGenerics $ LG.to $ LG.cpure (Proxy @HasDefault) (pure def) + +#endif + -- | This class captures those types whose names need to appear in .proto files. -- -- It has a default implementation for any data type which is an instance of the @@ -255,6 +307,41 @@ instance Datatype d => GenericNamed (M1 D d f) where genericNameOf _ = fromString (datatypeName (undefined :: M1 D d f ())) +instance NameOfWrapperFor a => Named (Wrapped a) where + nameOf _ = nameOfWrapperFor @a + {-# INLINE nameOf #-} + +-- | Defines the name to be returned by @`HsProtobuf.Named` (`Wrapped` a)@. +class NameOfWrapperFor a where + nameOfWrapperFor :: forall string . IsString string => string + +instance NameOfWrapperFor Double where + nameOfWrapperFor = "DoubleValue" + +instance NameOfWrapperFor Float where + nameOfWrapperFor = "FloatValue" + +instance NameOfWrapperFor Int64 where + nameOfWrapperFor = "Int64Value" + +instance NameOfWrapperFor Word64 where + nameOfWrapperFor = "UInt64Value" + +instance NameOfWrapperFor Int32 where + nameOfWrapperFor = "Int32Value" + +instance NameOfWrapperFor Word32 where + nameOfWrapperFor = "UInt32Value" + +instance NameOfWrapperFor Bool where + nameOfWrapperFor = "BoolValue" + +instance NameOfWrapperFor (Proto3.Suite.Types.String a) where + nameOfWrapperFor = "StringValue" + +instance NameOfWrapperFor (Proto3.Suite.Types.Bytes a) where + nameOfWrapperFor = "BytesValue" + -- | Enumerable types with finitely many values. -- -- This class can be derived whenever a sum type is an instance of 'Generic', @@ -328,6 +415,16 @@ fromB64 :: Message a => B.ByteString -> Either ParseError a fromB64 = fromByteString . B64.decodeLenient +-- | Like `coerce` but lets you avoid specifying a type constructor +-- (such a as parser) that is common to both the input and output types. +coerceOver :: forall a b f . Coercible (f a) (f b) => f a -> f b +coerceOver = coerce + +-- | Like `unsafeCoerce` but lets you avoid specifying a type constructor +-- (such a as parser) that is common to both the input and output types. +unsafeCoerceOver :: forall a b f . f a -> f b +unsafeCoerceOver = unsafeCoerce + instance Primitive Int32 where encodePrimitive = Encode.int32 decodePrimitive = Decode.int32 @@ -361,12 +458,12 @@ instance Primitive (Fixed Word32) where encodePrimitive num = Encode.fixed32 num . coerce decodePrimitive = coerce Decode.fixed32 - primType _ = DotProto.Fixed32 + primType _ = Fixed32 instance Primitive (Fixed Word64) where encodePrimitive num = Encode.fixed64 num . coerce decodePrimitive = coerce Decode.fixed64 - primType _ = DotProto.Fixed64 + primType _ = Fixed64 instance Primitive (Signed (Fixed Int32)) where encodePrimitive num = Encode.sfixed32 num . coerce @@ -398,21 +495,36 @@ decodePrimitive = fmap TL.toStrict Decode.text primType _ = String +deriving via T.Text instance Primitive (Proto3.Suite.Types.String T.Text) + instance Primitive TL.Text where encodePrimitive = Encode.text decodePrimitive = Decode.text primType _ = String +deriving via TL.Text instance Primitive (Proto3.Suite.Types.String TL.Text) + +instance Primitive TS.ShortText where + encodePrimitive = Encode.shortText + decodePrimitive = Decode.shortText + primType _ = String + +deriving via TS.ShortText instance Primitive (Proto3.Suite.Types.String TS.ShortText) + instance Primitive B.ByteString where encodePrimitive = Encode.byteString decodePrimitive = Decode.byteString primType _ = Bytes +deriving via B.ByteString instance Primitive (Proto3.Suite.Types.Bytes B.ByteString) + instance Primitive BL.ByteString where encodePrimitive = Encode.lazyByteString decodePrimitive = Decode.lazyByteString primType _ = Bytes +deriving via BL.ByteString instance Primitive (Proto3.Suite.Types.Bytes BL.ByteString) + instance forall e. (Named e, ProtoEnum e) => Primitive (Enumerated e) where encodePrimitive num = either (Encode.int32 num) (Encode.enum num) . enumerated decodePrimitive = coerce @@ -449,7 +561,7 @@ default protoType :: Primitive a => Proxy# a -> DotProtoField protoType p = messageField (Prim $ primType p) Nothing -messageField :: DotProtoType -> Maybe DotProto.Packing -> DotProtoField +messageField :: DotProtoType -> Maybe Packing -> DotProtoField messageField ty packing = DotProtoField { dotProtoFieldNumber = fieldNumber 1 , dotProtoFieldType = ty @@ -462,8 +574,8 @@ toDotProtoOption b = [DotProtoOption (Single "packed") (BoolLit b)] - isPacked DotProto.PackedField = True - isPacked DotProto.UnpackedField = False + isPacked PackedField = True + isPacked UnpackedField = False instance MessageField Int32 instance MessageField Int64 @@ -479,9 +591,15 @@ instance MessageField Float instance MessageField Double instance MessageField T.Text +deriving via T.Text instance MessageField (Proto3.Suite.Types.String T.Text) instance MessageField TL.Text +deriving via TL.Text instance MessageField (Proto3.Suite.Types.String TL.Text) +instance MessageField TS.ShortText +deriving via TS.ShortText instance MessageField (Proto3.Suite.Types.String TS.ShortText) instance MessageField B.ByteString +deriving via B.ByteString instance MessageField (Proto3.Suite.Types.Bytes B.ByteString) instance MessageField BL.ByteString +deriving via BL.ByteString instance MessageField (Proto3.Suite.Types.Bytes BL.ByteString) 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 @@ -520,7 +638,7 @@ encodeMessageField fn = Encode.vectorMessageBuilder (encodePrimitive fn) . unpackedvec decodeMessageField = UnpackedVec . fromList . Foldable.toList <$> repeated decodePrimitive - protoType _ = messageField (Repeated $ primType (proxy# :: Proxy# a)) (Just DotProto.UnpackedField) + protoType _ = messageField (Repeated $ primType (proxy# :: Proxy# a)) (Just UnpackedField) instance forall a. (Named a, Message a) => MessageField (NestedVec a) where encodeMessageField fn = Encode.vectorMessageBuilder (Encode.embedded fn . encodeMessage (fieldNumber 1)) . nestedvec @@ -533,17 +651,9 @@ protoType _ = messageField (NestedRepeated . Named . Single $ nameOf (proxy# :: Proxy# a)) Nothing instance (Named e, ProtoEnum e) => MessageField (PackedVec (Enumerated e)) where - encodeMessageField fn = omittingDefault (Encode.packedVarintsV fromIntegral fn) . Vector.mapMaybe omit . packedvec - where - -- omit values which are outside the enum range - omit :: Enumerated e -> Maybe Int32 - omit (Enumerated (Right e)) = Just (fromProtoEnum e) - omit _ = Nothing - decodeMessageField = decodePacked (foldMap retain <$> Decode.packedVarints @Word64) - where - -- retain only those values which are inside the enum range - retain = foldMap (pure . Enumerated . Right) . toProtoEnumMay . fromIntegral - protoType _ = messageField (Repeated . Named . Single $ nameOf (proxy# :: Proxy# e)) (Just DotProto.PackedField) + encodeMessageField fn = omittingDefault (Encode.packedVarintsV fromIntegral fn) . Vector.map codeFromEnumerated . packedvec + decodeMessageField = decodePacked (map (codeToEnumerated . fromIntegral) <$> Decode.packedVarints @Word64) + protoType _ = messageField (Repeated . Named . Single $ nameOf (proxy# :: Proxy# e)) (Just PackedField) instance MessageField (PackedVec Bool) where encodeMessageField fn = omittingDefault (Encode.packedBoolsV id fn) . packedvec @@ -552,27 +662,27 @@ toBool :: Word64 -> Bool toBool 1 = True toBool _ = False - protoType _ = messageField (Repeated Bool) (Just DotProto.PackedField) + protoType _ = messageField (Repeated Bool) (Just PackedField) instance MessageField (PackedVec Word32) where encodeMessageField fn = omittingDefault (Encode.packedVarintsV fromIntegral fn) . packedvec decodeMessageField = decodePacked Decode.packedVarints - protoType _ = messageField (Repeated UInt32) (Just DotProto.PackedField) + protoType _ = messageField (Repeated UInt32) (Just PackedField) instance MessageField (PackedVec Word64) where encodeMessageField fn = omittingDefault (Encode.packedVarintsV id fn) . packedvec decodeMessageField = decodePacked Decode.packedVarints - protoType _ = messageField (Repeated UInt64) (Just DotProto.PackedField) + protoType _ = messageField (Repeated UInt64) (Just PackedField) instance MessageField (PackedVec Int32) where encodeMessageField fn = omittingDefault (Encode.packedVarintsV fromIntegral fn) . packedvec decodeMessageField = decodePacked Decode.packedVarints - protoType _ = messageField (Repeated Int32) (Just DotProto.PackedField) + protoType _ = messageField (Repeated Int32) (Just PackedField) instance MessageField (PackedVec Int64) where encodeMessageField fn = omittingDefault (Encode.packedVarintsV fromIntegral fn) . packedvec decodeMessageField = decodePacked Decode.packedVarints - protoType _ = messageField (Repeated Int64) (Just DotProto.PackedField) + protoType _ = messageField (Repeated Int64) (Just PackedField) instance MessageField (PackedVec (Signed Int32)) where encodeMessageField fn = omittingDefault (Encode.packedVarintsV zigZag fn) . coerce @_ @(Vector Int32) @@ -587,7 +697,7 @@ zagZig :: Word32 -> Signed Int32 zagZig = Signed . fromIntegral . Decode.zigZagDecode - protoType _ = messageField (Repeated SInt32) (Just DotProto.PackedField) + protoType _ = messageField (Repeated SInt32) (Just PackedField) instance MessageField (PackedVec (Signed Int64)) where encodeMessageField fn = omittingDefault (Encode.packedVarintsV zigZag fn) . coerce @_ @(Vector Int64) @@ -602,7 +712,7 @@ zagZig :: Word64 -> Signed Int64 zagZig = Signed . fromIntegral . Decode.zigZagDecode - protoType _ = messageField (Repeated SInt64) (Just DotProto.PackedField) + protoType _ = messageField (Repeated SInt64) (Just PackedField) instance MessageField (PackedVec (Fixed Word32)) where @@ -610,38 +720,38 @@ decodeMessageField = coerce @(Parser RawField (PackedVec Word32)) @(Parser RawField (PackedVec (Fixed Word32))) (decodePacked Decode.packedFixed32) - protoType _ = messageField (Repeated DotProto.Fixed32) (Just DotProto.PackedField) + protoType _ = messageField (Repeated Fixed32) (Just PackedField) instance MessageField (PackedVec (Fixed Word64)) where encodeMessageField fn = omittingDefault (Encode.packedFixed64V id fn) . coerce @_ @(Vector Word64) decodeMessageField = coerce @(Parser RawField (PackedVec Word64)) @(Parser RawField (PackedVec (Fixed Word64))) (decodePacked Decode.packedFixed64) - protoType _ = messageField (Repeated DotProto.Fixed64) (Just DotProto.PackedField) + protoType _ = messageField (Repeated Fixed64) (Just PackedField) instance MessageField (PackedVec (Signed (Fixed Int32))) where encodeMessageField fn = omittingDefault (Encode.packedFixed32V fromIntegral fn) . coerce @_ @(Vector Int32) decodeMessageField = coerce @(Parser RawField (PackedVec Int32)) @(Parser RawField (PackedVec (Signed (Fixed Int32)))) (decodePacked Decode.packedFixed32) - protoType _ = messageField (Repeated SFixed32) (Just DotProto.PackedField) + protoType _ = messageField (Repeated SFixed32) (Just PackedField) instance MessageField (PackedVec (Signed (Fixed Int64))) where encodeMessageField fn = omittingDefault (Encode.packedFixed64V fromIntegral fn) . coerce @_ @(Vector Int64) decodeMessageField = coerce @(Parser RawField (PackedVec Int64)) @(Parser RawField (PackedVec (Signed (Fixed Int64)))) (decodePacked Decode.packedFixed64) - protoType _ = messageField (Repeated SFixed64) (Just DotProto.PackedField) + protoType _ = messageField (Repeated SFixed64) (Just PackedField) instance MessageField (PackedVec Float) where encodeMessageField fn = omittingDefault (Encode.packedFloatsV id fn) . packedvec decodeMessageField = decodePacked Decode.packedFloats - protoType _ = messageField (Repeated Float) (Just DotProto.PackedField) + protoType _ = messageField (Repeated Float) (Just PackedField) instance MessageField (PackedVec Double) where encodeMessageField fn = omittingDefault (Encode.packedDoublesV id fn) . packedvec decodeMessageField = decodePacked Decode.packedDoubles - protoType _ = messageField (Repeated Double) (Just DotProto.PackedField) + protoType _ = messageField (Repeated Double) (Just PackedField) instance (MessageField e, KnownSymbol comments) => MessageField (e // comments) where encodeMessageField fn = encodeMessageField fn . unCommented @@ -692,6 +802,20 @@ instance (MessageField k, MessageField v) => Message (k, v) +instance (MessageField a, Primitive a) => Message (Wrapped a) where + encodeMessage _ (Wrapped v) = encodeMessageField (FieldNumber 1) v + {-# INLINABLE encodeMessage #-} + decodeMessage _ = Wrapped <$> at decodeMessageField (FieldNumber 1) + {-# INLINABLE decodeMessage #-} + dotProto _ = + [ DotProtoField + (FieldNumber 1) + (Prim (primType (proxy# :: Proxy# a))) + (Single "value") + [] + "" + ] + -- | Generate metadata for a message type. message :: (Message a, Named a) => Proxy# a -> DotProtoDefinition message proxy = DotProtoMessage "" @@ -763,10 +887,21 @@ decodeMessage = decodeWrapperMessage dotProto = dotProtoWrapper +deriving via T.Text instance Message (Proto3.Suite.Types.String T.Text) + instance Message TL.Text where encodeMessage = encodeWrapperMessage decodeMessage = decodeWrapperMessage dotProto = dotProtoWrapper + +deriving via TL.Text instance Message (Proto3.Suite.Types.String TL.Text) + +instance Message TS.ShortText where + encodeMessage = encodeWrapperMessage + decodeMessage = decodeWrapperMessage + dotProto = dotProtoWrapper + +deriving via TS.ShortText instance Message (Proto3.Suite.Types.String TS.ShortText) instance Message B.ByteString where encodeMessage = encodeWrapperMessage 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 @@ -1,6 +1,16 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleInstances #-} +#ifdef LARGE_RECORDS +{-# LANGUAGE ApplicativeDo #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +#endif + {-# OPTIONS_GHC -fno-warn-orphans #-} #if !(MIN_VERSION_dhall(1,27,0)) @@ -32,6 +42,20 @@ import qualified Data.Map #endif +#ifdef LARGE_RECORDS +import Data.Coerce (coerce) +import Data.Proxy (Proxy (..)) +import Data.Void (Void) +import qualified Data.Text as Text +import qualified Dhall.Core as Dhall +import qualified Dhall.Map as Dhall +import qualified Dhall.Parser as Dhall +import Data.Record.Generic ((:.:)(Comp), I (..), K (..)) +import qualified Data.Record.Generic as LG +import qualified Data.Record.Generic.GHC as LG +import qualified Data.Record.Generic.Rep as LG +#endif + -------------------------------------------------------------------------------- -- Interpret the special 'Enumerated' type @@ -189,4 +213,65 @@ instance (Dhall.Inject k, Dhall.Inject v) => Dhall.Inject (Data.Map.Map k v) where injectWith = fmap (contramap Data.Map.toAscList) Dhall.injectWith +#endif + +#ifdef LARGE_RECORDS + +instance (LG.Generic a, LG.Constraints a Dhall.FromDhall) => Dhall.GenericFromDhall a (LG.ThroughLRGenerics a) where + genericAutoWithNormalizer _ normalizer _ = pure $ coerce $ Dhall.Decoder extract expected + where + makeCompRep :: (forall x. Dhall.FromDhall x => K String x -> f (g x)) -> LG.Rep (f :.: g) a + makeCompRep f = LG.cmap + (Proxy @Dhall.FromDhall) + (Comp . f) + (LG.recordFieldNames $ LG.metadata (Proxy @a)) + + extract :: Dhall.Expr Dhall.Src Void -> Dhall.Extractor Dhall.Src Void a + extract expr = + case expr of + Dhall.RecordLit flds -> do + let getField :: forall x. Dhall.FromDhall x => K String x -> Dhall.Extractor Dhall.Src Void x + getField (K fld) = + let decoder = Dhall.autoWith @x normalizer + in maybe + (Dhall.typeError expected expr) + (Dhall.extract decoder) + (Dhall.recordFieldValue <$> Dhall.lookup (Text.pack fld) flds) + LG.to <$> LG.sequenceA (makeCompRep (fmap I . getField)) + _ -> Dhall.typeError expected expr + + expected :: Dhall.Expector (Dhall.Expr Dhall.Src Void) + expected = do + let getField :: forall x. Dhall.FromDhall x => K String x -> Dhall.Expector (Dhall.Text, Dhall.RecordField Dhall.Src Void) + getField (K fld) = do + let decoder = Dhall.autoWith @x normalizer + f <- Dhall.makeRecordField <$> Dhall.expected decoder + pure (Text.pack fld, f) + Dhall.Record . Dhall.fromList . LG.collapse <$> LG.sequenceA (makeCompRep (fmap K . getField)) + +instance (LG.Generic a, LG.Constraints a Dhall.ToDhall) => Dhall.GenericToDhall (LG.ThroughLRGenerics a) where + genericToDhallWithNormalizer normalizer _ = pure $ coerce $ Dhall.Encoder embed declared + where + md = LG.metadata (Proxy @a) + fieldNames = LG.recordFieldNames md + + embed :: a -> Dhall.Expr Dhall.Src Void + embed = Dhall.RecordLit + . Dhall.fromList + . LG.collapse + . LG.zipWith (LG.mapKKK $ \n x -> (Text.pack n, Dhall.makeRecordField x)) fieldNames + . LG.cmap (Proxy @Dhall.ToDhall) (K . Dhall.embed (injectWith normalizer) . LG.unI) + . LG.from + + declared :: Dhall.Expr Dhall.Src Void + declared = Dhall.Record + $ Dhall.fromList + $ LG.collapse + $ LG.cmap + (Proxy @Dhall.ToDhall) + (\(K n :: K String x) -> + let typ = Dhall.declared (injectWith @x normalizer) + in K (Text.pack n, Dhall.makeRecordField typ)) + fieldNames + #endif 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,8 @@ -- | Fairly straightforward AST encoding of the .proto grammar {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE RecordWildCards #-} @@ -34,9 +36,11 @@ import Control.Applicative import Control.Monad +import Data.Data (Data) import Data.Int (Int32) import qualified Data.List.NonEmpty as NE -import Data.String (IsString) +import Data.String (IsString(..)) +import GHC.Generics (Generic) import Numeric.Natural import Prelude hiding (FilePath) import Proto3.Wire.Types (FieldNumber (..)) @@ -46,29 +50,31 @@ -- | The name of a message newtype MessageName = MessageName - { getMessageName :: String - } deriving (Eq, Ord, IsString) + { getMessageName :: String } + deriving (Data, Eq, Generic, IsString, Ord) instance Show MessageName where show = show . getMessageName -- | The name of some field newtype FieldName = FieldName - { getFieldName :: String - } deriving (Eq, Ord, IsString) + { getFieldName :: String } + deriving (Data, Eq, Generic, IsString, Ord) instance Show FieldName where show = show . getFieldName -- | The name of the package newtype PackageName = PackageName - { getPackageName :: String - } deriving (Eq, Ord, IsString) + { getPackageName :: String } + deriving (Data, Eq, Generic, IsString, Ord) instance Show PackageName where show = show . getPackageName -newtype Path = Path { components :: NE.NonEmpty String } deriving (Show, Eq, Ord) +newtype Path = Path + { components :: NE.NonEmpty String } + deriving (Data, Eq, Generic, Ord, Show) -- Used for testing fakePath :: Path @@ -79,25 +85,26 @@ | Dots Path | Qualified DotProtoIdentifier DotProtoIdentifier | Anonymous -- [recheck] is there a better way to represent unnamed things - deriving (Show, Eq, Ord) + deriving (Data, Eq, Generic, Ord, Show) -- | Top-level import declaration data DotProtoImport = DotProtoImport { dotProtoImportQualifier :: DotProtoImportQualifier , dotProtoImportPath :: FilePath - } deriving (Show, Eq, Ord) + } + deriving (Data, Eq, Generic, Ord, Show) instance Arbitrary DotProtoImport where - arbitrary = do - dotProtoImportQualifier <- arbitrary - let dotProtoImportPath = mempty - return (DotProtoImport {..}) + arbitrary = do + dotProtoImportQualifier <- arbitrary + dotProtoImportPath <- fmap fromString arbitrary + return (DotProtoImport {..}) data DotProtoImportQualifier = DotProtoImportPublic | DotProtoImportWeak | DotProtoImportDefault - deriving (Show, Eq, Ord) + deriving (Bounded, Data, Enum, Eq, Generic, Ord, Show) instance Arbitrary DotProtoImportQualifier where arbitrary = elements @@ -110,7 +117,7 @@ data DotProtoPackageSpec = DotProtoPackageSpec DotProtoIdentifier | DotProtoNoPackage - deriving (Show, Eq) + deriving (Data, Eq, Generic, Ord, Show) instance Arbitrary DotProtoPackageSpec where arbitrary = oneof @@ -123,7 +130,7 @@ data DotProtoOption = DotProtoOption { dotProtoOptionIdentifier :: DotProtoIdentifier , dotProtoOptionValue :: DotProtoValue - } deriving (Show, Eq, Ord) + } deriving (Data, Eq, Generic, Ord, Show) instance Arbitrary DotProtoOption where arbitrary = do @@ -139,8 +146,7 @@ = DotProtoMessage String DotProtoIdentifier [DotProtoMessagePart] | DotProtoEnum String DotProtoIdentifier [DotProtoEnumPart] | DotProtoService String DotProtoIdentifier [DotProtoServicePart] - deriving (Show, Eq) - + deriving (Data, Eq, Generic, Ord, Show) instance Arbitrary DotProtoDefinition where arbitrary = oneof [arbitraryMessage, arbitraryEnum] @@ -167,7 +173,7 @@ -- path values are constructed. See -- 'Proto3.Suite.DotProto.Generate.modulePathModName' to see how it is used -- during code generation. - } deriving (Show, Eq) + } deriving (Data, Eq, Generic, Ord, Show) instance Arbitrary DotProtoMeta where arbitrary = pure (DotProtoMeta fakePath) @@ -182,7 +188,7 @@ , protoPackage :: DotProtoPackageSpec , protoDefinitions :: [DotProtoDefinition] , protoMeta :: DotProtoMeta - } deriving (Show, Eq) + } deriving (Data, Eq, Generic, Ord, Show) instance Arbitrary DotProto where arbitrary = do @@ -201,7 +207,7 @@ | IntLit Int | FloatLit Double | BoolLit Bool - deriving (Show, Eq, Ord) + deriving (Data, Eq, Generic, Ord, Show) instance Arbitrary DotProtoValue where arbitrary = oneof @@ -230,7 +236,7 @@ | Double | Named DotProtoIdentifier -- ^ A named type, referring to another message or enum defined in the same file - deriving (Show, Eq) + deriving (Data, Eq, Generic, Ord, Show) instance Arbitrary DotProtoPrimType where arbitrary = oneof @@ -257,7 +263,7 @@ data Packing = PackedField | UnpackedField - deriving (Show, Eq) + deriving (Bounded, Data, Enum, Eq, Generic, Ord, Show) instance Arbitrary Packing where arbitrary = elements [PackedField, UnpackedField] @@ -270,7 +276,7 @@ | Repeated DotProtoPrimType | NestedRepeated DotProtoPrimType | Map DotProtoPrimType DotProtoPrimType - deriving (Show, Eq) + deriving (Data, Eq, Generic, Ord, Show) instance Arbitrary DotProtoType where arbitrary = oneof [fmap Prim arbitrary] @@ -281,7 +287,7 @@ = DotProtoEnumField DotProtoIdentifier DotProtoEnumValue [DotProtoOption] | DotProtoEnumOption DotProtoOption | DotProtoEnumEmpty - deriving (Show, Eq) + deriving (Data, Eq, Generic, Ord, Show) instance Arbitrary DotProtoEnumPart where arbitrary = oneof [arbitraryField, arbitraryOption] @@ -299,7 +305,7 @@ data Streaming = Streaming | NonStreaming - deriving (Show, Eq) + deriving (Bounded, Data, Enum, Eq, Generic, Ord, Show) instance Arbitrary Streaming where arbitrary = elements [Streaming, NonStreaming] @@ -308,7 +314,7 @@ = DotProtoServiceRPCMethod RPCMethod | DotProtoServiceOption DotProtoOption | DotProtoServiceEmpty - deriving (Show, Eq) + deriving (Data, Eq, Generic, Ord, Show) instance Arbitrary DotProtoServicePart where arbitrary = oneof @@ -323,7 +329,8 @@ , rpcMethodResponseType :: DotProtoIdentifier , rpcMethodResponseStreaming :: Streaming , rpcMethodOptions :: [DotProtoOption] - } deriving (Show, Eq) + } + deriving (Data, Eq, Generic, Ord, Show) instance Arbitrary RPCMethod where arbitrary = do @@ -341,7 +348,7 @@ | DotProtoMessageDefinition DotProtoDefinition | DotProtoMessageReserved [DotProtoReservedField] | DotProtoMessageOption DotProtoOption - deriving (Show, Eq) + deriving (Data, Eq, Generic, Ord, Show) instance Arbitrary DotProtoMessagePart where arbitrary = oneof @@ -369,7 +376,8 @@ return (DotProtoMessageReserved fields) arbitraryReservedLabels :: Gen [DotProtoReservedField] - arbitraryReservedLabels = smallListOf1 (ReservedIdentifier <$> return "") + arbitraryReservedLabels = + smallListOf1 (ReservedIdentifier <$> arbitraryIdentifierName) data DotProtoField = DotProtoField { dotProtoFieldNumber :: FieldNumber @@ -379,7 +387,7 @@ , dotProtoFieldComment :: String } | DotProtoEmptyField - deriving (Show, Eq) + deriving (Data, Eq, Generic, Ord, Show) instance Arbitrary DotProtoField where arbitrary = do @@ -395,7 +403,7 @@ = SingleField Int | FieldRange Int Int | ReservedIdentifier String - deriving (Show, Eq) + deriving (Data, Eq, Generic, Ord, Show) instance Arbitrary DotProtoReservedField where arbitrary = 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,5 +1,6 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} @@ -22,6 +23,9 @@ module Proto3.Suite.DotProto.Generate ( CompileError(..) + , StringType(..) + , RecordStyle (..) + , parseStringType , TypeContext , CompileArgs(..) , compileDotProtoFile @@ -38,11 +42,12 @@ import Data.Char import Data.Coerce import Data.Either (partitionEithers) -import Data.List (find, intercalate, nub, sortBy, stripPrefix) +import Data.List (find, intercalate, nub, sort, sortBy, stripPrefix) import qualified Data.List.NonEmpty as NE -import Data.List.NonEmpty (NonEmpty (..)) +import Data.List.Split (splitOn) +import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.Map as M -import Data.Maybe (fromMaybe) +import Data.Maybe import Data.Monoid import Data.Ord (comparing) import qualified Data.Set as S @@ -55,11 +60,15 @@ import Prelude hiding (FilePath) import Proto3.Suite.DotProto import Proto3.Suite.DotProto.AST.Lens +import qualified Proto3.Suite.DotProto.Generate.LargeRecord as LargeRecord +import qualified Proto3.Suite.DotProto.Generate.Record as RegularRecord +import Proto3.Suite.DotProto.Generate.Syntax import Proto3.Suite.DotProto.Internal import Proto3.Wire.Types (FieldNumber (..)) import Text.Parsec (Parsec, alphaNum, eof, parse, satisfy, try) import qualified Text.Parsec as Parsec -import qualified Turtle +import qualified Turtle hiding (encodeString) +import qualified Turtle.Compat as Turtle (encodeString) import Turtle (FilePath, (), (<.>)) -------------------------------------------------------------------------------- @@ -72,8 +81,21 @@ , extraInstanceFiles :: [FilePath] , inputProto :: FilePath , outputDir :: FilePath + , stringType :: StringType + , recordStyle :: RecordStyle } +data StringType = StringType String String + -- ^ Qualified module name, then unqualified type name. + +data RecordStyle = RegularRecords | LargeRecords + deriving stock (Eq, Show, Read) + +parseStringType :: String -> Either String StringType +parseStringType str = case splitOn "." str of + xs@(_ : _ : _) -> Right $ StringType (intercalate "." $ init xs) (last xs) + _ -> Left "must be in the form Module.Type" + -- | Generate a Haskell module corresponding to a @.proto@ file compileDotProtoFile :: CompileArgs -> IO (Either CompileError ()) compileDotProtoFile CompileArgs{..} = runExceptT $ do @@ -88,7 +110,7 @@ Turtle.mktree (Turtle.directory modulePath) extraInstances <- foldMapM getExtraInstances extraInstanceFiles - haskellModule <- renderHsModuleForDotProto extraInstances dotProto importTypeContext + haskellModule <- renderHsModuleForDotProto stringType recordStyle extraInstances dotProto importTypeContext liftIO (writeFile (Turtle.encodeString modulePath) haskellModule) where @@ -158,31 +180,81 @@ -- 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 ++ "\n" ++ 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 #-} - {-# OPTIONS_GHC -fno-warn-missing-export-lists #-} + => StringType + -> RecordStyle + -> ([HsImportDecl],[HsDecl]) -> DotProto -> TypeContext -> m String +renderHsModuleForDotProto stringType recordStyle extraInstanceFiles dotProto importCtxt = do + haskellModule <- hsModuleForDotProto stringType recordStyle extraInstanceFiles dotProto importCtxt + let languagePragmas = textUnlines $ map (\extn -> "{-# LANGUAGE " <> extn <> " #-}") $ sort extensions + ghcOptionPragmas = textUnlines $ map (\opt -> "{-# OPTIONS_GHC " <> opt <> " #-}") $ sort options + + extensions :: [T.Text] + extensions = + [ "DataKinds" + , "DeriveAnyClass" + , "DeriveGeneric" + , "GADTs" + , "OverloadedStrings" + , "TypeApplications" + ] ++ + case recordStyle of + RegularRecords -> [] + LargeRecords -> [ "ConstraintKinds" + , "FlexibleInstances" + , "MultiParamTypeClasses" + , "ScopedTypeVariables" + , "TypeFamilies" + , "UndecidableInstances" + ] + + options :: [T.Text] + options = [ "-fno-warn-unused-imports" + , "-fno-warn-name-shadowing" + , "-fno-warn-unused-matches" + , "-fno-warn-missing-export-lists" + ] ++ + case recordStyle of + RegularRecords -> [] + LargeRecords -> [ "-fplugin=Data.Record.Plugin" ] + + mkLRAnnotation :: HsDecl -> Maybe T.Text + mkLRAnnotation (HsDataDecl _ _ (HsIdent recName) _ [HsRecDecl _ _ (_fld1:_fld2:_)] _) = + Just ("{-# ANN type " <> T.pack recName <> " largeRecord #-}") + mkLRAnnotation _ = Nothing + + lrAnnotations :: T.Text + lrAnnotations = + case (recordStyle, haskellModule) of + (RegularRecords, _) -> "" + (LargeRecords, HsModule _ _ _ _ moduleDecls) -> + textUnlines (mapMaybe mkLRAnnotation moduleDecls) + + moduleContent :: T.Text + moduleContent = T.pack (prettyPrint haskellModule) + + textUnlines :: [T.Text] -> T.Text + textUnlines = T.intercalate "\n" + + pure $ T.unpack $ [Neat.text| + $languagePragmas + $ghcOptionPragmas + -- | Generated by Haskell protocol buffer compiler. DO NOT EDIT! + $moduleContent + + $lrAnnotations |] -- | Compile a Haskell module AST given a 'DotProto' package AST. -- Instances given in @eis@ override those otherwise generated. hsModuleForDotProto :: MonadError CompileError m - => ([HsImportDecl], [HsDecl]) + => StringType + -- ^ the module and the type for string + -> RecordStyle + -- ^ kind of records to generate + -> ([HsImportDecl], [HsDecl]) -- ^ Extra user-define instances that override default generated instances -> DotProto -- ^ @@ -190,6 +262,8 @@ -- ^ -> m HsModule hsModuleForDotProto + stringType + recordStyle (extraImports, extraInstances) dotProto@DotProto{ protoMeta = DotProtoMeta { metaModulePath = modulePath } , protoPackage @@ -197,19 +271,25 @@ } importTypeContext = do - packageIdentifier <- protoPackageName protoPackage moduleName <- modulePathModName modulePath typeContextImports <- ctxtImports importTypeContext let hasService = has (traverse._DotProtoService) protoDefinitions - let importDeclarations = concat [ defaultImports hasService, extraImports, typeContextImports ] + let importDeclarations = concat + [ defaultImports recordStyle + ImportCustomisation + { icUsesGrpc = hasService + , icStringType = stringType + } + , extraImports + , typeContextImports ] typeContext <- dotProtoTypeContext dotProto let toDotProtoDeclaration = - dotProtoDefinitionD packageIdentifier (typeContext <> importTypeContext) + dotProtoDefinitionD stringType recordStyle protoPackage (typeContext <> importTypeContext) let extraInstances' = instancesForModule moduleName extraInstances @@ -320,16 +400,21 @@ | path `S.member` alreadyRead = throwError (CircularImport path) | otherwise = do import_ <- importProto searchPaths toplevelFP path - importPkg <- protoPackageName (protoPackage import_) + let importPkgSpec = protoPackage import_ let fixImportTyInfo tyInfo = - tyInfo { dotProtoTypeInfoPackage = DotProtoPackageSpec importPkg + tyInfo { dotProtoTypeInfoPackage = importPkgSpec , dotProtoTypeInfoModulePath = metaModulePath . protoMeta $ import_ } importTypeContext <- fmap fixImportTyInfo <$> dotProtoTypeContext import_ - qualifiedTypeContext <- mapKeysM (concatDotProtoIdentifier importPkg) importTypeContext + let prefixWithPackageName = + case importPkgSpec of + DotProtoPackageSpec packageName -> concatDotProtoIdentifier packageName + DotProtoNoPackage -> pure + qualifiedTypeContext <- mapKeysM prefixWithPackageName importTypeContext + let isPublic (DotProtoImport q _) = q == DotProtoImportPublic transitiveImportsTC <- foldMapOfM (traverse . filtered isPublic) @@ -338,12 +423,15 @@ pure $ importTypeContext <> qualifiedTypeContext <> transitiveImportsTC --- | Given a type context, generates the Haskell import statements necessary --- to import all the required types. +-- | Given a type context, generates the Haskell import statements necessary to +-- import all the required types. Excludes module "Google.Protobuf.Wrappers" +-- because the generated code does not actually make use of wrapper types +-- as such; instead it uses @Maybe a@, where @a@ is the wrapped type. ctxtImports :: MonadError CompileError m => TypeContext -> m [HsImportDecl] -ctxtImports = fmap (map mkImport . nub) - . traverse (modulePathModName . dotProtoTypeInfoModulePath) - . M.elems +ctxtImports = + fmap (map mkImport . nub . filter (Module "Google.Protobuf.Wrappers" /=)) + . traverse (modulePathModName . dotProtoTypeInfoModulePath) + . M.elems where mkImport modName = importDecl_ modName True Nothing Nothing @@ -366,14 +454,6 @@ identName <- qualifiedMessageTypeName ctxt dotProtoTypeInfoParent ident pure $ HsTyCon (Qual modName (HsIdent identName)) -haskellName, jsonpbName, grpcName, protobufName, protobufWrapperName, 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) -protobufWrapperName name = Qual (Module "Google.Protobuf.Wrappers") (HsIdent name) - modulePathModName :: MonadError CompileError m => Path -> m Module modulePathModName (Path comps) = Module . intercalate "." <$> traverse typeLikeName (NE.toList comps) @@ -417,85 +497,136 @@ -- ** 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) +data FieldContext = WithinMessage | WithinOneOf + deriving (Eq, Show) + +typeApp :: HsType -> HsExp +typeApp ty = uvar_ ("@("++ pp ty ++ ")") 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)) +coerceE :: Bool -> Bool -> HsType -> HsType -> Maybe HsExp +coerceE _ _ from to | from == to = Nothing +coerceE overTyCon unsafe from to = + Just $ HsApp (HsApp coerceF (typeApp from)) (typeApp to) where - overParser = fmap $ HsTyApp (HsTyVar (HsIdent "_")) + coerceF | unsafe = HsVar (name "unsafeCoerce") + | otherwise = HsVar (name "coerce") + name | overTyCon = protobufName . (<> "Over") + | otherwise = haskellName +wrapFunE :: MonadError CompileError m => Bool -> FieldContext -> StringType -> TypeContext -> [DotProtoOption] -> DotProtoType -> m (Maybe HsExp) +wrapFunE overTyCon fc stringType ctxt opts dpt = + coerceE overTyCon (isMap dpt) + <$> dptToHsType fc stringType ctxt dpt + <*> dptToHsTypeWrapped fc stringType opts ctxt dpt +wrapE :: MonadError CompileError m => FieldContext -> StringType -> TypeContext -> [DotProtoOption] -> DotProtoType -> HsExp -> m HsExp +wrapE fc stringType ctxt opts dpt e = + maybeModify e <$> wrapFunE False fc stringType ctxt opts dpt + +unwrapFunE :: MonadError CompileError m => Bool -> FieldContext -> StringType -> TypeContext -> [DotProtoOption] -> DotProtoType -> m (Maybe HsExp) +unwrapFunE overTyCon fc stringType ctxt opts dpt = + coerceE overTyCon (isMap dpt) + <$> dptToHsTypeWrapped fc stringType opts ctxt dpt + <*> dptToHsType fc stringType ctxt dpt + +unwrapE :: MonadError CompileError m => FieldContext -> StringType -> TypeContext -> [DotProtoOption] -> DotProtoType -> HsExp -> m HsExp +unwrapE fc stringType ctxt opts dpt e = do + maybeModify e <$> unwrapFunE True fc stringType ctxt opts dpt + -------------------------------------------------------------------------------- -- -- * 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 +dptToHsType :: MonadError CompileError m => FieldContext -> StringType -> TypeContext -> DotProtoType -> m HsType +dptToHsType fc = foldDPT (dptToHsContType fc) . 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) - where - 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 (Dots (Path ("google" :| ["protobuf", x]))) - | x == "Int32Value" -> pure $ protobufWrapperType_ x - | x == "Int64Value" -> pure $ protobufWrapperType_ x - | x == "UInt32Value" -> pure $ protobufWrapperType_ x - | x == "UInt64Value" -> pure $ protobufWrapperType_ x - | x == "StringValue" -> pure $ protobufWrapperType_ x - | x == "BytesValue" -> pure $ protobufWrapperType_ x - | x == "BoolValue" -> pure $ protobufWrapperType_ x - | x == "FloatValue" -> pure $ protobufWrapperType_ x - | x == "DoubleValue" -> pure $ protobufWrapperType_ x - Named msgName -> - case M.lookup msgName ctxt of - Just ty@(DotProtoTypeInfo { dotProtoTypeInfoKind = DotProtoKindEnum }) -> - HsTyApp (protobufType_ "Enumerated") <$> msgTypeFromDpTypeInfo ctxt ty msgName - Just ty -> msgTypeFromDpTypeInfo ctxt ty msgName - Nothing -> noSuchTypeError msgName +dptToHsTypeWrapped + :: MonadError CompileError m + => FieldContext + -> StringType + -> [DotProtoOption] + -> TypeContext + -> DotProtoType + -> m HsType +dptToHsTypeWrapped fc stringType opts = + foldDPT + -- The wrapper for the collection type replaces the native haskell + -- collection type, so try that first. + (\ctxt ty -> maybe (dptToHsContType fc ctxt ty) id (dptToHsWrappedContType fc ctxt opts ty)) + -- Always wrap the primitive type. + (dpptToHsTypeWrapped stringType) +-- | Like 'dptToHsTypeWrapped' but without use of +-- 'dptToHsContType' or 'dptToHsWrappedContType'. +dpptToHsTypeWrapped + :: MonadError CompileError m + => StringType + -> TypeContext + -> DotProtoPrimType + -> m HsType +dpptToHsTypeWrapped (StringType _ stringType) ctxt = \case + Int32 -> + pure $ primType_ "Int32" + Int64 -> + pure $ primType_ "Int64" + SInt32 -> + pure $ protobufSignedType_ $ primType_ "Int32" + SInt64 -> + pure $ protobufSignedType_ $ primType_ "Int64" + UInt32 -> + pure $ primType_ "Word32" + UInt64 -> + pure $ primType_ "Word64" + Fixed32 -> + pure $ protobufFixedType_ $ primType_ "Word32" + Fixed64 -> + pure $ protobufFixedType_ $ primType_ "Word64" + SFixed32 -> + pure $ protobufSignedType_ $ protobufFixedType_ $ primType_ "Int32" + SFixed64 -> + pure $ protobufSignedType_ $ protobufFixedType_ $ primType_ "Int64" + String -> + pure $ protobufStringType_ stringType + Bytes -> + pure $ protobufBytesType_ "ByteString" + Bool -> + pure $ primType_ "Bool" + Float -> + pure $ primType_ "Float" + Double -> + pure $ primType_ "Double" + Named (Dots (Path ("google" :| ["protobuf", x]))) + | x == "Int32Value" -> + pure $ protobufWrappedType_ $ primType_ "Int32" + | x == "Int64Value" -> + pure $ protobufWrappedType_ $ primType_ "Int64" + | x == "UInt32Value" -> + pure $ protobufWrappedType_ $ primType_ "Word32" + | x == "UInt64Value" -> + pure $ protobufWrappedType_ $ primType_ "Word64" + | x == "StringValue" -> + pure $ protobufWrappedType_ $ protobufStringType_ stringType + | x == "BytesValue" -> + pure $ protobufWrappedType_ $ protobufBytesType_ "ByteString" + | x == "BoolValue" -> + pure $ protobufWrappedType_ $ primType_ "Bool" + | x == "FloatValue" -> + pure $ protobufWrappedType_ $ primType_ "Float" + | x == "DoubleValue" -> + pure $ protobufWrappedType_ $ primType_ "Double" + Named msgName -> + case M.lookup msgName ctxt of + Just ty@(DotProtoTypeInfo { dotProtoTypeInfoKind = DotProtoKindEnum }) -> + HsTyApp (protobufType_ "Enumerated") <$> msgTypeFromDpTypeInfo ctxt ty msgName + Just ty -> msgTypeFromDpTypeInfo ctxt ty msgName + Nothing -> noSuchTypeError msgName + foldDPT :: MonadError CompileError m => (TypeContext -> DotProtoType -> HsType -> HsType) -> (TypeContext -> DotProtoPrimType -> m HsType) @@ -517,10 +648,14 @@ -- | Translate DotProtoType constructors to wrapped Haskell container types -- (for Message serde instances). -dptToHsWrappedContType :: TypeContext -> [DotProtoOption] -> DotProtoType -> Maybe (HsType -> HsType) -dptToHsWrappedContType ctxt opts = \case +-- +-- When the given 'FieldContext' is 'WithinOneOf' we do not wrap submessages +-- in "Maybe" because the entire oneof is already wrapped in a "Maybe". +dptToHsWrappedContType :: FieldContext -> TypeContext -> [DotProtoOption] -> DotProtoType -> Maybe (HsType -> HsType) +dptToHsWrappedContType fc ctxt opts = \case Prim (Named tyName) - | isMessage ctxt tyName -> Just $ HsTyApp (protobufType_ "Nested") + | WithinMessage <- fc, isMessage ctxt tyName + -> Just $ HsTyApp (protobufType_ "Nested") Repeated (Named tyName) | isMessage ctxt tyName -> Just $ HsTyApp (protobufType_ "NestedVec") Repeated ty @@ -531,32 +666,25 @@ _ -> Nothing -- | Translate DotProtoType to Haskell container types. -dptToHsContType :: TypeContext -> DotProtoType -> HsType -> HsType -dptToHsContType ctxt = \case - Prim (Named tyName) | isMessage ctxt tyName +-- +-- When the given 'FieldContext' is 'WithinOneOf' we do not wrap submessages +-- in "Maybe" because the entire oneof is already wrapped in a "Maybe". +dptToHsContType :: FieldContext -> TypeContext -> DotProtoType -> HsType -> HsType +dptToHsContType fc ctxt = \case + Prim (Named tyName) | WithinMessage <- fc, isMessage ctxt tyName -> 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 + => StringType + -> TypeContext -> DotProtoPrimType -> m HsType -dpptToHsType ctxt = \case +dpptToHsType (StringType _ stringType) ctxt = \case Int32 -> pure $ primType_ "Int32" Int64 -> pure $ primType_ "Int64" SInt32 -> pure $ primType_ "Int32" @@ -567,7 +695,7 @@ Fixed64 -> pure $ primType_ "Word64" SFixed32 -> pure $ primType_ "Int32" SFixed64 -> pure $ primType_ "Int64" - String -> pure $ primType_ "Text" + String -> pure $ primType_ stringType Bytes -> pure $ primType_ "ByteString" Bool -> pure $ primType_ "Bool" Float -> pure $ primType_ "Float" @@ -577,7 +705,7 @@ | x == "Int64Value" -> pure $ primType_ "Int64" | x == "UInt32Value" -> pure $ primType_ "Word32" | x == "UInt64Value" -> pure $ primType_ "Word64" - | x == "StringValue" -> pure $ primType_ "Text" + | x == "StringValue" -> pure $ primType_ stringType | x == "BytesValue" -> pure $ primType_ "ByteString" | x == "BoolValue" -> pure $ primType_ "Bool" | x == "FloatValue" -> pure $ primType_ "Float" @@ -603,16 +731,21 @@ -- ** Generate instances for a 'DotProto' package dotProtoDefinitionD :: MonadError CompileError m - => DotProtoIdentifier -> TypeContext -> DotProtoDefinition -> m [HsDecl] -dotProtoDefinitionD pkgIdent ctxt = \case + => StringType + -> RecordStyle + -> DotProtoPackageSpec + -> TypeContext + -> DotProtoDefinition + -> m [HsDecl] +dotProtoDefinitionD stringType recordStyle pkgSpec ctxt = \case DotProtoMessage _ messageName messageParts -> - dotProtoMessageD ctxt Anonymous messageName messageParts + dotProtoMessageD stringType recordStyle ctxt Anonymous messageName messageParts DotProtoEnum _ enumName enumParts -> dotProtoEnumD Anonymous enumName enumParts DotProtoService _ serviceName serviceParts -> - dotProtoServiceD pkgIdent ctxt serviceName serviceParts + dotProtoServiceD stringType pkgSpec ctxt serviceName serviceParts -- | Generate 'Named' instance for a type in this package namedInstD :: String -> HsDecl @@ -639,12 +772,14 @@ dotProtoMessageD :: forall m . MonadError CompileError m - => TypeContext + => StringType + -> RecordStyle + -> TypeContext -> DotProtoIdentifier -> DotProtoIdentifier -> [DotProtoMessagePart] -> m [HsDecl] -dotProtoMessageD ctxt parentIdent messageIdent messageParts = do +dotProtoMessageD stringType recordStyle ctxt parentIdent messageIdent messageParts = do messageName <- qualifiedMessageName parentIdent messageIdent let mkDataDecl flds = @@ -653,19 +788,22 @@ defaultMessageDeriving let getName = \case - DotProtoMessageField fld -> [dotProtoFieldName fld] - DotProtoMessageOneOf ident _ -> [ident] - _ -> [] + DotProtoMessageField fld -> (: []) <$> getFieldNameForSchemaInstanceDeclaration fld + DotProtoMessageOneOf ident _ -> (: []) . (Nothing, ) <$> dpIdentUnqualName ident + _ -> pure [] + messageDataDecl <- mkDataDecl <$> foldMapM (messagePartFieldD messageName) messageParts + foldMapM id [ sequence - [ mkDataDecl <$> foldMapM (messagePartFieldD messageName) messageParts + [ pure messageDataDecl + , pure (nfDataInstD messageDataDecl messageName) , pure (namedInstD messageName) , pure (hasDefaultInstD messageName) - , messageInstD ctxt' parentIdent messageIdent messageParts + , messageInstD stringType ctxt' parentIdent messageIdent messageParts - , toJSONPBMessageInstD ctxt' parentIdent messageIdent messageParts - , fromJSONPBMessageInstD ctxt' parentIdent messageIdent messageParts + , toJSONPBMessageInstD stringType ctxt' parentIdent messageIdent messageParts + , fromJSONPBMessageInstD stringType ctxt' parentIdent messageIdent messageParts -- Generate Aeson instances in terms of JSONPB instances , pure (toJSONInstDecl messageName) @@ -673,8 +811,8 @@ #ifdef SWAGGER -- And the Swagger ToSchema instance corresponding to JSONPB encodings - , toSchemaInstanceDeclaration messageName Nothing - =<< foldMapM (traverse dpIdentUnqualName . getName) messageParts + , toSchemaInstanceDeclaration stringType ctxt' messageName Nothing + =<< foldMapM getName messageParts #endif #ifdef DHALL @@ -699,10 +837,14 @@ ctxt' = maybe mempty dotProtoTypeChildContext (M.lookup messageIdent ctxt) <> ctxt + nfDataInstD = case recordStyle of + RegularRecords -> RegularRecord.nfDataInstD + LargeRecords -> LargeRecord.nfDataInstD + messagePartFieldD :: String -> DotProtoMessagePart -> m [([HsName], HsBangType)] messagePartFieldD messageName (DotProtoMessageField DotProtoField{..}) = do fullName <- prefixedFieldName messageName =<< dpIdentUnqualName dotProtoFieldName - fullTy <- dptToHsType ctxt' dotProtoFieldType + fullTy <- dptToHsType WithinMessage stringType ctxt' dotProtoFieldType pure [ ([HsIdent fullName], HsUnBangedTy fullTy ) ] messagePartFieldD messageName (DotProtoMessageOneOf fieldName _) = do @@ -716,7 +858,7 @@ nestedDecls :: DotProtoDefinition -> m [HsDecl] nestedDecls (DotProtoMessage _ subMsgName subMessageDef) = do parentIdent' <- concatDotProtoIdentifier parentIdent messageIdent - dotProtoMessageD ctxt' parentIdent' subMsgName subMessageDef + dotProtoMessageD stringType recordStyle ctxt' parentIdent' subMsgName subMessageDef nestedDecls (DotProtoEnum _ subEnumName subEnumDef) = do parentIdent' <- concatDotProtoIdentifier parentIdent messageIdent @@ -731,11 +873,13 @@ (cons, idents) <- fmap unzip (mapM (oneOfCons fullName) fields) #ifdef SWAGGER - toSchemaInstance <- toSchemaInstanceDeclaration fullName (Just idents) - =<< mapM (dpIdentUnqualName . dotProtoFieldName) fields + toSchemaInstance <- toSchemaInstanceDeclaration stringType ctxt' fullName (Just idents) + =<< mapM getFieldNameForSchemaInstanceDeclaration fields #endif - pure [ dataDecl_ fullName cons defaultMessageDeriving + let nestedDecl = dataDecl_ fullName cons defaultMessageDeriving + pure [ nestedDecl + , nfDataInstD nestedDecl fullName , namedInstD fullName #ifdef SWAGGER , toSchemaInstance @@ -749,12 +893,7 @@ oneOfCons :: String -> DotProtoField -> m (HsConDecl, HsName) oneOfCons fullName DotProtoField{..} = do - consTy <- case dotProtoFieldType of - Prim msg@(Named msgName) - | isMessage ctxt' msgName - -> dpptToHsType ctxt' msg - _ -> dptToHsType ctxt' dotProtoFieldType - + consTy <- dptToHsType WithinOneOf stringType ctxt' dotProtoFieldType consName <- prefixedConName fullName =<< dpIdentUnqualName dotProtoFieldName let ident = HsIdent consName pure (conDecl_ ident [HsUnBangedTy consTy], ident) @@ -766,12 +905,13 @@ messageInstD :: forall m . MonadError CompileError m - => TypeContext + => StringType + -> TypeContext -> DotProtoIdentifier -> DotProtoIdentifier -> [DotProtoMessagePart] -> m HsDecl -messageInstD ctxt parentIdent msgIdent messageParts = do +messageInstD stringType ctxt parentIdent msgIdent messageParts = do msgName <- qualifiedMessageName parentIdent msgIdent qualifiedFields <- getQualifiedFields msgName messageParts @@ -821,7 +961,7 @@ let recordFieldName' = uvar_ (coerce recordFieldName) in case fieldInfo of FieldNormal _fieldName fieldNum dpType options -> do - fieldE <- wrapE ctxt options dpType recordFieldName' + fieldE <- wrapE WithinMessage stringType ctxt options dpType recordFieldName' pure $ apply encodeMessageFieldE [ fieldNumberE fieldNum, fieldE ] FieldOneOf OneofField{subfields} -> do @@ -848,7 +988,11 @@ let wrapJust = HsParen . HsApp (HsVar (haskellName "Just")) xE <- (if isMaybe then id else fmap forceEmitE) - . wrapE ctxt options dpType + . wrapE WithinMessage stringType ctxt options dpType + -- For now we use 'WithinMessage' to preserve + -- the historical approach of treating this field + -- as if it were an ordinary non-oneof field that + -- just happens to be present. . (if isMaybe then wrapJust else id) $ uvar_ "y" @@ -861,7 +1005,8 @@ decodeMessageField QualifiedField{fieldInfo} = case fieldInfo of FieldNormal _fieldName fieldNum dpType options -> - unwrapE ctxt options dpType $ apply atE [ decodeMessageFieldE, fieldNumberE fieldNum ] + unwrapE WithinMessage stringType ctxt options dpType $ + apply atE [ decodeMessageFieldE, fieldNumberE fieldNum ] FieldOneOf OneofField{subfields} -> do parsers <- mapM subfieldParserE subfields @@ -878,7 +1023,11 @@ composeOp (uvar_ consName)) - alts <- unwrapE ctxt options dpType decodeMessageFieldE + -- For now we continue the historical practice of parsing + -- submessages within oneofs as if were outside of oneofs, + -- and replacing the "Just . Ctor" with "fmap . Ctor". + -- That is why we do not pass WithinOneOf. + alts <- unwrapE WithinMessage stringType ctxt options dpType decodeMessageFieldE pure $ HsTuple [ fieldNumberE fieldNumber @@ -889,48 +1038,61 @@ -- *** Generate ToJSONPB/FromJSONPB instances toJSONPBMessageInstD - :: MonadError CompileError m - => TypeContext + :: forall m + . MonadError CompileError m + => StringType + -> TypeContext -> DotProtoIdentifier -> DotProtoIdentifier -> [DotProtoMessagePart] -> m HsDecl -toJSONPBMessageInstD _ctxt parentIdent msgIdent messageParts = do +toJSONPBMessageInstD stringType 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 applyE nm oneofNm = do + fs <- traverse (encodeMessageField oneofNm) qualFields + pure $ apply (HsVar (jsonpbName nm)) [HsList fs] let patBinder = foldQF (const fieldBinder) (oneofSubDisjunctBinder . subfields) - let matchE nm appNm oneofAppNm = - match_ + let matchE nm appNm oneofAppNm = do + rhs <- applyE appNm oneofAppNm + pure $ match_ (HsIdent nm) [ HsPApp (unqual_ msgName) (patVar . patBinder <$> qualFields) ] - (HsUnGuardedRhs (applyE appNm oneofAppNm)) + (HsUnGuardedRhs rhs) [] + toJSONPB <- matchE "toJSONPB" "object" "objectOrNull" + toEncoding <- matchE "toEncodingPB" "pairs" "pairsOrNull" + pure $ instDecl_ (jsonpbName "ToJSONPB") [ type_ msgName ] - [ HsFunBind [matchE "toJSONPB" "object" "objectOrNull"] - , HsFunBind [matchE "toEncodingPB" "pairs" "pairsOrNull" ] + [ HsFunBind [toJSONPB] + , HsFunBind [toEncoding] ] where + encodeMessageField :: String -> QualifiedField -> m HsExp + encodeMessageField oneofNm (QualifiedField _ fieldInfo) = + case fieldInfo of + FieldNormal fldName fldNum dpType options -> + defPairE fldName fldNum dpType options + FieldOneOf oo -> + oneofCaseE oneofNm oo + -- E.g. -- "another" .= f2 -- always succeeds (produces default value on missing field) - defPairE fldName fldNum = - HsInfixApp (str_ (coerce fldName)) - toJSONPBOp - (uvar_ (fieldBinder fldNum)) + defPairE fldName fldNum dpType options = do + w <- wrapE WithinMessage stringType ctxt options dpType (uvar_ (fieldBinder fldNum)) + pure $ HsInfixApp (str_ (coerce fldName)) toJSONPBOp w -- E.g. -- HsJSONPB.pair "name" f4 -- fails on missing field - pairE fldNm varNm = - apply (HsVar (jsonpbName "pair")) - [ str_ (coerce fldNm) , uvar_ varNm] + oneOfPairE fldNm varNm options dpType = do + w <- wrapE WithinOneOf stringType ctxt options dpType (uvar_ varNm) + pure $ apply (HsVar (jsonpbName "pair")) [str_ (coerce fldNm), w] -- Suppose we have a sum type Foo, nested inside a message Bar. -- We want to generate the following: @@ -945,9 +1107,11 @@ -- > , -- > , -- > ] - oneofCaseE retJsonCtor (OneofField typeName subfields) = - HsParen - $ HsLet [ HsFunBind [ match_ (HsIdent caseName) [] (HsUnGuardedRhs caseExpr) [] ] ] + oneofCaseE :: String -> OneofField -> m HsExp + oneofCaseE retJsonCtor (OneofField typeName subfields) = do + altEs <- traverse altE subfields + pure $ HsParen + $ HsLet [ HsFunBind [ match_ (HsIdent caseName) [] (HsUnGuardedRhs (caseExpr altEs)) [] ] ] $ HsLambda defaultSrcLoc [patVar optsStr] (HsIf dontInline noInline yesInline) where optsStr = "options" @@ -966,6 +1130,16 @@ yesInline = HsApp caseBnd opts + altE sub@(OneofSubfield _ conName pbFldNm dpType options) = do + let patVarNm = oneofSubBinder sub + p <- oneOfPairE pbFldNm patVarNm options dpType + pure $ alt_ (HsPApp (haskellName "Just") + [ HsPParen + (HsPApp (unqual_ conName) [patVar patVarNm]) + ] + ) + (HsUnGuardedAlt p) + [] -- E.g. -- case f4_or_f9 of @@ -975,36 +1149,30 @@ -- -> HsJSONPB.pair "someid" f9 -- Nothing -- -> mempty - caseExpr = HsParen $ + caseExpr altEs = 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 + :: forall m + . MonadError CompileError m + => StringType + -> TypeContext -> DotProtoIdentifier -> DotProtoIdentifier -> [DotProtoMessagePart] -> m HsDecl -fromJSONPBMessageInstD _ctxt parentIdent msgIdent messageParts = do +fromJSONPBMessageInstD stringType ctxt parentIdent msgIdent messageParts = do msgName <- qualifiedMessageName parentIdent msgIdent qualFields <- getQualifiedFields msgName messageParts + fieldParsers <- traverse parseField qualFields + let parseJSONPBE = apply (HsVar (jsonpbName "withObject")) [ str_ msgName @@ -1013,7 +1181,7 @@ where fieldAps = foldl (\f -> HsInfixApp f apOp) (apply pureE [ uvar_ msgName ]) - (foldQF normalParserE oneofParserE <$> qualFields) + fieldParsers let parseJSONPBDecl = match_ (HsIdent "parseJSONPB") [] (HsUnGuardedRhs parseJSONPBE) [] @@ -1025,6 +1193,11 @@ lambdaPVar = patVar "obj" lambdaVar = uvar_ "obj" + parseField (QualifiedField _ (FieldNormal fldName _ dpType options)) = + normalParserE fldName dpType options + parseField (QualifiedField _ (FieldOneOf fld)) = + oneofParserE fld + -- E.g., for message -- message Something { oneof name_or_id { string name = _; int32 someid = _; } } -- @@ -1036,10 +1209,12 @@ -- <|> -- (parseSomethingNameOrId obj) -- ) - oneofParserE (OneofField oneofType fields) = - HsParen $ + oneofParserE :: OneofField -> m HsExp + oneofParserE (OneofField oneofType fields) = do + ds <- tryParseDisjunctsE + pure $ HsParen $ HsLet [ HsFunBind [ match_ (HsIdent letBndStr) [patVar letArgStr ] - (HsUnGuardedRhs tryParseDisjunctsE) [] + (HsUnGuardedRhs ds) [] ] ] (HsInfixApp parseWrapped altOp parseUnwrapped) @@ -1064,26 +1239,33 @@ -- , (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)]) + tryParseDisjunctsE = do + fs <- traverse subParserE fields + pure $ HsApp msumE (HsList (fs <> fallThruE)) + fallThruE = [ HsApp pureE (HsVar (haskellName "Nothing")) ] + + subParserE OneofSubfield{subfieldConsName, subfieldName, + subfieldType, subfieldOptions} = do + maybeCoercion <- + unwrapFunE False WithinOneOf stringType ctxt subfieldOptions subfieldType + let inject = (HsInfixApp (HsVar (haskellName "Just")) + composeOp + (uvar_ subfieldConsName)) + pure $ HsInfixApp + (maybe inject (HsInfixApp inject composeOp) maybeCoercion) + fmapOp + (apply (HsVar (jsonpbName "parseField")) + [ letArgName + , str_ (coerce subfieldName)]) + -- E.g. obj .: "someid" - normalParserE fldNm _ = - HsInfixApp lambdaVar - parseJSONPBOp - (str_(coerce fldNm)) + normalParserE :: FieldName -> DotProtoType -> [DotProtoOption] -> m HsExp + normalParserE fldName dpType options = + unwrapE WithinMessage stringType ctxt options dpType $ + HsInfixApp lambdaVar + parseJSONPBOp + (str_(coerce fldName)) -- *** Generate default Aeson To/FromJSON and Swagger ToSchema instances -- (These are defined in terms of ToJSONPB) @@ -1112,16 +1294,30 @@ -- *** Generate `ToSchema` instance +getFieldNameForSchemaInstanceDeclaration + :: MonadError CompileError m + => DotProtoField + -> m (Maybe ([DotProtoOption], DotProtoType), String) +getFieldNameForSchemaInstanceDeclaration fld = do + unqual <- dpIdentUnqualName (dotProtoFieldName fld) + let optsType = (dotProtoFieldOptions fld, dotProtoFieldType fld) + pure (Just optsType, unqual) + toSchemaInstanceDeclaration :: MonadError CompileError m - => String + => StringType + -> TypeContext + -> String -- ^ Name of the message type to create an instance for -> Maybe [HsName] -- ^ Oneof constructors - -> [String] - -- ^ Field names + -> [(Maybe ([DotProtoOption], DotProtoType), String)] + -- ^ Field names, with every field that is not actually a oneof + -- combining fields paired with its options and protobuf type -> m HsDecl -toSchemaInstanceDeclaration messageName maybeConstructors fieldNames = do +toSchemaInstanceDeclaration stringType ctxt messageName maybeConstructors fieldNamesEtc = do + let fieldNames = map snd fieldNamesEtc + qualifiedFieldNames <- mapM (prefixedFieldName messageName) fieldNames let messageConstructor = HsCon (UnQual (HsIdent messageName)) @@ -1203,10 +1399,11 @@ let toDeclareName fieldName = "declare_" ++ fieldName - let toArgument fieldName = HsApp asProxy declare + let toArgument fc (maybeOptsType, fieldName) = + maybe pure (uncurry (unwrapE fc stringType ctxt)) maybeOptsType $ + HsApp asProxy declare where declare = uvar_ (toDeclareName fieldName) - asProxy = HsVar (jsonpbName "asProxy") -- do let declare_fieldName0 = HsJSONPB.declareSchemaRef @@ -1216,35 +1413,32 @@ -- ... -- 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 expressionForMessage = do + let bindingStatements = do + (fieldName, qualifiedFieldName) <- zip fieldNames qualifiedFieldNames - let declareIdentifier = HsIdent (toDeclareName fieldName) + let declareIdentifier = HsIdent (toDeclareName fieldName) - let stmt0 = HsLetStmt [ HsFunBind - [ HsMatch defaultSrcLoc declareIdentifier [] - (HsUnGuardedRhs (HsVar (jsonpbName "declareSchemaRef"))) [] + let stmt0 = HsLetStmt [ HsFunBind + [ HsMatch defaultSrcLoc declareIdentifier [] + (HsUnGuardedRhs (HsVar (jsonpbName "declareSchemaRef"))) [] + ] ] - ] - let stmt1 = HsGenerator defaultSrcLoc (HsPVar (HsIdent qualifiedFieldName)) - (HsApp (HsVar (UnQual declareIdentifier)) - (HsCon (proxyName "Proxy"))) - [ stmt0, stmt1] - + let stmt1 = HsGenerator defaultSrcLoc (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 + inferenceStatement <- do + arguments <- traverse (toArgument WithinMessage) fieldNamesEtc + let patternBind = HsPatBind defaultSrcLoc HsPWildCard + (HsUnGuardedRhs (applicativeApply messageConstructor arguments)) [] + pure $ if null fieldNames then [] else [ HsLetStmt [ patternBind ] ] - patternBind = HsPatBind defaultSrcLoc HsPWildCard - (HsUnGuardedRhs (applicativeApply messageConstructor arguments)) [] + let returnStatement = HsQualifier (HsApp returnE (HsParen namedSchema)) - returnStatement = HsQualifier (HsApp returnE (HsParen namedSchema)) + pure $ HsDo (bindingStatements ++ inferenceStatement ++ [ returnStatement ]) -- do let declare_fieldName0 = HsJSONPB.declareSchemaRef -- let _ = pure ConstructorName0 <*> HsJSONPB.asProxy declare_fieldName0 @@ -1254,35 +1448,36 @@ -- qualifiedFieldName1 <- declare_fieldName1 Proxy.Proxy -- ... -- return (...) - let expressionForOneOf constructors = - HsDo (bindingStatements ++ [ returnStatement ]) - where - bindingStatements = do - (fieldName, qualifiedFieldName, constructor) - <- zip3 fieldNames qualifiedFieldNames constructors + let expressionForOneOf constructors = do + let bindingStatement (fieldNameEtc, qualifiedFieldName, constructor) = do + let declareIdentifier = HsIdent (toDeclareName (snd fieldNameEtc)) - let declareIdentifier = HsIdent (toDeclareName fieldName) + let stmt0 = HsLetStmt [ HsFunBind + [ HsMatch defaultSrcLoc declareIdentifier [] + (HsUnGuardedRhs (HsVar (jsonpbName "declareSchemaRef"))) [] + ] + ] + let stmt1 = HsGenerator defaultSrcLoc (HsPVar (HsIdent qualifiedFieldName)) + (HsApp (HsVar (UnQual declareIdentifier)) + (HsCon (proxyName "Proxy"))) + inferenceStatement <- do + argument <- toArgument WithinOneOf fieldNameEtc + let patternBind = HsPatBind defaultSrcLoc HsPWildCard + (HsUnGuardedRhs (applicativeApply (HsCon (UnQual constructor)) [ argument ])) [] + pure $ if null fieldNames then [] else [ HsLetStmt [ patternBind ] ] - let stmt0 = HsLetStmt [ HsFunBind - [ HsMatch defaultSrcLoc declareIdentifier [] - (HsUnGuardedRhs (HsVar (jsonpbName "declareSchemaRef"))) [] - ] - ] - let stmt1 = HsGenerator defaultSrcLoc (HsPVar (HsIdent qualifiedFieldName)) - (HsApp (HsVar (UnQual declareIdentifier)) - (HsCon (proxyName "Proxy"))) - let inferenceStatement = - if null fieldNames then [] else [ HsLetStmt [ patternBind ] ] - where - arguments = [ toArgument fieldName ] + pure $ [stmt0, stmt1] ++ inferenceStatement - patternBind = HsPatBind defaultSrcLoc HsPWildCard - (HsUnGuardedRhs (applicativeApply (HsCon (UnQual constructor)) arguments)) [] + bindingStatements <- foldMapM bindingStatement $ + zip3 fieldNamesEtc qualifiedFieldNames constructors - [stmt0, stmt1] ++ inferenceStatement + let returnStatement = HsQualifier (HsApp returnE (HsParen namedSchema)) + pure $ HsDo (bindingStatements ++ [ returnStatement ]) - returnStatement = HsQualifier (HsApp returnE (HsParen namedSchema)) + expression <- case maybeConstructors of + Nothing -> expressionForMessage + Just constructors -> expressionForOneOf constructors let instanceDeclaration = instDecl_ className [ classArgument ] [ classDeclaration ] @@ -1295,10 +1490,6 @@ where match = match_ matchName [ HsPWildCard ] rightHandSide [] where - expression = case maybeConstructors of - Nothing -> expressionForMessage - Just constructors -> expressionForOneOf constructors - rightHandSide = HsUnGuardedRhs expression matchName = HsIdent "declareNamedSchema" @@ -1459,16 +1650,21 @@ dotProtoServiceD :: MonadError CompileError m - => DotProtoIdentifier + => StringType + -> DotProtoPackageSpec -> TypeContext -> DotProtoIdentifier -> [DotProtoServicePart] -> m [HsDecl] -dotProtoServiceD pkgIdent ctxt serviceIdent service = do +dotProtoServiceD stringType pkgSpec ctxt serviceIdent service = do serviceName <- typeLikeName =<< dpIdentUnqualName serviceIdent - packageName <- dpIdentQualName pkgIdent - let endpointPrefix = "/" ++ packageName ++ "." ++ serviceName ++ "/" + endpointPrefix <- + case pkgSpec of + DotProtoPackageSpec pkgIdent -> do + packageName <- dpIdentQualName pkgIdent + pure $ "/" ++ packageName ++ "." ++ serviceName ++ "/" + DotProtoNoPackage -> pure $ "/" ++ serviceName ++ "/" let serviceFieldD (DotProtoServiceRPCMethod RPCMethod{..}) = do fullName <- prefixedMethodName serviceName =<< dpIdentUnqualName rpcMethodName @@ -1477,9 +1673,9 @@ Single nm -> pure nm _ -> invalidMethodNameError rpcMethodName - requestTy <- dpptToHsType ctxt (Named rpcMethodRequestType) + requestTy <- dpptToHsType stringType ctxt (Named rpcMethodRequestType) - responseTy <- dpptToHsType ctxt (Named rpcMethodResponseType) + responseTy <- dpptToHsType stringType ctxt (Named rpcMethodResponseType) let streamingType = case (rpcMethodRequestStreaming, rpcMethodResponseStreaming) of @@ -1626,52 +1822,11 @@ -- * Common Haskell expressions, constructors, and operators -- -dotProtoFieldC, primC, 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, +unaryHandlerC, clientStreamHandlerC, serverStreamHandlerC, biDiStreamHandlerC, + methodNameC, defaultOptionsE, serverLoopE, convertServerHandlerE, convertServerReaderHandlerE, convertServerWriterHandlerE, convertServerRWHandlerE, clientRegisterMethodE, clientRequestE :: HsExp -dotProtoFieldC = HsVar (protobufName "DotProtoField") -primC = HsVar (protobufName "Prim") -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") @@ -1702,36 +1857,6 @@ 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 @@ -1744,7 +1869,7 @@ 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 (Qualified a b) = apply qualifiedC [ dpIdentE a, dpIdentE b ] dpIdentE Anonymous = anonymousC dpValueE :: DotProtoValue -> HsExp @@ -1770,7 +1895,7 @@ -- | Translate a dot proto primitive type to a Haskell AST primitive type. dpPrimTypeE :: DotProtoPrimType -> HsExp dpPrimTypeE ty = - let wrap = HsVar . protobufName in + let wrap = HsVar . protobufASTName in case ty of Named n -> apply namedC [ dpIdentE n ] Int32 -> wrap "Int32" @@ -1789,18 +1914,24 @@ Float -> wrap "Float" Double -> wrap "Double" -defaultImports :: Bool -> [HsImportDecl] -defaultImports usesGrpc = +data ImportCustomisation = ImportCustomisation + { icStringType :: StringType + , icUsesGrpc :: Bool + } + +defaultImports :: RecordStyle -> ImportCustomisation -> [HsImportDecl] +defaultImports recordStyle ImportCustomisation{ icUsesGrpc, icStringType = StringType stringModule stringType} = [ 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.DotProto") & qualified protobufASTNS & 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 "Proto3.Wire.Decode") & qualified protobufNS & selecting [i"Parser", i"RawField"] , importDecl_ (m "Control.Applicative") & qualified haskellNS & everything , importDecl_ (m "Control.Applicative") & unqualified & selecting [s"<*>", s"<|>", s"<$>"] , importDecl_ (m "Control.DeepSeq") & qualified haskellNS & everything @@ -1812,20 +1943,30 @@ , 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 stringModule) & qualified haskellNS & selecting [i stringType] , 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 "Google.Protobuf.Wrappers.Polymorphic") & qualified protobufNS & selecting [HsIThingAll (HsIdent "Wrapped")] , importDecl_ (m "Unsafe.Coerce") & qualified haskellNS & everything ] <> - (if not usesGrpc then [] else + (if not icUsesGrpc 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"] ]) + <> + case recordStyle of + RegularRecords -> [] + LargeRecords -> + [ importDecl_ (m "Data.Record.Generic") & qualified lrNS & everything + , importDecl_ (m "Data.Record.Generic.Rep") & qualified lrNS & everything + , importDecl_ (m "Data.Record.Generic.Rep.Internal") & qualified lrNS & everything + , importDecl_ (m "Data.Record.Plugin.Runtime") & qualified lrNS & everything + ] where m = Module i = HsIVar . HsIdent @@ -1833,7 +1974,9 @@ grpcNS = m "HsGRPC" jsonpbNS = m "HsJSONPB" + lrNS = m "LR" protobufNS = m "HsProtobuf" + protobufASTNS = m "HsProtobufAST" proxyNS = m "Proxy" -- staged constructors for importDecl @@ -1856,88 +1999,11 @@ 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" ] +defaultMessageDeriving = map haskellName [ "Show", "Eq", "Ord", "Generic" ] 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 defaultSrcLoc - -importDecl_ :: Module -> Bool -> Maybe Module -> Maybe (Bool, [HsImportSpec]) -> HsImportDecl -importDecl_ = HsImportDecl defaultSrcLoc - -dataDecl_ :: String -> [HsConDecl] -> [HsQName] -> HsDecl -dataDecl_ messageName [constructor@(HsRecDecl _ _ [_])] = - HsNewTypeDecl defaultSrcLoc [] (HsIdent messageName) [] constructor -dataDecl_ messageName constructors = - HsDataDecl defaultSrcLoc [] (HsIdent messageName) [] constructors - -recDecl_ :: HsName -> [([HsName], HsBangType)] -> HsConDecl -recDecl_ = HsRecDecl defaultSrcLoc - -conDecl_ :: HsName -> [HsBangType] -> HsConDecl -conDecl_ = HsConDecl defaultSrcLoc - -instDecl_ :: HsQName -> [HsType] -> [HsDecl] -> HsDecl -instDecl_ = HsInstDecl defaultSrcLoc [] - -match_ :: HsName -> [HsPat] -> HsRhs -> [HsDecl] -> HsMatch -match_ = HsMatch defaultSrcLoc - -unqual_ :: String -> HsQName -unqual_ = UnQual . HsIdent - -uvar_ :: String -> HsExp -uvar_ = HsVar . unqual_ - -protobufType_, primType_, protobufWrapperType_ :: String -> HsType -protobufType_ = HsTyCon . protobufName -primType_ = HsTyCon . haskellName -protobufWrapperType_ = HsTyCon . protobufWrapperName - -type_ :: String -> HsType -type_ = HsTyCon . unqual_ - -patVar :: String -> HsPat -patVar = HsPVar . HsIdent - -alt_ :: HsPat -> HsGuardedAlts -> [HsDecl] -> HsAlt -alt_ = HsAlt defaultSrcLoc - -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 --- pretty-printed output -defaultSrcLoc :: SrcLoc -defaultSrcLoc = SrcLoc "" 0 0 - -__nowarn_unused :: a -__nowarn_unused = subfieldType `undefined` subfieldOptions `undefined` oneofType diff --git a/src/Proto3/Suite/DotProto/Generate/LargeRecord.hs b/src/Proto3/Suite/DotProto/Generate/LargeRecord.hs new file mode 100644 --- /dev/null +++ b/src/Proto3/Suite/DotProto/Generate/LargeRecord.hs @@ -0,0 +1,22 @@ +{- | This module provides functions to generate Haskell records using + the large-records library. +-} +module Proto3.Suite.DotProto.Generate.LargeRecord where + +import Language.Haskell.Syntax +import Proto3.Suite.DotProto.Generate.Syntax + +isLargeRecord :: HsDecl -> Bool +isLargeRecord (HsDataDecl _ _ _ _ [HsRecDecl _ _ (_fld1:_fld2:_)] _) = True +isLargeRecord _ = False + +-- | Generate 'NFData' instance for a type using large-generics +nfDataInstD :: HsDecl -> String -> HsDecl +nfDataInstD typeDecl typeName = + instDecl_ (haskellName "NFData") + [ type_ typeName ] + [ HsFunBind [rnfDecl] | isLargeRecord typeDecl ] + where + rnfDecl = match_ (HsIdent "rnf") [] + (HsUnGuardedRhs (HsVar (lrName "grnf"))) + [] diff --git a/src/Proto3/Suite/DotProto/Generate/Record.hs b/src/Proto3/Suite/DotProto/Generate/Record.hs new file mode 100644 --- /dev/null +++ b/src/Proto3/Suite/DotProto/Generate/Record.hs @@ -0,0 +1,14 @@ +{- | This module provides functions to generate regular Haskell records + without using the large-records library. +-} +module Proto3.Suite.DotProto.Generate.Record where + +import Language.Haskell.Syntax +import Proto3.Suite.DotProto.Generate.Syntax + +-- | Generate 'NFData' instance for a type using GHC generics +nfDataInstD :: HsDecl -> String -> HsDecl +nfDataInstD _ typeName = + instDecl_ (haskellName "NFData") + [ type_ typeName ] + [] 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,11 +1,15 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE MonoLocalBinds #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-} @@ -13,7 +17,6 @@ -- describe JSONPB encodings for protobuf types. module Proto3.Suite.DotProto.Generate.Swagger ( ppSchema - , OverrideToSchema(..) , asProxy , insOrdFromList ) @@ -24,25 +27,24 @@ #else import Control.Lens ((&), (.~), (?~)) #endif -import Data.Aeson (Value (String), ToJSONKey, - ToJSONKeyFunction(..)) -import qualified Data.Aeson as Aeson +import Data.Aeson (Value (String)) import Data.Aeson.Encode.Pretty (encodePretty) -import qualified Data.ByteString as B import qualified Data.ByteString.Lazy.Char8 as LC8 import Data.Hashable (Hashable) import Data.HashMap.Strict.InsOrd (InsOrdHashMap) import qualified Data.HashMap.Strict.InsOrd -import Data.Map (Map) import Data.Swagger import qualified Data.Text as T import Data.Proxy import qualified Data.Vector as V import GHC.Exts (Proxy#, proxy#) -import GHC.Int -import GHC.Word +import Google.Protobuf.Wrappers.Polymorphic (Wrapped(..)) import Proto3.Suite (Enumerated (..), Finite (..), - Fixed (..), Named (..), enumerate) + Fixed (..), Named (..), + Nested (..), NestedVec (..), + PackedVec (..), Signed (..), + UnpackedVec (..), enumerate) +import qualified Proto3.Suite.Types import Proto3.Suite.DotProto.Generate.Swagger.Wrappers () -- | Convenience re-export so that users of generated code don't have to add @@ -50,47 +52,38 @@ insOrdFromList :: (Eq k, Hashable k) => [(k, v)] -> InsOrdHashMap k v insOrdFromList = Data.HashMap.Strict.InsOrd.fromList -{-| This is a hack to work around the `swagger2` library forbidding `ToSchema` - instances for `ByteString`s --} -newtype OverrideToSchema a = OverrideToSchema { unOverride :: a } +-- Distinctions between varint and fixed-width formats do not matter to JSONPB. +deriving via a instance ToSchema a => ToSchema (Fixed a) -instance {-# OVERLAPPABLE #-} ToSchema a => ToSchema (OverrideToSchema a) where - declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy a) +-- Zig-zag encoding issues do not matter to JSONPB. +deriving via a instance ToSchema a => ToSchema (Signed a) -instance {-# OVERLAPPING #-} ToSchema (OverrideToSchema B.ByteString) where - declareNamedSchema _ = return (NamedSchema Nothing byteSchema) +-- Packed/unpacked distinctions do not matter to JSONPB. +deriving via (V.Vector a) instance ToSchema a => ToSchema (NestedVec a) +deriving via (V.Vector a) instance ToSchema a => ToSchema (PackedVec a) +deriving via (V.Vector a) instance ToSchema a => ToSchema (UnpackedVec a) -instance {-# OVERLAPPING #-} ToSchema (OverrideToSchema (V.Vector B.ByteString)) where - 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) +-- Unless and until the overlapping instances for @Maybe (Wrapped _)@ +-- are selected, the schema is unaffected by 'Wrapped'. +deriving via a instance ToSchema a => ToSchema (Wrapped a) -instance {-# OVERLAPPING #-} (ToJSONKey k, ToSchema k) => ToSchema (OverrideToSchema (Map k B.ByteString)) where - declareNamedSchema _ = case Aeson.toJSONKey :: ToJSONKeyFunction k of - ToJSONKeyText _ _ -> do - return (NamedSchema Nothing schema_) - ToJSONKeyValue _ _ -> do - declareNamedSchema (Proxy :: Proxy [(k, (OverrideToSchema B.ByteString))]) - where - schema_ = mempty -#if MIN_VERSION_swagger2(2,4,0) - & type_ ?~ SwaggerObject -#else - & type_ .~ SwaggerObject -#endif - & additionalProperties ?~ AdditionalPropertiesSchema (Inline byteSchema) +instance ToSchema (Proto3.Suite.Types.String a) where + declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy String) +instance ToSchema (Proto3.Suite.Types.Bytes a) where + declareNamedSchema _ = pure (NamedSchema Nothing byteSchema) + +-- Note that the context is @ToSchema (Maybe a)@, NOT @ToSchema a@. +-- This design keeps this instance from bypassing overlapping +-- instances such as @ToSchema (Maybe (Wrapped Bool))@ that +-- are included by cabal flag @-fswagger-wrapper-format@. +-- We use MonoLocalBinds to avoid the resultant compiler warning. +deriving via (Maybe a) instance ToSchema (Maybe a) => ToSchema (Nested a) + {-| This is a convenience function that uses type inference to select the correct instance of `ToSchema` to use for fields of a message -} -asProxy :: (Proxy (OverrideToSchema a) -> b) -> Proxy a +asProxy :: (Proxy a -> b) -> Proxy a asProxy _ = Proxy -- | Pretty-prints a schema. Useful when playing around with schemas in the @@ -112,15 +105,3 @@ & type_ .~ SwaggerString #endif & enum_ ?~ fmap String enumMemberNames - -instance ToSchema (Fixed Int32) where - declareNamedSchema _ = declareNamedSchema (Proxy @Int32) - -instance ToSchema (Fixed Int64) where - declareNamedSchema _ = declareNamedSchema (Proxy @Int64) - -instance ToSchema (Fixed Word32) where - declareNamedSchema _ = declareNamedSchema (Proxy @Word32) - -instance ToSchema (Fixed Word64) where - declareNamedSchema _ = declareNamedSchema (Proxy @Word64) diff --git a/src/Proto3/Suite/DotProto/Generate/Swagger.hs-boot b/src/Proto3/Suite/DotProto/Generate/Swagger.hs-boot deleted file mode 100644 --- a/src/Proto3/Suite/DotProto/Generate/Swagger.hs-boot +++ /dev/null @@ -1,6 +0,0 @@ -module Proto3.Suite.DotProto.Generate.Swagger - ( OverrideToSchema (..) - ) -where - -newtype OverrideToSchema a = OverrideToSchema { unOverride :: a } diff --git a/src/Proto3/Suite/DotProto/Generate/Syntax.hs b/src/Proto3/Suite/DotProto/Generate/Syntax.hs new file mode 100644 --- /dev/null +++ b/src/Proto3/Suite/DotProto/Generate/Syntax.hs @@ -0,0 +1,179 @@ +{-| Utilities to manipulate Haskell AST -} +module Proto3.Suite.DotProto.Generate.Syntax where + +import Language.Haskell.Syntax + +haskellName, jsonpbName, grpcName, lrName, protobufName, protobufASTName, proxyName :: String -> HsQName +haskellName name = Qual (Module "Hs") (HsIdent name) +jsonpbName name = Qual (Module "HsJSONPB") (HsIdent name) +grpcName name = Qual (Module "HsGRPC") (HsIdent name) +lrName name = Qual (Module "LR") (HsIdent name) +protobufName name = Qual (Module "HsProtobuf") (HsIdent name) +protobufASTName name = Qual (Module "HsProtobufAST") (HsIdent name) +proxyName name = Qual (Module "Proxy") (HsIdent name) + +haskellNS :: Module +haskellNS = Module "Hs" + +-------------------------------------------------------------------------------- +-- +-- * Wrappers around haskell-src-exts constructors +-- + +apply :: HsExp -> [HsExp] -> HsExp +apply f = paren . foldl HsApp f + +maybeModify :: HsExp -> Maybe HsExp -> HsExp +maybeModify x Nothing = x +maybeModify x (Just f) = paren (HsApp f (paren x)) + +paren :: HsExp -> HsExp +paren e@(HsParen _) = e +paren e = HsParen e + +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 defaultSrcLoc + +importDecl_ :: Module -> Bool -> Maybe Module -> Maybe (Bool, [HsImportSpec]) -> HsImportDecl +importDecl_ = HsImportDecl defaultSrcLoc + +dataDecl_ :: String -> [HsConDecl] -> [HsQName] -> HsDecl +dataDecl_ messageName [constructor@(HsRecDecl _ _ [_])] = + HsNewTypeDecl defaultSrcLoc [] (HsIdent messageName) [] constructor +dataDecl_ messageName constructors = + HsDataDecl defaultSrcLoc [] (HsIdent messageName) [] constructors + +recDecl_ :: HsName -> [([HsName], HsBangType)] -> HsConDecl +recDecl_ = HsRecDecl defaultSrcLoc + +conDecl_ :: HsName -> [HsBangType] -> HsConDecl +conDecl_ = HsConDecl defaultSrcLoc + +instDecl_ :: HsQName -> [HsType] -> [HsDecl] -> HsDecl +instDecl_ = HsInstDecl defaultSrcLoc [] + +match_ :: HsName -> [HsPat] -> HsRhs -> [HsDecl] -> HsMatch +match_ = HsMatch defaultSrcLoc + +unqual_ :: String -> HsQName +unqual_ = UnQual . HsIdent + +uvar_ :: String -> HsExp +uvar_ = HsVar . unqual_ + +protobufType_, primType_, protobufStringType_, protobufBytesType_ :: String -> HsType +protobufType_ = HsTyCon . protobufName +primType_ = HsTyCon . haskellName +protobufStringType_ = HsTyApp (protobufType_ "String") . HsTyCon . haskellName +protobufBytesType_ = HsTyApp (protobufType_ "Bytes") . HsTyCon . haskellName + +protobufFixedType_, protobufSignedType_, protobufWrappedType_ :: HsType -> HsType +protobufFixedType_ = HsTyApp (protobufType_ "Fixed") +protobufSignedType_ = HsTyApp (protobufType_ "Signed") +protobufWrappedType_ = HsTyApp (HsTyCon (protobufName "Wrapped")) + +type_ :: String -> HsType +type_ = HsTyCon . unqual_ + +patVar :: String -> HsPat +patVar = HsPVar . HsIdent + +alt_ :: HsPat -> HsGuardedAlts -> [HsDecl] -> HsAlt +alt_ = HsAlt defaultSrcLoc + +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 +-- pretty-printed output +defaultSrcLoc :: SrcLoc +defaultSrcLoc = SrcLoc "" 0 0 + +-------------------------------------------------------------------------------- +-- +-- * Common Haskell expressions, constructors, and operators +-- + +dotProtoFieldC, primC, repeatedC, nestedRepeatedC, namedC, mapC, + fieldNumberC, singleC, dotsC, pathC, qualifiedC, anonymousC, dotProtoOptionC, + identifierC, stringLitC, intLitC, floatLitC, boolLitC, trueC, falseC, + nothingC, justC, forceEmitC, mconcatE, encodeMessageFieldE, + fromStringE, decodeMessageFieldE, pureE, returnE, memptyE, msumE, atE, oneofE, + fmapE :: HsExp + +dotProtoFieldC = HsVar (protobufASTName "DotProtoField") +primC = HsVar (protobufASTName "Prim") +repeatedC = HsVar (protobufASTName "Repeated") +nestedRepeatedC = HsVar (protobufASTName "NestedRepeated") +namedC = HsVar (protobufASTName "Named") +mapC = HsVar (protobufASTName "Map") +fieldNumberC = HsVar (protobufName "FieldNumber") +singleC = HsVar (protobufASTName "Single") +pathC = HsVar (protobufASTName "Path") +dotsC = HsVar (protobufASTName "Dots") +qualifiedC = HsVar (protobufASTName "Qualified") +anonymousC = HsVar (protobufASTName "Anonymous") +dotProtoOptionC = HsVar (protobufASTName "DotProtoOption") +identifierC = HsVar (protobufASTName "Identifier") +stringLitC = HsVar (protobufASTName "StringLit") +intLitC = HsVar (protobufASTName "IntLit") +floatLitC = HsVar (protobufASTName "FloatLit") +boolLitC = HsVar (protobufASTName "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") + +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 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 @@ -20,6 +20,7 @@ import Control.Lens (Lens', lens, over) import Control.Lens.Cons (_head) import Control.Monad +import Control.Monad.IO.Class import Control.Monad.Except import Data.Bifunctor (first) import Data.Char @@ -42,7 +43,8 @@ import Proto3.Wire.Types (FieldNumber (..)) import System.FilePath (isPathSeparator) import Text.Parsec (ParseError) -import qualified Turtle +import qualified Turtle hiding (absolute, collapse) +import qualified Turtle.Compat as Turtle (absolute, collapse) import Turtle (ExitCode (..), FilePath, Text, ()) import Turtle.Format ((%)) @@ -678,7 +680,3 @@ 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 @@ -11,8 +11,21 @@ {-# OPTIONS_GHC -fno-warn-unused-do-bind #-} module Proto3.Suite.DotProto.Parsing - ( parseProto + ( ProtoParser + , runProtoParser + , parseProto , parseProtoFile + + -- * Option Parsers + , pOptionStmt + , pFieldOptions + , pFieldOptionStmt + , pOptionId + , pOptionKw + + -- * Extension Parsers + , pExtendStmt + , pExtendKw ) where import Prelude hiding (fail) @@ -24,6 +37,8 @@ #if !MIN_VERSION_base(4,13,0) import Control.Monad.Fail #endif +import qualified Data.Char as Char +import Data.List.NonEmpty (NonEmpty ((:|))) import qualified Data.List.NonEmpty as NE import Data.Functor import qualified Data.Text as T @@ -31,12 +46,13 @@ import Proto3.Wire.Types (FieldNumber(..)) import Text.Parsec (parse, ParseError) import Text.Parsec.String (Parser) -import Text.Parser.Char +import Text.Parser.Char hiding (digit, hexDigit) import Text.Parser.Combinators import Text.Parser.LookAhead import Text.Parser.Token import qualified Text.Parser.Token.Style as TokenStyle -import qualified Turtle +import qualified Turtle hiding (encodeString, fromText) +import qualified Turtle.Compat as Turtle (encodeString, fromText) ---------------------------------------- -- interfaces @@ -107,21 +123,75 @@ globalIdentifier :: ProtoParser DotProtoIdentifier globalIdentifier = token $ string "." >> _identifier --- Parses a nested identifier, consuming trailing space. -nestedIdentifier :: ProtoParser DotProtoIdentifier -nestedIdentifier = token $ do - h <- parens _identifier - string "." - t <- _identifier - return $ Qualified h t - ---------------------------------------- -- values --- [issue] these string parsers are weak to \" and \000 octal codes -stringLit :: ProtoParser String -stringLit = stringLiteral <|> stringLiteral' +strLit :: ProtoParser String +strLit = doubleQuotedLiteral <|> singleQuotedLiteral + where + doubleQuotedLiteral = + between (char '"') (char '"') (many character) + where + character = + escape <|> satisfy (\c -> c `notElem` [ '\0', '\n', '\\', '"' ]) + singleQuotedLiteral = + between (char '\'') (char '\'') (many character) + where + character = + escape <|> satisfy (\c -> c `notElem` [ '\0', '\n', '\\', '\'' ]) + + escape = do + char '\\' + hexEscape <|> octEscape <|> charEscape + + hexEscape = do + (char 'x' <|> char 'X') + digit0 <- hexDigit + digit1 <- hexDigit + let number = 16 * digit0 + digit1 + return (Char.chr number) + + octEscape = do + digit0 <- octalDigit + digit1 <- octalDigit + digit2 <- octalDigit + let number = 64 * digit0 + 8 * digit1 + digit2 + return (Char.chr number) + + charEscape = + '\a' <$ char 'a' + <|> '\b' <$ char 'b' + <|> '\f' <$ char 'f' + <|> '\n' <$ char 'n' + <|> '\r' <$ char 'r' + <|> '\t' <$ char 't' + <|> '\v' <$ char 'v' + <|> '\\' <$ char '\\' + <|> '\'' <$ char '\'' + <|> '"' <$ char '"' + +digit :: ProtoParser Int +digit = do + c <- satisfy (\c -> '0' <= c && c <= '9') + return (Char.ord c - Char.ord '0') + +hexDigit :: ProtoParser Int +hexDigit = digit <|> lowercase <|> uppercase + where + lowercase = do + c <- satisfy (\c -> 'a' <= c && c <= 'f') + return (Char.ord c - Char.ord 'a') + + uppercase = do + c <- satisfy (\c -> 'A' <= c && c <= 'F') + return (Char.ord c - Char.ord 'A') + +octalDigit :: ProtoParser Int +octalDigit = do + c <- satisfy (\c -> '0' <= c && c <= '7') + return (Char.ord c - Char.ord '0') + bool :: ProtoParser Bool bool = token $ lit "true" True <|> lit "false" False where @@ -135,7 +205,7 @@ value :: ProtoParser DotProtoValue value = try (BoolLit <$> bool) - <|> try (StringLit <$> stringLit) + <|> try (StringLit <$> strLit) <|> try (FloatLit <$> floatLit) <|> try (IntLit . fromInteger <$> integer) <|> try (Identifier <$> identifier) @@ -192,26 +262,33 @@ adapt _ = DotProtoNoPackage topLevel :: Path -> ProtoParser DotProto -topLevel modulePath = do whiteSpace - syntaxSpec - sortStatements modulePath <$> many topStatement +topLevel modulePath = do + whiteSpace + syntaxSpec + dotProto <- sortStatements modulePath <$> many topStatement + eof + return dotProto -------------------------------------------------------------------------------- -- top-level statements topStatement :: ProtoParser DotProtoStatement -topStatement = DPSImport <$> import_ - <|> DPSPackage <$> package - <|> DPSOption <$> topOption - <|> DPSDefinition <$> definition - <|> DPSEmpty <$ empty +topStatement = + choice + [ DPSImport <$> import_ + , DPSPackage <$> package + , DPSOption <$> pOptionStmt + , DPSEmpty <$ try pExtendStmt + , DPSDefinition <$> definition + , DPSEmpty <$ empty + ] import_ :: ProtoParser DotProtoImport import_ = do symbol "import" qualifier <- option DotProtoImportDefault $ symbol "weak" $> DotProtoImportWeak <|> symbol "public" $> DotProtoImportPublic - target <- Turtle.fromText . T.pack <$> stringLit + target <- Turtle.fromText . T.pack <$> strLit semi return $ DotProtoImport qualifier target @@ -222,34 +299,92 @@ return $ DotProtoPackageSpec p definition :: ProtoParser DotProtoDefinition -definition = message - <|> enum - <|> service +definition = + choice + [ try message + , try enum + , service + ] -------------------------------------------------------------------------------- -- options -inlineOption :: ProtoParser DotProtoOption -inlineOption = DotProtoOption <$> (optionName <* symbol "=") <*> value - where - optionName = nestedIdentifier <|> identifier +-- | Parses a protobuf option that could appear in a service, RPC, message, +-- enumeration, or at the top-level. +-- +-- @since 0.5.2 +pOptionStmt :: ProtoParser DotProtoOption +pOptionStmt = token (between pOptionKw (token semi) pFieldOptionStmt) -optionAnnotation :: ProtoParser [DotProtoOption] -optionAnnotation = brackets (commaSep1 inlineOption) <|> pure [] +-- | Parses zero or more message field options enclosed in square braces. +-- +-- @since 0.5.2 +pFieldOptions :: ProtoParser [DotProtoOption] +pFieldOptions = pOptions <|> pure [] + where + pOptions :: ProtoParser [DotProtoOption] + pOptions = between lbracket rbracket (commaSep1 (token pFieldOptionStmt)) -topOption :: ProtoParser DotProtoOption -topOption = symbol "option" *> inlineOption <* semi + lbracket :: ProtoParser () + lbracket = token (char '[' $> ()) "left bracket" + rbracket :: ProtoParser () + rbracket = token (char ']' $> ()) "right bracket" + +-- | Parses a protobuf option in the context of a message field's options. +-- +-- @since 0.5.2 +pFieldOptionStmt :: ProtoParser DotProtoOption +pFieldOptionStmt = token $ do + idt <- pOptionId + token (char '=') + val <- value + pure (DotProtoOption idt val) + +-- | Parses a (qualified) identifier for a protobuf option. +-- +-- @since 0.5.2 +pOptionId :: ProtoParser DotProtoIdentifier +pOptionId = + choice + [ try pOptionQName + , try (parens pOptionName) + , pOptionName + ] + where + pOptionName :: ProtoParser DotProtoIdentifier + pOptionName = token $ do + nm <- identifierName + nms <- many (char '.' *> identifierName) + if null nms + then pure (Single nm) + else pure (Dots (Path (nm :| nms))) + + pOptionQName :: ProtoParser DotProtoIdentifier + pOptionQName = token $ do + idt <- parens pOptionName + nms <- char '.' *> pOptionName + pure (Qualified idt nms) + +-- | Parses a single keyword token "option". +-- +-- @since 0.5.2 +pOptionKw :: ProtoParser () +pOptionKw = do + spaces + token (string "option" >> notFollowedBy alphaNum) + "keyword 'option'" + -------------------------------------------------------------------------------- -- service statements servicePart :: ProtoParser DotProtoServicePart servicePart = DotProtoServiceRPCMethod <$> rpc - <|> DotProtoServiceOption <$> topOption + <|> DotProtoServiceOption <$> pOptionStmt <|> DotProtoServiceEmpty <$ empty rpcOptions :: ProtoParser [DotProtoOption] -rpcOptions = braces $ many topOption +rpcOptions = braces $ many pOptionStmt rpcClause :: ProtoParser (DotProtoIdentifier, Streaming) rpcClause = do @@ -293,7 +428,7 @@ <|> try (DotProtoMessageDefinition <$> message) <|> try messageOneOf <|> try (DotProtoMessageField <$> messageField) - <|> try (DotProtoMessageOption <$> topOption) + <|> try (DotProtoMessageOption <$> pOptionStmt) messageType :: ProtoParser DotProtoType messageType = try mapType <|> try repType <|> (Prim <$> primType) @@ -310,7 +445,7 @@ mname <- identifier symbol "=" mnumber <- fieldNumber - moptions <- optionAnnotation + moptions <- pFieldOptions semi return $ DotProtoField mnumber mtype mname moptions mempty @@ -321,13 +456,13 @@ enumField = do fname <- identifier symbol "=" fpos <- fromInteger <$> integer - opts <- optionAnnotation + opts <- pFieldOptions semi return $ DotProtoEnumField fname fpos opts enumStatement :: ProtoParser DotProtoEnumPart -enumStatement = try (DotProtoEnumOption <$> topOption) +enumStatement = try (DotProtoEnumOption <$> pOptionStmt) <|> enumField <|> empty $> DotProtoEnumEmpty @@ -352,6 +487,29 @@ reservedField :: ProtoParser [DotProtoReservedField] reservedField = do symbol "reserved" - v <- ranges <|> commaSep1 (ReservedIdentifier <$> stringLit) + v <- ranges <|> commaSep1 (ReservedIdentifier <$> strFieldName) semi return v + +strFieldName :: ProtoParser String +strFieldName = + between (char '"') (char '"') identifierName + <|> between (char '\'') (char '\'') identifierName + +-- Message Extensions ---------------------------------------------------------- + +pExtendStmt :: ProtoParser (DotProtoIdentifier, [DotProtoMessagePart]) +pExtendStmt = do + pExtendKw + idt <- identifier + fxs <- braces (many messagePart) + pure (idt, fxs) + +-- | Parses a single keyword token "extend". +-- +-- @since 0.5.2 +pExtendKw :: ProtoParser () +pExtendKw = do + spaces + token (string "extend" >> notFollowedBy alphaNum) + "keyword 'extend'" 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 @@ -21,7 +21,6 @@ import Data.Char import qualified Data.List.NonEmpty as NE -import qualified Data.Text as T #if (MIN_VERSION_base(4,11,0)) import Prelude hiding ((<>)) #endif @@ -30,7 +29,7 @@ import Text.PrettyPrint (($$), (<+>), (<>)) import qualified Text.PrettyPrint as PP import Text.PrettyPrint.HughesPJClass (Pretty(..)) -import Turtle (toText) +import Turtle.Compat (encodeString) -- | Options for rendering a @.proto@ file. data RenderingOptions = RenderingOptions @@ -68,17 +67,24 @@ $$ (PP.vcat $ topOption <$> protoOptions) $$ (PP.vcat $ prettyPrintProtoDefinition opts <$> protoDefinitions) +strLit :: String -> PP.Doc +strLit string = PP.text "\"" <> foldMap escape string <> PP.text "\"" + where + escape '\n' = PP.text "\\n" + escape '\\' = PP.text "\\\\" + escape '\0' = PP.text "\\x00" + escape '"' = PP.text "\\\"" + escape c = PP.text [ c ] + instance Pretty DotProtoPackageSpec where pPrint (DotProtoPackageSpec p) = PP.text "package" <+> pPrint p <> PP.text ";" pPrint (DotProtoNoPackage) = PP.empty instance Pretty DotProtoImport where pPrint (DotProtoImport q i) = - PP.text "import" <+> pPrint q <+> PP.text fp <> PP.text ";" + PP.text "import" <+> pPrint q <+> strLit fp <> PP.text ";" where - fp = case T.unpack . either id id . toText $ i of - [] -> show ("" :: String) - x -> x + fp = encodeString i instance Pretty DotProtoImportQualifier where pPrint DotProtoImportDefault = PP.empty @@ -180,7 +186,7 @@ instance Pretty DotProtoValue where pPrint (Identifier value) = pPrint value - pPrint (StringLit value) = PP.text $ show value + pPrint (StringLit value) = strLit value pPrint (IntLit value) = PP.text $ show value pPrint (FloatLit value) = PP.text $ show value pPrint (BoolLit value) = PP.text $ toLower <$> show value diff --git a/src/Proto3/Suite/JSONPB.hs b/src/Proto3/Suite/JSONPB.hs --- a/src/Proto3/Suite/JSONPB.hs +++ b/src/Proto3/Suite/JSONPB.hs @@ -40,7 +40,6 @@ , Swagger.ParamSchema(..) , Swagger.SwaggerType(..) , Swagger.declareSchemaRef - , Proto3.Suite.DotProto.Generate.Swagger.OverrideToSchema(..) , Proto3.Suite.DotProto.Generate.Swagger.asProxy , Proto3.Suite.DotProto.Generate.Swagger.insOrdFromList #endif 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,17 +1,19 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE OverloadedLists #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -- | Support for the "JSONPB" canonical JSON encoding described at --- https://developers.google.com/protocol-buffers/docs/proto3#json. +-- . -- -- This modules provides 'Data.Aeson'-like helper functions, typeclasses, and -- instances for converting to and from values of types which have a JSONPB @@ -80,14 +82,14 @@ Series, explicitParseField, explicitParseFieldMaybe, - object, typeMismatch) + object, toJSONKeyText, + typeMismatch,) import qualified Data.Attoparsec.ByteString as Atto (skipWhile) import qualified Data.Attoparsec.ByteString.Char8 as Atto (Parser, endOfInput) import qualified Data.Binary.Builder as Builder import qualified Data.ByteString as BS import qualified Data.ByteString.Base64 as B64 import qualified Data.ByteString.Lazy as LBS -import Data.Coerce import Data.Maybe import qualified Data.Map as M import Data.Text (Text) @@ -95,14 +97,20 @@ import qualified Data.Text.Encoding as T import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy.Encoding as TL +import qualified Data.Text.Short as TS 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 Google.Protobuf.Wrappers.Polymorphic (Wrapped(..)) import Proto3.Suite.Class (HasDefault (def, isDefault), Named (nameOf)) -import Proto3.Suite.Types (Enumerated (..), Fixed (..)) +import Proto3.Suite.Types (Enumerated(..), Fixed(..), + Nested(..), NestedVec(..), + PackedVec(..), Signed(..), + UnpackedVec(..)) +import qualified Proto3.Suite.Types import Proto3.Wire.Class (ProtoEnum(..)) import Test.QuickCheck.Arbitrary (Arbitrary(..)) @@ -145,6 +153,12 @@ instance FromJSONPB A.Value where parseJSONPB = pure +-- | JSONPB format shortcuts Google wrappers types. +deriving via a instance FromJSONPB a => FromJSONPB (Wrapped a) + +-- | JSONPB format shortcuts Google wrappers types. +deriving via a instance ToJSONPB a => ToJSONPB (Wrapped a) + -- * JSONPB codec entry points -- | 'Data.Aeson.encode' variant for serializing a JSONPB value as a lazy @@ -222,7 +236,7 @@ data Options = Options { optEmitDefaultValuedFields :: Bool , optEmitNamedOneof :: Bool - -- ^ For compatibility with the Go JSONPB implementation. + -- ^ For compatibility with the Go, C++, and Python JSONPB implementations. -- -- If 'False', the following message -- @@ -353,7 +367,7 @@ -- or strings are accepted. -- --- int32 / sint32 +-- int32 / sint32 / sfixed32 instance ToJSONPB Int32 where toJSONPB = const . A.toJSON toEncodingPB = const . A.toEncoding @@ -361,7 +375,7 @@ instance FromJSONPB Int32 where parseJSONPB = parseNumOrDecimalString "int32 / sint32" --- uint32 +-- uint32 / fixed32 instance ToJSONPB Word32 where toJSONPB = const . A.toJSON toEncodingPB = const . A.toEncoding @@ -369,47 +383,27 @@ instance FromJSONPB Word32 where parseJSONPB = parseNumOrDecimalString "uint32" --- int64 / sint64 +-- int64 / sint64 / sfixed64 instance ToJSONPB Int64 where toJSONPB x _ = A.String . T.pack . show $ x toEncodingPB x _ = E.string (show x) instance FromJSONPB Int64 where parseJSONPB = parseNumOrDecimalString "int64 / sint64" --- unit64 +-- unit64 / fixed64 instance ToJSONPB Word64 where toJSONPB x _ = A.String . T.pack . show $ x toEncodingPB x _ = E.string (show x) instance FromJSONPB Word64 where parseJSONPB = parseNumOrDecimalString "int64 / sint64" --- fixed32 -instance ToJSONPB (Fixed Word32) where - toJSONPB = coerce (toJSONPB @Word32) - toEncodingPB = coerce (toEncodingPB @Word32) -instance FromJSONPB (Fixed Word32) where - parseJSONPB = coerce (parseJSONPB @Word32) - --- fixed64 -instance ToJSONPB (Fixed Word64) where - toJSONPB = coerce (toJSONPB @Word64) - toEncodingPB = coerce (toEncodingPB @Word64) -instance FromJSONPB (Fixed Word64) where - parseJSONPB = coerce (parseJSONPB @Word64) - --- sfixed32 -instance ToJSONPB (Fixed Int32) where - toJSONPB = coerce (toJSONPB @Int32) - toEncodingPB = coerce (toEncodingPB @Int32) -instance FromJSONPB (Fixed Int32) where - parseJSONPB = coerce (parseJSONPB @Int32) +-- Distinctions between varint and fixed-width formats do not matter to JSONPB. +deriving via a instance FromJSONPB a => FromJSONPB (Fixed a) +deriving via a instance ToJSONPB a => ToJSONPB (Fixed a) --- sfixed64 -instance ToJSONPB (Fixed Int64) where - toJSONPB = coerce (toJSONPB @Int64) - toEncodingPB = coerce (toEncodingPB @Int64) -instance FromJSONPB (Fixed Int64) where - parseJSONPB = coerce (parseJSONPB @Int64) +-- Zig-zag encoding issues do not matter to JSONPB. +deriving via a instance FromJSONPB a => FromJSONPB (Signed a) +deriving via a instance ToJSONPB a => ToJSONPB (Signed a) -------------------------------------------------------------------------------- -- Floating point scalar types @@ -437,12 +431,27 @@ -- Stringly types (string and bytes) -- string +instance ToJSONPB T.Text where + toJSONPB = const . A.toJSON + toEncodingPB = const . A.toEncoding +instance FromJSONPB T.Text where + parseJSONPB = A.parseJSON + instance ToJSONPB TL.Text where toJSONPB = const . A.toJSON toEncodingPB = const . A.toEncoding instance FromJSONPB TL.Text where parseJSONPB = A.parseJSON +instance ToJSONPB TS.ShortText where + toJSONPB = toJSONPB . TS.toText + toEncodingPB = toEncodingPB . TS.toText +instance FromJSONPB TS.ShortText where + parseJSONPB = fmap TS.fromText . A.parseJSON + +deriving via a instance ToJSONPB a => ToJSONPB (Proto3.Suite.Types.String a) +deriving via a instance FromJSONPB a => FromJSONPB (Proto3.Suite.Types.String a) + -- bytes bsToJSONPB :: BS.ByteString -> A.Value @@ -460,48 +469,39 @@ parseJSONPB (A.String b64enc) = pure . B64.decodeLenient . T.encodeUtf8 $ b64enc parseJSONPB v = A.typeMismatch "bytes" v +deriving via a instance ToJSONPB a => ToJSONPB (Proto3.Suite.Types.Bytes a) +deriving via a instance FromJSONPB a => FromJSONPB (Proto3.Suite.Types.Bytes a) + -------------------------------------------------------------------------------- -- Enumerated types enumToJSONPB :: (e -> Options -> a) -- ^ JSONPB encoder function to use - -> a -- ^ null value to use for out-of-range enums + -> (Int32 -> a) -- ^ handles out-of-range enums -> Enumerated e -- ^ the enumerated value to encode -> Options -- ^ JSONPB encoding options -> a -- ^ the JSONPB-encoded value -enumToJSONPB enc null_ (Enumerated e) opts = either err (\input -> enc input opts) e - where - err 0 = error "enumToJSONPB: The first enum value must be zero in proto3" - -- TODO: Raise a compilation error when the first enum value in an - -- enumeration is not zero. - -- - -- See https://github.com/awakesecurity/proto3-suite/issues/28 - -- - -- The proto3 spec states that the default value is the first - -- defined enum value, which must be 0. Since we currently don't - -- raise a compilation error for this like we should, we have to - -- handle this case. - -- - -- For now, die horribly to mimic what should be a compilation - -- error. - err _ = null_ - -- From the JSONPB spec: - -- - -- If a value is missing in the JSON-encoded data or if its value - -- is null, it will be interpreted as the appropriate default - -- value when parsed into a protocol buffer. - -- - -- Thus, interpreting a wire value out of enum range as "missing", - -- we yield null here to mean the default value. - +enumToJSONPB enc outOfRange (Enumerated e) opts = + either outOfRange (\input -> enc input opts) e +-- | If you ask for an unrecognized enumerator code to be emitted, then this +-- instance will emit it numerically, relying upon parser behavior required by: +-- instance ToJSONPB e => ToJSONPB (Enumerated e) where - toJSONPB = enumToJSONPB toJSONPB A.Null - toEncodingPB = enumToJSONPB toEncodingPB E.null_ + toJSONPB = enumToJSONPB toJSONPB (A.Number . fromIntegral) + toEncodingPB = enumToJSONPB toEncodingPB E.int32 +-- | Supports both names and integer codes, as required by: +-- 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 + -- In order to reduce the amount of generated Haskell code we delegate to + -- such code only in the String case, and when converting 'Int32' to @e@. + -- The rest of the parser we implement here, generically. + parseJSONPB A.Null = pure def + parseJSONPB (A.String s) = Enumerated . Right <$> parseJSONPB (A.String s) + parseJSONPB (A.Number n) = fromCode <$> parseJSONPB (A.Number n) + where + fromCode c = Enumerated $ maybe (Left c) Right (toProtoEnumMay c) + parseJSONPB v = fail $ "Expected enumerator name or code, not: " ++ show v -- ** Instances for composite types @@ -519,6 +519,14 @@ parseJSONPB A.Null = pure [] parseJSONPB v = A.typeMismatch "repeated" v +-- Packed/unpacked distinctions do not matter to JSONPB. +deriving via (V.Vector a) instance FromJSONPB a => FromJSONPB (NestedVec a) +deriving via (V.Vector a) instance ToJSONPB a => ToJSONPB (NestedVec a) +deriving via (V.Vector a) instance FromJSONPB a => FromJSONPB (PackedVec a) +deriving via (V.Vector a) instance ToJSONPB a => ToJSONPB (PackedVec a) +deriving via (V.Vector a) instance FromJSONPB a => FromJSONPB (UnpackedVec a) +deriving via (V.Vector a) instance ToJSONPB a => ToJSONPB (UnpackedVec a) + -------------------------------------------------------------------------------- -- Instances for nested messages @@ -529,8 +537,45 @@ parseJSONPB A.Null = pure Nothing parseJSONPB v = fmap Just (parseJSONPB v) +deriving via (Maybe a) instance FromJSONPB a => FromJSONPB (Nested a) +deriving via (Maybe a) instance ToJSONPB a => ToJSONPB (Nested a) + -------------------------------------------------------------------------------- -- Instances for map + +deriving via a instance A.FromJSONKey a => A.FromJSONKey (Fixed a) +deriving via a instance A.ToJSONKey a => A.ToJSONKey (Fixed a) + +deriving via a instance A.FromJSONKey a => A.FromJSONKey (Signed a) +deriving via a instance A.ToJSONKey a => A.ToJSONKey (Signed a) + +deriving via T.Text instance A.FromJSONKey (Proto3.Suite.Types.String T.Text) +deriving via T.Text instance A.ToJSONKey (Proto3.Suite.Types.String T.Text) + +deriving via TL.Text instance A.FromJSONKey (Proto3.Suite.Types.String TL.Text) +deriving via TL.Text instance A.ToJSONKey (Proto3.Suite.Types.String TL.Text) + +#if MIN_VERSION_aeson(2,0,2) + +deriving via TS.ShortText instance A.FromJSONKey (Proto3.Suite.Types.String TS.ShortText) +deriving via TS.ShortText instance A.ToJSONKey (Proto3.Suite.Types.String TS.ShortText) + +#else + +instance A.FromJSON (Proto3.Suite.Types.String TS.ShortText) where + parseJSON = fmap (Proto3.Suite.Types.String . TS.fromText) . A.parseJSON + +instance A.FromJSONKey (Proto3.Suite.Types.String TS.ShortText) where + fromJSONKey = A.FromJSONKeyText (Proto3.Suite.Types.String . TS.fromText) + +instance A.ToJSON (Proto3.Suite.Types.String TS.ShortText) where + toJSON = A.toJSON . TS.toText . Proto3.Suite.Types.string + toEncoding = A.toEncoding . TS.toText . Proto3.Suite.Types.string + +instance A.ToJSONKey (Proto3.Suite.Types.String TS.ShortText) where + toJSONKey = A.toJSONKeyText (TS.toText . Proto3.Suite.Types.string) + +#endif instance (A.ToJSONKey k, ToJSONPB k, ToJSONPB v) => ToJSONPB (M.Map k v) where toJSONPB m opts = A.liftToJSON @(M.Map k) (`toJSONPB` opts) (A.Array . V.fromList . map (`toJSONPB` opts)) m 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 @@ -18,6 +18,10 @@ -- * Enumerable Types , Enumerated(..) + -- * String and Bytes Types + , String(..) + , Bytes(..) + , ForceEmit(..) , Nested(..) , UnpackedVec(..) @@ -34,6 +38,7 @@ import Data.Int (Int32) import qualified Data.Vector as V import GHC.TypeLits (Symbol) +import Prelude hiding (String) import Proto3.Wire.Class (ProtoEnum(..)) import Test.QuickCheck (Arbitrary(..)) @@ -57,6 +62,20 @@ arbitrary = do i <- arbitrary return . Enumerated $ maybe (Left i) Right (toProtoEnumMay i) + +-- | 'String' provides a way to indicate that the given type expresses +-- a Protobuf string scalar. @'String' a@ may have type class instances +-- that are more specific to Protobuf uses than those of @a@. +newtype String a = String { string :: a } + deriving (Show, Eq, Ord, Generic, Monoid, NFData, Arbitrary, + Functor, Foldable, Semigroup, Traversable) + +-- | 'Bytes' provides a way to indicate that the given type expresses +-- a Protobuf bytes scalar. @'Bytes' a@ may have type class instances +-- that are more specific to Protobuf uses than those of @a@. +newtype Bytes a = Bytes { bytes :: a } + deriving (Show, Eq, Ord, Generic, Monoid, NFData, Arbitrary, + Functor, Foldable, Semigroup, Traversable) -- | 'PackedVec' provides a way to encode packed lists of basic protobuf types into -- the wire format. diff --git a/src/Turtle/Compat.hs b/src/Turtle/Compat.hs new file mode 100644 --- /dev/null +++ b/src/Turtle/Compat.hs @@ -0,0 +1,41 @@ +{-# LANGUAGE CPP #-} + +-- | Compatibility module to avoid compiler warnings about deprecation +-- of obsolete Turtle functionality related to FilePath. Once we +-- no longer support pre-1.6 Turtle we can eliminate this module. +module Turtle.Compat + ( absolute + , collapse + , encodeString + , fromText + , toText + ) where + +import qualified Turtle + +#if MIN_VERSION_turtle(1,6,0) + +import qualified Data.Text +import qualified System.FilePath + +absolute = System.FilePath.isAbsolute +collapse = System.FilePath.normalise +encodeString = id +fromText = Data.Text.unpack +toText = Right . Data.Text.pack + +#else + +absolute = Turtle.absolute +collapse = Turtle.collapse +encodeString = Turtle.encodeString +fromText = Turtle.fromText +toText = Turtle.toText + +#endif + +absolute :: Turtle.FilePath -> Bool +collapse :: Turtle.FilePath -> Turtle.FilePath +encodeString :: Turtle.FilePath -> String +fromText :: Turtle.Text -> Turtle.FilePath +toText :: Turtle.FilePath -> Either Turtle.Text Turtle.Text diff --git a/src/no-swagger-wrapper-format/Proto3/Suite/DotProto/Generate/Swagger/Wrappers.hs b/src/no-swagger-wrapper-format/Proto3/Suite/DotProto/Generate/Swagger/Wrappers.hs --- a/src/no-swagger-wrapper-format/Proto3/Suite/DotProto/Generate/Swagger/Wrappers.hs +++ b/src/no-swagger-wrapper-format/Proto3/Suite/DotProto/Generate/Swagger/Wrappers.hs @@ -1,1 +1,1 @@ -module Proto3.Suite.DotProto.Generate.Swagger.Wrappers where +module Proto3.Suite.DotProto.Generate.Swagger.Wrappers () where diff --git a/src/swagger-wrapper-format/Proto3/Suite/DotProto/Generate/Swagger/Wrappers.hs b/src/swagger-wrapper-format/Proto3/Suite/DotProto/Generate/Swagger/Wrappers.hs --- a/src/swagger-wrapper-format/Proto3/Suite/DotProto/Generate/Swagger/Wrappers.hs +++ b/src/swagger-wrapper-format/Proto3/Suite/DotProto/Generate/Swagger/Wrappers.hs @@ -1,5 +1,7 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MonoLocalBinds #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -27,12 +29,10 @@ ) import Data.Swagger.Declare (Declare) import Data.Word (Word32, Word64) -import {-# SOURCE #-} Proto3.Suite.DotProto.Generate.Swagger (OverrideToSchema (..)) +import Google.Protobuf.Wrappers.Polymorphic (Wrapped(..)) -import qualified Data.ByteString as B -import qualified Data.ByteString.Lazy as BL import qualified Data.Text as T -import qualified Data.Text.Lazy as TL +import qualified Proto3.Suite.Types -- | Wrapped Type Schemas @@ -52,42 +52,36 @@ :: forall a . ToSchema a => T.Text - -> Proxy (OverrideToSchema a) + -> Proxy (Maybe (Wrapped a)) -> Declare (Definitions Schema) NamedSchema declareWrapperNamedSchema formatValue _ = setFormat formatValue (declareNamedSchema (Proxy :: Proxy a)) -instance {-# OVERLAPPING #-} ToSchema (OverrideToSchema (Maybe Double)) where +instance {-# OVERLAPPING #-} ToSchema (Maybe (Wrapped Double)) where declareNamedSchema = declareWrapperNamedSchema "DoubleValue" -instance {-# OVERLAPPING #-} ToSchema (OverrideToSchema (Maybe Float)) where +instance {-# OVERLAPPING #-} ToSchema (Maybe (Wrapped Float)) where declareNamedSchema = declareWrapperNamedSchema "FloatValue" -instance {-# OVERLAPPING #-} ToSchema (OverrideToSchema (Maybe Int64)) where +instance {-# OVERLAPPING #-} ToSchema (Maybe (Wrapped Int64)) where declareNamedSchema = declareWrapperNamedSchema "Int64Value" -instance {-# OVERLAPPING #-} ToSchema (OverrideToSchema (Maybe Word64)) where +instance {-# OVERLAPPING #-} ToSchema (Maybe (Wrapped Word64)) where declareNamedSchema = declareWrapperNamedSchema "UInt64Value" -instance {-# OVERLAPPING #-} ToSchema (OverrideToSchema (Maybe Int32)) where +instance {-# OVERLAPPING #-} ToSchema (Maybe (Wrapped Int32)) where declareNamedSchema = declareWrapperNamedSchema "Int32Value" -instance {-# OVERLAPPING #-} ToSchema (OverrideToSchema (Maybe Word32)) where +instance {-# OVERLAPPING #-} ToSchema (Maybe (Wrapped Word32)) where declareNamedSchema = declareWrapperNamedSchema "UInt32Value" -instance {-# OVERLAPPING #-} ToSchema (OverrideToSchema (Maybe Bool)) where +instance {-# OVERLAPPING #-} ToSchema (Maybe (Wrapped Bool)) where declareNamedSchema = declareWrapperNamedSchema "BoolValue" -instance {-# OVERLAPPING #-} ToSchema (OverrideToSchema (Maybe T.Text)) where - declareNamedSchema = declareWrapperNamedSchema "StringValue" - -instance {-# OVERLAPPING #-} ToSchema (OverrideToSchema (Maybe TL.Text)) where - declareNamedSchema = declareWrapperNamedSchema "StringValue" - -instance {-# OVERLAPPING #-} ToSchema (OverrideToSchema (Maybe B.ByteString)) where +instance {-# OVERLAPPING #-} ToSchema (Maybe (Wrapped (Proto3.Suite.Types.String a))) where declareNamedSchema _ = - setFormat "BytesValue" (pure (NamedSchema Nothing byteSchema)) + setFormat "StringValue" (declareNamedSchema (Proxy :: Proxy String)) -instance {-# OVERLAPPING #-} ToSchema (OverrideToSchema (Maybe BL.ByteString)) where +instance {-# OVERLAPPING #-} ToSchema (Maybe (Wrapped (Proto3.Suite.Types.Bytes a))) where declareNamedSchema _ = setFormat "BytesValue" (pure (NamedSchema Nothing byteSchema)) diff --git a/tests/ArbitraryGeneratedTestTypes.hs b/tests/ArbitraryGeneratedTestTypes.hs --- a/tests/ArbitraryGeneratedTestTypes.hs +++ b/tests/ArbitraryGeneratedTestTypes.hs @@ -3,17 +3,22 @@ module ArbitraryGeneratedTestTypes where -import qualified Data.Text.Lazy as T +import Data.String (fromString) +import qualified Data.Text.Short as TS import qualified Data.Vector as V import qualified Proto3.Suite.Types as DotProto import Test.QuickCheck (listOf) import qualified Test.QuickCheck as QC -import Test.QuickCheck.Arbitrary.Generic (genericArbitrary, Arbitrary (arbitrary)) +import Test.QuickCheck.Arbitrary.Generic (genericArbitrary, Arbitrary (..)) import TestProto import qualified TestProtoImport import qualified TestProtoOneof import qualified TestProtoOneofImport +instance Arbitrary TS.ShortText where + arbitrary = fmap TS.fromText arbitrary + shrink = map TS.fromText . shrink . TS.toText + instance Arbitrary Trivial where arbitrary = Trivial <$> arbitrary @@ -24,7 +29,7 @@ <*> arbitrary <*> arbitrary <*> arbitrary - <*> fmap T.pack arbitrary + <*> fmap fromString arbitrary <*> arbitrary instance Arbitrary WithEnum_TestEnum where @@ -36,7 +41,7 @@ instance Arbitrary WithNesting_Nested where arbitrary = WithNesting_Nested - <$> fmap T.pack arbitrary + <$> fmap fromString arbitrary <*> arbitrary <*> arbitrary <*> arbitrary @@ -70,11 +75,14 @@ instance Arbitrary WithNestingRepeated where arbitrary = WithNestingRepeated <$> arbitrary + shrink (WithNestingRepeated xs) = map (WithNestingRepeated . V.fromList) $ + QC.shrinkList (const []) (V.toList xs) + -- It is too expensive to shrink the submessages. instance Arbitrary WithNestingRepeated_Nested where arbitrary = WithNestingRepeated_Nested - <$> fmap T.pack arbitrary + <$> fmap fromString arbitrary <*> arbitrary <*> arbitrary <*> arbitrary @@ -89,9 +97,9 @@ arbitrary = OutOfOrderFields <$> arbitrary - <*> fmap T.pack arbitrary + <*> fmap fromString arbitrary <*> arbitrary - <*> fmap (fmap T.pack) arbitrary + <*> fmap (fmap fromString) arbitrary instance Arbitrary UsingImported where arbitrary = @@ -129,7 +137,7 @@ instance Arbitrary TestProtoOneof.SomethingPickOne where arbitrary = QC.oneof - [ TestProtoOneof.SomethingPickOneName <$> fmap T.pack arbitrary + [ TestProtoOneof.SomethingPickOneName <$> fmap fromString arbitrary , TestProtoOneof.SomethingPickOneSomeid <$> arbitrary , TestProtoOneof.SomethingPickOneDummyMsg1 <$> arbitrary , TestProtoOneof.SomethingPickOneDummyMsg2 <$> arbitrary @@ -157,6 +165,6 @@ instance Arbitrary TestProtoOneofImport.WithOneofPickOne where arbitrary = QC.oneof - [ TestProtoOneofImport.WithOneofPickOneA <$> fmap T.pack arbitrary + [ TestProtoOneofImport.WithOneofPickOneA <$> fmap fromString arbitrary , TestProtoOneofImport.WithOneofPickOneB <$> arbitrary ] diff --git a/tests/Main.hs b/tests/Main.hs --- a/tests/Main.hs +++ b/tests/Main.hs @@ -35,6 +35,7 @@ #endif import qualified Test.Proto.Generate.Name +import qualified Test.Proto.Parse.Option -- ----------------------------------------------------------------------------- @@ -51,6 +52,7 @@ , dotProtoUnitTests , codeGenTests , Test.Proto.Generate.Name.tests + , Test.Proto.Parse.Option.tests #ifdef DHALL , dhallTests @@ -68,11 +70,20 @@ , "-itests" , "-igen" #ifdef SWAGGER +#ifdef SWAGGER_WRAPPER_FORMAT + , "-isrc/swagger-wrapper-format" + , "-DSWAGGER_WRAPPER_FORMAT" +#else + , "-isrc/no-swagger-wrapper-format" +#endif , "-DSWAGGER" #endif #ifdef DHALL , "-DDHALL" #endif +#ifdef LARGE_RECORDS + , "-DLARGE_RECORDS" +#endif , "src/Proto3/Suite/DotProto/Internal.hs" , "src/Proto3/Suite/JSONPB/Class.hs" , "tests/TestCodeGen.hs" @@ -255,6 +266,7 @@ , dotProtoPrintTrivial , dotProtoRoundtripTrivial , dotProtoRoundtripSimpleMessage + , dotProtoRoundtripExtend , qcDotProtoRoundtrip ] @@ -313,6 +325,14 @@ ++ "\n\nWhen attempting to parse:\n\n" ++ generated ++ "\n\nInitial AST:\n\n" + +dotProtoRoundtripExtend :: TestTree +dotProtoRoundtripExtend = + let expected :: DotProto + expected = DotProto [] [] DotProtoNoPackage [] (DotProtoMeta (Path ("test-files" NE.:| ["test_proto_extend"]))) + in testCase + "Round-trip for a message extension" + (testDotProtoRoundtrip expected) -------------------------------------------------------------------------------- -- Helpers diff --git a/tests/Test/Proto/Parse/Gen.hs b/tests/Test/Proto/Parse/Gen.hs new file mode 100644 --- /dev/null +++ b/tests/Test/Proto/Parse/Gen.hs @@ -0,0 +1,52 @@ + +module Test.Proto.Parse.Gen + ( optionId, + optionName, + optionQName, + optionKw, + ) +where + +import Hedgehog (Gen) +import qualified Hedgehog.Gen as Gen +import qualified Hedgehog.Range as Range + +import Control.Applicative (liftA2) +import qualified Data.List.NonEmpty as NonEmpty + +import Proto3.Suite.DotProto.AST + +optionId :: Gen DotProtoIdentifier +optionId = Gen.choice [optionName, optionQName] + +optionQName :: Gen DotProtoIdentifier +optionQName = liftA2 Qualified optionName optionName + +optionName :: Gen DotProtoIdentifier +optionName = + Gen.sized $ \s -> do + let range = Range.linear 1 (fromIntegral s) + nms <- Gen.nonEmpty range gNameString + pure $ if null (NonEmpty.tail nms) + then Single (NonEmpty.head nms) + else Dots (Path nms) + where + gNameString :: Gen String + gNameString = + Gen.sized $ \s -> do + let range = Range.linear 1 (fromIntegral s) + chr <- Gen.alpha + chrs <- Gen.list range Gen.alphaNum + pure (chr : chrs) + +optionKw :: Gen String +optionKw = do + lspace <- whitespace + rspace <- whitespace + pure (lspace ++ "option" ++ rspace) + +whitespace :: Gen String +whitespace = + Gen.sized $ \s -> do + len <- Gen.int (Range.linear 0 (fromIntegral s)) + pure (replicate len ' ') diff --git a/tests/Test/Proto/Parse/Option.hs b/tests/Test/Proto/Parse/Option.hs new file mode 100644 --- /dev/null +++ b/tests/Test/Proto/Parse/Option.hs @@ -0,0 +1,75 @@ + +module Test.Proto.Parse.Option (tests) where + +import Hedgehog (Property, PropertyT, forAll, property, (===)) +import qualified Hedgehog as Hedgehog +import qualified Hedgehog.Gen as Gen +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.Hedgehog (testProperty) + +import qualified Test.Proto.Parse.Gen as Gen + +import qualified Data.Char as Char +import Data.Either (isLeft) +import Text.Parsec (ParseError) +import qualified Text.Parsec as Parsec +import Text.PrettyPrint (render) +import Text.PrettyPrint.HughesPJClass (Pretty, pPrint) + +import Proto3.Suite.DotProto.Parsing (ProtoParser) +import qualified Proto3.Suite.DotProto.Parsing as Proto3 +import Proto3.Suite.DotProto.Rendering () -- orphan Pretty DotProtoIdentifier + +tests :: TestTree +tests = + testGroup + "Test.Proto.Parse.Option" + [ testProperty "Unqualified Option Identifier" propParseName + , testProperty "Qualified Option Identifier" propParseQName + , testProperty "Keyword 'Option'" propParseOptionKw + , testsOptionKw + ] + +runParseTest :: ProtoParser a -> String -> Either ParseError a +runParseTest p = Parsec.parse (Proto3.runProtoParser p) "" + +parseTrip :: (Eq a, Pretty a, Show a) => a -> ProtoParser a -> PropertyT IO () +parseTrip x p = Hedgehog.tripping x (render . pPrint) (runParseTest p) + +propParseName :: Property +propParseName = property $ do + idt <- forAll Gen.optionName + parseTrip idt Proto3.pOptionId + +propParseQName :: Property +propParseQName = property $ do + idt <- forAll Gen.optionQName + parseTrip idt Proto3.pOptionId + +-------------------------------------------------------------------------------- + +testsOptionKw :: TestTree +testsOptionKw = + testGroup + "Test.Proto.Parse.Option.Keyword" + [ testProperty "Keyword 'Option'" propParseOptionKw + , testProperty "Keyword Malformed" propParseOptionKwMalformed + ] + +propParseOptionKw :: Property +propParseOptionKw = property $ do + str <- forAll Gen.optionKw + case runParseTest Proto3.pOptionKw str of + Left err -> Hedgehog.footnoteShow err >> Hedgehog.failure + Right () -> Hedgehog.success + +-- | Ensure the parser handling the keyword "option" must be followed by a +-- non-alphanumeric, otherwise the parser should fail. +propParseOptionKwMalformed :: Property +propParseOptionKwMalformed = property $ do + chr <- forAll Gen.ascii + let result :: Either ParseError () + result = runParseTest Proto3.pOptionKw ("option" ++ [chr]) + in if Char.isAlphaNum chr + then Hedgehog.assert (isLeft result) + else result === Right () diff --git a/tests/TestCodeGen.hs b/tests/TestCodeGen.hs --- a/tests/TestCodeGen.hs +++ b/tests/TestCodeGen.hs @@ -1,4 +1,5 @@ {-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -9,7 +10,6 @@ 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 @@ -18,6 +18,8 @@ import Data.Swagger (ToSchema) import qualified Data.Swagger import qualified Data.Text as T +import Data.Typeable (Typeable, splitTyConApp, + tyConName, typeRep) import Google.Protobuf.Timestamp (Timestamp(..)) import Prelude hiding (FilePath) import Proto3.Suite.DotProto.Generate @@ -28,20 +30,80 @@ import System.Exit import Test.Tasty import Test.Tasty.HUnit (testCase, (@?=)) -import Turtle (FilePath) import qualified Turtle import qualified Turtle.Format as F +import qualified TestProtoWrappers codeGenTests :: TestTree codeGenTests = testGroup "Code generator unit tests" - [ pascalCaseMessageNames + [ swaggerWrapperFormat + , pascalCaseMessageNames , camelCaseMessageFieldNames , don'tAlterEnumFieldNames , knownTypeMessages - , simpleEncodeDotProto - , simpleDecodeDotProto + , pythonInteroperation ] +pythonInteroperation :: TestTree +pythonInteroperation = testGroup "Python interoperation" $ do +#ifdef LARGE_RECORDS + recStyle <- [RegularRecords, LargeRecords] +#else + recStyle <- [RegularRecords] +#endif + tt <- ["Data.Text.Lazy.Text", "Data.Text.Text", "Data.Text.Short.ShortText"] + format <- ["Binary", "Jsonpb"] + direction <- [simpleEncodeDotProto, simpleDecodeDotProto] + pure @[] (direction recStyle tt format) + +swaggerWrapperFormat :: TestTree +swaggerWrapperFormat = testGroup "Swagger Wrapper Format" + [ expectSchema @TestProtoWrappers.TestDoubleValue + "{\"properties\":{\"wrapper\":{\"format\":\"DoubleValue\",\"type\":\"number\"}},\"type\":\"object\"}" + "{\"properties\":{\"wrapper\":{\"format\":\"double\",\"type\":\"number\"}},\"type\":\"object\"}" + , expectSchema @TestProtoWrappers.TestFloatValue + "{\"properties\":{\"wrapper\":{\"format\":\"FloatValue\",\"type\":\"number\"}},\"type\":\"object\"}" + "{\"properties\":{\"wrapper\":{\"format\":\"float\",\"type\":\"number\"}},\"type\":\"object\"}" + , expectSchema @TestProtoWrappers.TestInt64Value + "{\"properties\":{\"wrapper\":{\"maximum\":9223372036854775807,\"format\":\"Int64Value\",\"minimum\":-9223372036854775808,\"type\":\"integer\"}},\"type\":\"object\"}" + "{\"properties\":{\"wrapper\":{\"maximum\":9223372036854775807,\"format\":\"int64\",\"minimum\":-9223372036854775808,\"type\":\"integer\"}},\"type\":\"object\"}" + , expectSchema @TestProtoWrappers.TestUInt64Value + "{\"properties\":{\"wrapper\":{\"maximum\":18446744073709551615,\"format\":\"UInt64Value\",\"minimum\":0,\"type\":\"integer\"}},\"type\":\"object\"}" + "{\"properties\":{\"wrapper\":{\"maximum\":18446744073709551615,\"minimum\":0,\"type\":\"integer\"}},\"type\":\"object\"}" + , expectSchema @TestProtoWrappers.TestInt32Value + "{\"properties\":{\"wrapper\":{\"maximum\":2147483647,\"format\":\"Int32Value\",\"minimum\":-2147483648,\"type\":\"integer\"}},\"type\":\"object\"}" + "{\"properties\":{\"wrapper\":{\"maximum\":2147483647,\"format\":\"int32\",\"minimum\":-2147483648,\"type\":\"integer\"}},\"type\":\"object\"}" + , expectSchema @TestProtoWrappers.TestUInt32Value + "{\"properties\":{\"wrapper\":{\"maximum\":4294967295,\"format\":\"UInt32Value\",\"minimum\":0,\"type\":\"integer\"}},\"type\":\"object\"}" + "{\"properties\":{\"wrapper\":{\"maximum\":4294967295,\"minimum\":0,\"type\":\"integer\"}},\"type\":\"object\"}" + , expectSchema @TestProtoWrappers.TestBoolValue + "{\"properties\":{\"wrapper\":{\"format\":\"BoolValue\",\"type\":\"boolean\"}},\"type\":\"object\"}" + "{\"properties\":{\"wrapper\":{\"type\":\"boolean\"}},\"type\":\"object\"}" + , expectSchema @TestProtoWrappers.TestStringValue + "{\"properties\":{\"wrapper\":{\"format\":\"StringValue\",\"type\":\"string\"}},\"type\":\"object\"}" + "{\"properties\":{\"wrapper\":{\"type\":\"string\"}},\"type\":\"object\"}" + , expectSchema @TestProtoWrappers.TestBytesValue + "{\"properties\":{\"wrapper\":{\"format\":\"BytesValue\",\"type\":\"string\"}},\"type\":\"object\"}" + "{\"properties\":{\"wrapper\":{\"format\":\"byte\",\"type\":\"string\"}},\"type\":\"object\"}" + ] + where + expectSchema :: + forall a . + (ToSchema a, Typeable a) => + LBS.ByteString -> + LBS.ByteString -> + TestTree + expectSchema wrapperFormat noWrapperFormat = + testCase (tyConName (fst (splitTyConApp (typeRep (Proxy @a))))) $ do + lbsSchemaOf @a @?= (if wf then wrapperFormat else noWrapperFormat) + where + wf :: Bool +#ifdef SWAGGER_WRAPPER_FORMAT + wf = True +#else + wf = False +#endif + knownTypeMessages :: TestTree knownTypeMessages = testGroup @@ -102,34 +164,50 @@ setPythonPath = Turtle.export "PYTHONPATH" . maybe pyTmpDir (\p -> pyTmpDir <> ":" <> p) =<< Turtle.need "PYTHONPATH" -simpleEncodeDotProto :: TestTree -simpleEncodeDotProto = - testCase "generate code for a simple .proto and then use it to encode messages" +simpleEncodeDotProto :: RecordStyle -> String -> T.Text -> TestTree +simpleEncodeDotProto recStyle chosenStringType format = + testCase ("generate code for a simple .proto and then use it to encode messages" ++ + " with string type " ++ chosenStringType ++ " in format " ++ show format ++ + ", record style " ++ show recStyle) $ do - compileTestDotProtos + decodedStringType <- either die pure (parseStringType chosenStringType) + + compileTestDotProtos recStyle decodedStringType -- Compile our generated encoder - Turtle.proc "tests/encode.sh" [hsTmpDir] empty >>= (@?= ExitSuccess) + let args = [hsTmpDir] +#if DHALL + ++ ["-DDHALL"] +#endif + Turtle.proc "tests/encode.sh" args 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" + let cmd = hsTmpDir <> "/simpleEncodeDotProto " <> format <> " | python tests/check_simple_dot_proto.py " <> format Turtle.shell cmd empty >>= (@?= ExitFailure 12) -- Not using bracket so that we can inspect the output to fix the tests Turtle.rmtree hsTmpDir Turtle.rmtree pyTmpDir -simpleDecodeDotProto :: TestTree -simpleDecodeDotProto = - testCase "generate code for a simple .proto and then use it to decode messages" +simpleDecodeDotProto :: RecordStyle -> String -> T.Text -> TestTree +simpleDecodeDotProto recStyle chosenStringType format = + testCase ("generate code for a simple .proto and then use it to decode messages" ++ + " with string type " ++ chosenStringType ++ " in format " ++ show format ++ + ", record style " ++ show recStyle) $ do - compileTestDotProtos + decodedStringType <- either die pure (parseStringType chosenStringType) + + compileTestDotProtos recStyle decodedStringType -- Compile our generated decoder - Turtle.proc "tests/decode.sh" [hsTmpDir] empty >>= (@?= ExitSuccess) + let args = [hsTmpDir] +#if DHALL + ++ ["-DDHALL"] +#endif + Turtle.proc "tests/decode.sh" args empty >>= (@?= ExitSuccess) setPythonPath - let cmd = "python tests/send_simple_dot_proto.py | " <> hsTmpDir <> "/simpleDecodeDotProto " + let cmd = "python tests/send_simple_dot_proto.py " <> format <> " | FORMAT=" <> format <> " " <> hsTmpDir <> "/simpleDecodeDotProto " Turtle.shell cmd empty >>= (@?= ExitSuccess) -- Not using bracket so that we can inspect the output to fix the tests @@ -138,18 +216,15 @@ -- * Helpers --- E.g. dumpAST ["test-files"] "test_proto.proto" -dumpAST :: [FilePath] -> FilePath -> IO () -dumpAST incs fp = either (error . show) putStrLn <=< runExceptT $ do - (dp, tc) <- readDotProtoWithContext incs fp - renderHsModuleForDotProto mempty dp tc - hsTmpDir, pyTmpDir :: IsString a => a hsTmpDir = "test-files/hs-tmp" pyTmpDir = "test-files/py-tmp" -compileTestDotProtos :: IO () -compileTestDotProtos = do +defaultStringType :: StringType +defaultStringType = StringType "Data.Text.Lazy" "Text" + +compileTestDotProtos :: RecordStyle -> StringType -> IO () +compileTestDotProtos recStyle decodedStringType = do Turtle.mktree hsTmpDir Turtle.mktree pyTmpDir let protoFiles = @@ -162,14 +237,17 @@ , "test_proto_protoc_plugin.proto" -} , "test_proto_nested_message.proto" + , "test_proto_wrappers.proto" ] forM_ protoFiles $ \protoFile -> do compileDotProtoFileOrDie CompileArgs{ includeDir = ["test-files"] - , extraInstanceFiles = [] + , extraInstanceFiles = ["test-files" Turtle. "Orphan.hs"] , outputDir = hsTmpDir , inputProto = protoFile + , stringType = decodedStringType + , recordStyle = recStyle } let cmd = T.concat [ "protoc --python_out=" @@ -190,6 +268,7 @@ -- >>> import Proto3.Suite.JSONPB -- >>> import TestProto -- >>> import TestProtoOneof +-- >>> import TestProtoWrappers -- >>> :set -XOverloadedStrings -- >>> :set -XOverloadedLists -- >>> :set -XTypeApplications @@ -303,4 +382,7 @@ decodesAs bs x = eitherDecode bs == Right x schemaOf :: forall a . ToSchema a => IO () -schemaOf = LBS8.putStrLn (Data.Aeson.encode (Data.Swagger.toSchema (Proxy @a))) +schemaOf = LBS8.putStrLn (lbsSchemaOf @a) + +lbsSchemaOf :: forall a . ToSchema a => LBS.ByteString +lbsSchemaOf = Data.Aeson.encode (Data.Swagger.toSchema (Proxy @a)) diff --git a/tests/decode.sh b/tests/decode.sh --- a/tests/decode.sh +++ b/tests/decode.sh @@ -1,15 +1,19 @@ set -eu hsTmpDir=$1 +shift ghc \ --make \ -odir $hsTmpDir \ -hidir $hsTmpDir \ -o $hsTmpDir/simpleDecodeDotProto \ + "$@" \ $hsTmpDir/TestProto.hs \ $hsTmpDir/TestProtoImport.hs \ $hsTmpDir/TestProtoOneof.hs \ $hsTmpDir/TestProtoOneofImport.hs \ + $hsTmpDir/TestProtoWrappers.hs \ + tests/Test/Dhall/Orphan.hs \ tests/SimpleDecodeDotProto.hs \ >/dev/null diff --git a/tests/encode.sh b/tests/encode.sh --- a/tests/encode.sh +++ b/tests/encode.sh @@ -1,15 +1,19 @@ set -eu hsTmpDir=$1 +shift ghc \ --make \ -odir $hsTmpDir \ -hidir $hsTmpDir \ -o $hsTmpDir/simpleEncodeDotProto \ + "$@" \ $hsTmpDir/TestProto.hs \ $hsTmpDir/TestProtoImport.hs \ $hsTmpDir/TestProtoOneof.hs \ $hsTmpDir/TestProtoOneofImport.hs \ + $hsTmpDir/TestProtoWrappers.hs \ + tests/Test/Dhall/Orphan.hs \ tests/SimpleEncodeDotProto.hs \ >/dev/null 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 @@ -15,7 +15,7 @@ parseArgs :: ParserInfo CompileArgs parseArgs = info (helper <*> parser) (fullDesc <> progDesc "Compiles a .proto file to a Haskell module") where - parser = CompileArgs <$> includes <*> extraInstances <*> proto <*> out + parser = CompileArgs <$> includes <*> extraInstances <*> proto <*> out <*> stringType <*> recordStyle includes = many $ strOption $ long "includeDir" @@ -36,6 +36,16 @@ long "out" <> metavar "DIR" <> 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!)" + + stringType = option (eitherReader parseStringType) + $ long "string-type" + <> metavar "Data.Text.Lazy.Text" + <> help "Haskell representation of strings" + <> value (StringType "Data.Text.Lazy" "Text") + + recordStyle = flag RegularRecords LargeRecords + $ long "largeRecords" + <> help "Use large-records library to optimize the core code size of generated records" main :: IO () main = execParser parseArgs >>= compileDotProtoFileOrDie