diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,16 @@ +# 0.10.0 +* [#306](https://github.com/awakesecurity/proto3-suite/pull/306) 0.10.0: Use proto3-wire 1.5.0 + * Support proto3-wire 1.5 instead of proto3-wire 1.4. +* Fix `--extraInstanceFile` to support standalone deriving declarations in + addition to regular instance declarations. + +# 0.9.5 +* [#305](https://github.com/awakesecurity/proto3-suite/pull/305) Avoid unpacked packed fields + * The new system of typed builders exploited parser behavior that is required + by the protobuf standard but not yet implemented by `proto3-suite`, causing + decoding errors when the decoder is `proto3-suite`. This change avoids that + incompatibility and expands round-trip testing to cover more scenarios. + # 0.9.4 * [#289](https://github.com/awakesecurity/proto3-suite/pull/289) Support optional fields * Support optional fields (outside of a `oneof`). Such fields are allowed 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.2 name: proto3-suite -version: 0.9.4 +version: 0.10.0 synopsis: A higher-level API to the proto3-wire library description: This library provides a higher-level API to @@ -22,13 +22,14 @@ build-type: Simple data-files: - test-files/*.bin - tests/encode.sh + test-files/*.bin + tests/encode.sh tests/decode.sh extra-source-files: - CHANGELOG.md, + CHANGELOG.md, gen/.gitignore + test-files/extra_instances_deriving.hs flag dhall Description: Turn on Dhall interpret and inject codegen @@ -53,7 +54,7 @@ flag development Description: Enable development-specific options. - Default: False + Default: False Manual: True source-repository head @@ -72,10 +73,10 @@ build-depends: base >=4.15 && <5.0 - , proto3-wire >= 1.4.6 && < 1.5 + , proto3-wire >=1.5 && <1.6 ghc-options: - -O2 + -O2 -Wall library @@ -84,14 +85,14 @@ if flag(dhall) exposed-modules: Proto3.Suite.DhallPB - build-depends: dhall >=1.13 && < 1.43 + build-depends: dhall >=1.13 && <1.43 cpp-options: -DDHALL if flag(swagger) build-depends: swagger2 >=2.1.6 && <2.9 - cpp-options: + cpp-options: -DSWAGGER exposed-modules: @@ -103,7 +104,7 @@ else hs-source-dirs: src/no-swagger-wrapper-format - exposed-modules: + exposed-modules: Proto3.Suite Proto3.Suite.Class Proto3.Suite.DotProto @@ -131,45 +132,45 @@ Proto3.Suite.Form.Encode.Core Turtle.Compat - build-depends: - aeson >= 1.1.1.0 && < 2.3 - , aeson-pretty >= 0.8.10 && < 0.9 - , attoparsec >= 0.13.0.1 && < 0.15 - , base64-bytestring >= 1.0.0.1 && < 1.3 - , binary >=0.8.3 && <= 0.9 + build-depends: + aeson >=1.1.1.0 && <2.3 + , aeson-pretty + , attoparsec >=0.13.0.1 + , base64-bytestring >=1.0.0.1 && <1.3 + , binary >=0.8.3 , bytestring >=0.10.6.0 && <0.13 , deepseq >=1.4 && <1.6 - , cereal >= 0.5.1 && <0.6 + , cereal >=0.5.1 && <0.6 , containers >=0.5 && <0.8 , contravariant >=1.4 && <1.6 - , filepath >= 1.5.2 && < 1.6 - , foldl >= 1.4.18 && < 1.5 + , filepath + , foldl , ghc-lib-parser >=9.2.8 && <9.13 - , hashable >= 1.4.7 && < 1.5 - , insert-ordered-containers >= 0.2.7 && < 0.3 - , lens >= 5.3.5 && < 5.4 + , hashable + , insert-ordered-containers + , lens , mtl >=2.2 && <2.4 - , neat-interpolation >= 0.5.1 && < 0.6 - , parsec >= 3.1.9 && <3.2 - , parsers >= 0.12 && <0.13 + , neat-interpolation + , parsec >=3.1.9 && <3.2 + , parsers >=0.12 && <0.13 , pretty ==1.1.* - , pretty-show >= 1.6.12 && < 2 + , pretty-show >=1.6.12 && <2 , QuickCheck >=2.10 && <2.17 - , quickcheck-instances >=0.3.26 && < 0.4 + , quickcheck-instances >=0.3.26 && <0.4 , safe ==0.3.* - , split >= 0.2.5 && < 0.3 - , system-filepath >= 0.4.14 && < 0.5 + , split + , system-filepath , template-haskell >=2.17 && <2.24 - , text >= 0.2 && <2.2 + , text >=0.2 && <2.2 , text-short >=0.1.3 && <0.2 - , time >= 1.12.2 && < 1.13 + , time , transformers >=0.4 && <0.7 - , turtle < 1.6.0 || >= 1.6.1 && < 1.7 + , turtle <1.6.0 || >=1.6.1 && <1.7 , vector >=0.11 && <0.14 if flag(attoparsec-aeson) build-depends: - attoparsec-aeson >= 2.2.0.0 && < 2.3 + attoparsec-aeson >=2.2.0.0 test-suite tests import: common @@ -184,7 +185,7 @@ if flag(dhall) other-modules: TestDhall - build-depends: dhall >=1.13 && < 1.43 + build-depends: dhall >=1.13 && <1.43 cpp-options: -DDHALL if flag(swagger) @@ -227,31 +228,31 @@ build-depends: aeson - , attoparsec >= 0.13.0.1 - , base64-bytestring >= 1.0.0.1 && < 1.3 + , attoparsec >=0.13.0.1 + , base64-bytestring >=1.0.0.1 && <1.3 , bytestring >=0.10.6.0 && <0.13 - , cereal >= 0.5.1 && <0.6 + , cereal >=0.5.1 && <0.6 , containers >=0.5 && <0.8 , deepseq >=1.4 && <1.6 , doctest , generic-arbitrary - , ghc-lib-parser >= 9.10.2 && < 9.11 + , ghc-lib-parser , hedgehog , mtl >=2.2 && <2.4 - , parsec >= 3.1.9 && <3.2.0 + , parsec >=3.1.9 && <3.2.0 , pretty ==1.1.* - , pretty-show >= 1.6.12 && < 2.0 + , pretty-show >=1.6.12 && <2.0 , proto3-suite , QuickCheck >=2.10 && <2.17 , record-hasfield - , tasty >= 0.11 && <1.6 + , tasty >=0.11 && <1.6 , tasty-hedgehog - , tasty-hunit >= 0.9 && <0.11 - , tasty-quickcheck >= 0.8.4 && <0.12 - , text >= 0.2 && <2.2 + , tasty-hunit >=0.9 && <0.11 + , tasty-quickcheck >=0.8.4 && <0.12 + , text >=0.2 && <2.2 , text-short >=0.1.3 && <0.2 , transformers >=0.4 && <0.7 - , turtle < 1.6.0 || >= 1.6.1 && < 1.7 + , turtle , vector >=0.11 && <0.14 executable compile-proto-file @@ -259,14 +260,14 @@ hs-source-dirs: tools/compile-proto-file default-language: Haskell2010 - build-depends: + build-depends: base >=4.15 && <5.0 - , ghc-lib-parser >= 9.10.2 && < 9.11 - , optparse-applicative >= 0.18.1 && < 0.19 + , ghc-lib-parser + , optparse-applicative , proto3-suite - , system-filepath >= 0.4.14 && < 0.5 - , text >= 2.1.1 && < 2.2 - , turtle < 1.6.0 || >= 1.6.1 && < 1.7 + , system-filepath + , text + , turtle ghc-options: -O2 @@ -277,10 +278,10 @@ main-is: Main.hs hs-source-dirs: tools/canonicalize-proto-file - build-depends: + build-depends: containers >=0.5 && <0.8 , mtl >=2.2 && <2.4 - , optparse-generic >= 1.5.2 && < 1.6 + , optparse-generic , proto3-suite - , system-filepath >= 0.4.14 && < 0.5 - , turtle < 1.6.0 || >= 1.6.1 && < 1.7 + , system-filepath + , turtle 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 @@ -34,6 +34,7 @@ , hsModuleForDotProto , renderHsModuleForDotProto , readDotProtoWithContext + , getExtraInstances ) where import Control.Applicative @@ -256,7 +257,7 @@ , (?stringType :: StringType) , (?typeLevelFormat :: Bool) ) => - -- | Extra user-define instances that override default generated instances + -- | Extra user-defined instances and standalone deriving declarations that override default generated instances ([HsImportDecl], [HsDecl]) -> -- | DotProto -> @@ -309,8 +310,9 @@ Nothing -> internalError (T.unpack "Error: Failed to parse instance file") Just (GHC.L _ m) -> do - let isInstDecl (GHC.L _ GHC.InstD{}) = True - isInstDecl _ = False + let isInstDecl (GHC.L _ GHC.InstD{}) = True + isInstDecl (GHC.L _ GHC.DerivD{}) = True + isInstDecl _ = False pure (GHC.hsmodImports m, filter isInstDecl (GHC.hsmodDecls m)) -- | This very specific function will only work for the qualification on the very first type diff --git a/src/Proto3/Suite/Form/Encode.hs b/src/Proto3/Suite/Form/Encode.hs --- a/src/Proto3/Suite/Form/Encode.hs +++ b/src/Proto3/Suite/Form/Encode.hs @@ -156,6 +156,7 @@ import Proto3.Wire.Encode.Repeated (ToRepeated, mapRepeated) import Proto3.Wire.Reverse qualified as RB import Proto3.Wire.Types (FieldNumber, fieldNumber) +import Proto3.Wire.Types qualified as Wire (WireType(..)) -- | The unsafe but fast inverse of 'messageEncoderToByteString'. unsafeByteStringToMessageEncoder :: B.ByteString -> MessageEncoder message @@ -246,20 +247,21 @@ {-# INLINE cachedFieldsEncoding #-} $(instantiatePackableField - [t| 'UInt32 |] [t| Word32 |] [| Encode.uint32 |] [| Encode.packedUInt32R |] + [t| 'UInt32 |] [t| Word32 |] [| Encode.uint32 |] [| Encode.packedField @'Wire.Varint |] [ ([t| Word16 |], [| fromIntegral @Word16 @Word32 |], [t| 'UInt32 |]) , ([t| Word8 |], [| fromIntegral @Word8 @Word32 |], [t| 'UInt32 |]) ] True) $(instantiatePackableField - [t| 'UInt64 |] [t| Word64 |] [| Encode.uint64 |] [| Encode.packedUInt64R |] + [t| 'UInt64 |] [t| Word64 |] [| Encode.uint64 |] [| Encode.packedField @'Wire.Varint |] [ ([t| Word32 |], [| id |], [t| 'UInt32 |]) , ([t| Word16 |], [| fromIntegral @Word16 @Word32 |], [t| 'UInt32 |]) , ([t| Word8 |], [| fromIntegral @Word8 @Word32 |], [t| 'UInt32 |]) ] True) $(instantiatePackableField - [t| 'Int32 |] [t| Int32 |] [| Encode.int32 |] [| Encode.packedInt32R |] + [t| 'Int32 |] [t| Int32 |] [| Encode.int32 |] + [| \(!fn) -> Encode.packedField @'Wire.Varint fn . fmap (fromIntegral @Int32 @Word64) |] [ ([t| Int16 |], [| fromIntegral @Int16 @Int32 |], [t| 'Int32 |]) , ([t| Int8 |], [| fromIntegral @Int8 @Int32 |], [t| 'Int32 |]) -- Because the encoding for @int32@ is just a conversion to the 64-bit unsigned @@ -271,7 +273,8 @@ ] True) $(instantiatePackableField - [t| 'Int64 |] [t| Int64 |] [| Encode.int64 |] [| Encode.packedInt64R |] + [t| 'Int64 |] [t| Int64 |] [| Encode.int64 |] + [| \(!fn) -> Encode.packedField @'Wire.Varint fn . fmap (fromIntegral @Int64 @Word64) |] [ ([t| Int32 |], [| fromIntegral @Int32 @Int64 |], [t| 'Int64 |]) , ([t| Int16 |], [| fromIntegral @Int16 @Int64 |], [t| 'Int64 |]) , ([t| Int8 |], [| fromIntegral @Int8 @Int64 |], [t| 'Int64 |]) @@ -285,7 +288,10 @@ ] True) $(instantiatePackableField - [t| 'SInt32 |] [t| Int32 |] [| Encode.sint32 |] [| Encode.packedSInt32R |] + [t| 'SInt32 |] [t| Int32 |] [| Encode.sint32 |] + [| \(!fn) -> + Encode.packedField @'Wire.Varint fn . + fmap (fromIntegral @Int32 @Word32 . Encode.zigZagEncode) |] [ ([t| Int16 |], [| fromIntegral @Int16 @Int32 |], [t| 'SInt32 |]) , ([t| Int8 |], [| fromIntegral @Int8 @Int32 |], [t| 'SInt32 |]) , ([t| Word16 |], [| fromIntegral @Word16 @Int32 |], [t| 'SInt32 |]) @@ -293,7 +299,10 @@ ] False) $(instantiatePackableField - [t| 'SInt64 |] [t| Int64 |] [| Encode.sint64 |] [| Encode.packedSInt64R |] + [t| 'SInt64 |] [t| Int64 |] [| Encode.sint64 |] + [| \(!fn) -> + Encode.packedField @'Wire.Varint fn . + fmap (fromIntegral @Int64 @Word64 . Encode.zigZagEncode) |] [ ([t| Int32 |], [| id |], [t| 'SInt32 |]) , ([t| Int16 |], [| id |], [t| 'SInt32 |]) , ([t| Int8 |], [| id |], [t| 'SInt32 |]) @@ -303,20 +312,21 @@ ] False) $(instantiatePackableField - [t| 'Fixed32 |] [t| Word32 |] [| Encode.fixed32 |] [| Encode.packedFixed32R |] + [t| 'Fixed32 |] [t| Word32 |] [| Encode.fixed32 |] [| Encode.packedField @'Wire.Fixed32 |] [ ([t| Word16 |], [| fromIntegral @Word16 @Word32 |], [t| 'Fixed32 |]) , ([t| Word8 |], [| fromIntegral @Word8 @Word32 |], [t| 'Fixed32 |]) ] False) $(instantiatePackableField - [t| 'Fixed64 |] [t| Word64 |] [| Encode.fixed64 |] [| Encode.packedFixed64R |] + [t| 'Fixed64 |] [t| Word64 |] [| Encode.fixed64 |] [| Encode.packedField @'Wire.Fixed64 |] [ ([t| Word32 |], [| fromIntegral @Word32 @Word64 |], [t| 'Fixed64 |]) , ([t| Word16 |], [| fromIntegral @Word16 @Word64 |], [t| 'Fixed64 |]) , ([t| Word8 |], [| fromIntegral @Word8 @Word64 |], [t| 'Fixed64 |]) ] False) $(instantiatePackableField - [t| 'SFixed32 |] [t| Int32 |] [| Encode.sfixed32 |] [| Encode.packedSFixed32R |] + [t| 'SFixed32 |] [t| Int32 |] [| Encode.sfixed32 |] + [| \(!fn) -> Encode.packedField @'Wire.Fixed32 fn . fmap (fromIntegral @Int32 @Word32) |] [ ([t| Int16 |], [| fromIntegral @Int16 @Int32 |], [t| 'SFixed32 |]) , ([t| Int8 |], [| fromIntegral @Int8 @Int32 |], [t| 'SFixed32 |]) , ([t| Word16 |], [| fromIntegral @Word16 @Int32 |], [t| 'SFixed32 |]) @@ -324,7 +334,8 @@ ] False) $(instantiatePackableField - [t| 'SFixed64 |] [t| Int64 |] [| Encode.sfixed64 |] [| Encode.packedSFixed64R |] + [t| 'SFixed64 |] [t| Int64 |] [| Encode.sfixed64 |] + [| \(!fn) -> Encode.packedField @'Wire.Fixed64 fn . fmap (fromIntegral @Int64 @Word64) |] [ ([t| Int32 |], [| fromIntegral @Int32 @Int64 |], [t| 'SFixed64 |]) , ([t| Int16 |], [| fromIntegral @Int16 @Int64 |], [t| 'SFixed64 |]) , ([t| Int8 |], [| fromIntegral @Int8 @Int64 |], [t| 'SFixed64 |]) @@ -334,15 +345,15 @@ ] False) $(instantiatePackableField - [t| 'Bool |] [t| Bool |] [| Encode.bool |] [| Encode.packedBoolsR |] + [t| 'Bool |] [t| Bool |] [| Encode.bool |] [| Encode.packedField @'Wire.Varint |] [] True) $(instantiatePackableField - [t| 'Float |] [t| Float |] [| Encode.float |] [| Encode.packedFloatsR |] + [t| 'Float |] [t| Float |] [| Encode.float |] [| Encode.packedField @'Wire.Fixed32 |] [] True) $(instantiatePackableField - [t| 'Double |] [t| Double |] [| Encode.double |] [| Encode.packedDoublesR |] + [t| 'Double |] [t| Double |] [| Encode.double |] [| Encode.packedField @'Wire.Fixed64 |] [ ([t| Float |], [| realToFrac @Float @Double |], [t| 'Double |]) ] True) diff --git a/src/Proto3/Suite/Form/Encode/Core.hs b/src/Proto3/Suite/Form/Encode/Core.hs --- a/src/Proto3/Suite/Form/Encode/Core.hs +++ b/src/Proto3/Suite/Form/Encode/Core.hs @@ -1,6 +1,5 @@ {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveTraversable #-} @@ -77,7 +76,7 @@ (Association, NumberOf, OneOfOf, Packing(..), Cardinality(..), CardinalityOf, ProtoType(..), ProtoTypeOf, Wrapper) import Proto3.Wire.Encode qualified as Encode -import Proto3.Wire.Encode.Repeated (Repeated(..), ToRepeated(..), mapRepeated) +import Proto3.Wire.Encode.Repeated (Repeated, ToRepeated(..), mapRepeated, toRepeated) import Proto3.Wire.Types (FieldNumber, fieldNumber) -- | Annotates 'Encode.MessageBuilder' with the type of protobuf message it encodes. @@ -378,16 +377,7 @@ -- See also 'fieldForm'. field :: forall names . a -> FieldsEncoder message names (Occupy message name names) -instance forall (name :: Symbol) -#if defined(__GLASGOW_HASKELL__) && 904 <= __GLASGOW_HASKELL__ - r (a :: TYPE r) -#else - (a :: Type) - -- Regarding the call to @coerce@, GHC 9.2.8 would say: - -- "Cannot use function with levity-polymorphic arguments". - -- So we just drop support for unlifted arguments until GHC 9.4. -#endif - (message :: Type) . +instance forall (name :: Symbol) (a :: Type) (message :: Type) . ( KnownFieldNumber message name , FieldForm (CardinalityOf message name) (ProtoTypeOf message name) a ) => @@ -456,7 +446,7 @@ -- defined in "Proto3.Suite.Form", which declare message format without -- specifying any policy regarding how to efficiently encode or which -- Haskell types may be encoded. -type FieldForm :: Cardinality -> ProtoType -> forall {r} . TYPE r -> Constraint +type FieldForm :: Cardinality -> ProtoType -> Type -> Constraint class FieldForm cardinality protoType a where -- | Encodes a message field with the @@ -493,27 +483,26 @@ -- accept both packed and unpacked primitives regardless of packing preference.) instance ( ToRepeated c e , PackedFieldForm protoType e - , FieldForm 'Optional protoType (Identity e) ) => FieldForm ('Repeated 'Packed) protoType c where - fieldForm _ ty !fn (toRepeated -> !xs@(ReverseRepeated prediction reversed)) = - case prediction of - Just count - | 2 <= count -> packedFieldForm ty fn xs -- multiple packed elements - | otherwise -> fieldForm (proxy# :: Proxy# ('Repeated 'Unpacked)) ty fn xs -- 0 or 1 - Nothing -> case foldr singletonOp Empty reversed of - Empty -> mempty -- 0 elements can be expressed implicitly - Singleton x -> fieldForm (proxy# :: Proxy# 'Optional) ty fn (Identity x) -- unpacked - Multiple -> packedFieldForm ty fn xs -- multiple packed elements - where - singletonOp :: a -> Singleton a -> Singleton a - singletonOp x Empty = Singleton x - singletonOp _ _ = Multiple + fieldForm _ ty !fn = packedFieldForm ty fn . toRepeated + -- From , "Repeated Elements": + -- + -- "Protocol buffer parsers must be able to parse repeated fields + -- that were compiled as packed as if they were not packed, and + -- vice versa. This permits adding [packed=true] to existing + -- fields in a forward- and backward-compatible way." + -- + -- Therefore in principle we could save one octet by using unpacked + -- format for a repeated field containing exactly one element. + -- + -- But at present the @proto3-suite@ decoder rejects unpacked format + -- when parsing a repeated field it expects to be packed. And even + -- after we improve compatibility, saving just one octet might not + -- justify a larger and perhaps slower generated encoder. {-# INLINE fieldForm #-} -data Singleton a = Empty | Singleton a | Multiple - instance FieldForm 'Optional ('Message inner) (Identity (MessageEncoder inner)) where fieldForm _ _ !fn (Identity e) = Encode.embedded fn (untypedMessageEncoder e) @@ -532,7 +521,6 @@ -- | 'FieldForm' delegates to this type class when encoding -- packed repeated fields containing two or more elements. -type PackedFieldForm :: ProtoType -> forall {r} . TYPE r -> Constraint class PackedFieldForm protoType a where -- | 'fieldForm' delegates to this method when encoding diff --git a/test-files/extra_instances_deriving.hs b/test-files/extra_instances_deriving.hs new file mode 100644 --- /dev/null +++ b/test-files/extra_instances_deriving.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE StandaloneDeriving #-} + +module ExtraInstances where + +data Foo = Foo + +helper :: Int +helper = 42 + +instance Show Foo where + show _ = "Foo" + +deriving instance Eq Foo diff --git a/tests/Main.hs b/tests/Main.hs --- a/tests/Main.hs +++ b/tests/Main.hs @@ -84,7 +84,6 @@ , Test.Proto.Generate.Name.testTree , Test.Proto.Parse.Option.testTree , Test.Proto.Interval.testTree - #ifdef DHALL , dhallTests #endif diff --git a/tests/TestCodeGen.hs b/tests/TestCodeGen.hs --- a/tests/TestCodeGen.hs +++ b/tests/TestCodeGen.hs @@ -3,6 +3,7 @@ {-# LANGUAGE DisambiguateRecordFields #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MagicHash #-} +{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE OverloadedLists #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -12,6 +13,8 @@ import ArbitraryGeneratedTestTypes () import Control.Applicative +import Control.Monad.Except (runExceptT) +import Data.List (sort) import Control.Monad #ifdef SWAGGER import qualified Data.Aeson @@ -40,7 +43,8 @@ import Proto3.Suite.DotProto.AST (DotProtoField(..), DotProtoIdentifier(..), DotProtoType(..), DotProtoPrimType(..)) import Proto3.Suite.DotProto.Generate -import Proto3.Suite.Haskell.Parser (Logger) +import Proto3.Suite.Haskell.Parser (Logger, renderSDoc) +import qualified GHC.Utils.Outputable as GHC import Proto3.Suite.JSONPB (FromJSONPB (..), Options (..), ToJSONPB (..), defaultOptions, eitherDecode, encode, @@ -49,7 +53,7 @@ import System.Exit import Test.Proto.ToEncoder (Iterator, Stripping) import Test.Tasty -import Test.Tasty.HUnit (testCase, (@?=)) +import Test.Tasty.HUnit (assertEqual, assertFailure, testCase, (@?=)) import Test.Tasty.QuickCheck (Arbitrary, (===), testProperty) import qualified Turtle import qualified Turtle.Format as F @@ -71,6 +75,7 @@ , don'tAlterEnumFieldNames , knownTypeMessages , pythonInteroperation logger + , extraInstanceParsing logger #ifdef SWAGGER , swaggerTests , swaggerWrapperFormat @@ -82,11 +87,32 @@ tt <- ["Data.Text.Lazy.Text", "Data.Text.Text", "Data.Text.Short.ShortText"] format <- ["Binary", "Jsonpb"] testEncode <- [True, False] + testDecode <- [False, True] direct <- [False, True] guard $ not direct || (testEncode && format == "Binary") - let f = if testEncode then simpleEncodeDotProto direct else simpleDecodeDotProto + f <- if + | testEncode, testDecode -> [roundTripDotProto direct] + | testEncode -> [simpleEncodeDotProto direct] + | testDecode -> [simpleDecodeDotProto] + | otherwise -> [] pure @[] (f logger tt format) +extraInstanceParsing :: Logger -> TestTree +extraInstanceParsing logger = + testCase "getExtraInstances includes standalone deriving declarations" $ do + result <- runExceptT $ getExtraInstances logger "test-files/extra_instances_deriving.hs" + case result of + Left err -> assertFailure (show err) + Right (_imports, decls) -> do + assertEqual "expected 2 declarations (1 instance + 1 standalone deriving)" + 2 (length decls) + let names = sort (map (renderSDoc . GHC.ppr) decls) + assertEqual "parsed instance names should match the instances in extra_instances_deriving.hs" + [ "deriving instance Eq Foo" + , "instance Show Foo where\n show _ = \"Foo\"" + ] + names + #ifdef SWAGGER swaggerWrapperFormat :: TestTree swaggerWrapperFormat = testGroup "Swagger Wrapper Format" @@ -197,6 +223,7 @@ setPythonPath = Turtle.export "PYTHONPATH" . maybe pyTmpDir (\p -> pyTmpDir <> ":" <> p) =<< Turtle.need "PYTHONPATH" +-- | Haskell encoder -> Python decoder. simpleEncodeDotProto :: Bool -> Logger -> String -> T.Text -> TestTree simpleEncodeDotProto direct logger chosenStringType format = testCase ("generate code for a simple .proto and then use it to encode messages" ++ @@ -206,14 +233,9 @@ decodedStringType <- either die pure (parseStringType chosenStringType) compileTestDotProtos logger decodedStringType direct - -- Compile our generated encoder - let encodeCmd = "tests/encode.sh " <> hsTmpDir - <> (if direct then " -DTYPE_LEVEL_FORMAT" else "") -#if DHALL - <> " -DDHALL" -#endif - Turtle.shell encodeCmd empty >>= (@?= ExitSuccess) + compileHaskellEncoder direct + -- The python test of encoding exits with a special error code to indicate -- all tests were successful. When directly encoding without an intermediate -- data structure, we run the test several times (still compiling just once) @@ -241,6 +263,7 @@ Turtle.rmtree hsTmpDir Turtle.rmtree pyTmpDir +-- | Python encoder -> Haskell decoder. simpleDecodeDotProto :: Logger -> String -> T.Text -> TestTree simpleDecodeDotProto logger chosenStringType format = testCase ("generate code for a simple .proto and then use it to decode messages" ++ @@ -249,13 +272,9 @@ decodedStringType <- either die pure (parseStringType chosenStringType) compileTestDotProtos logger decodedStringType False - -- Compile our generated decoder - let decodeCmd = "tests/decode.sh " <> hsTmpDir -#if DHALL - <> " -DDHALL" -#endif - Turtle.shell decodeCmd empty >>= (@?= ExitSuccess) + compileHaskellDecoder + setPythonPath let cmd = "python tests/send_simple_dot_proto.py " <> format <> " | FORMAT=" <> format <> " " <> hsTmpDir <> "/simpleDecodeDotProto " Turtle.shell cmd empty >>= (@?= ExitSuccess) @@ -264,6 +283,43 @@ Turtle.rmtree hsTmpDir Turtle.rmtree pyTmpDir +-- | Haskell encoder -> Haskell decoder. +roundTripDotProto :: Bool -> Logger -> String -> T.Text -> TestTree +roundTripDotProto direct logger chosenStringType format = + testCase ("generate code for a simple .proto and then use it to encode and decode messages" ++ + " with string type " ++ chosenStringType ++ " in format " ++ show format ++ + (if direct then ", direct mode" else ", intermediate mode")) + $ do + decodedStringType <- either die pure (parseStringType chosenStringType) + + compileTestDotProtos logger decodedStringType direct + + compileHaskellEncoder direct + + compileHaskellDecoder + + let iterators :: [Iterator] + iterators + | direct = [minBound .. maxBound] + | otherwise = [minBound] -- Just an unused placeholder + strippings :: [Stripping] + strippings + | direct = [minBound .. maxBound] + | otherwise = [minBound] -- Just an unused placeholder + forM_ iterators $ \(iterator :: Iterator) -> do + forM_ strippings $ \(stripping :: Stripping) -> do + when direct $ do + putStrLn $ " iterator: " ++ show iterator + putStrLn $ " stripping: " ++ show stripping + let cmd = hsTmpDir <> "/simpleEncodeDotProto " <> format <> + " " <> T.pack (show iterator) <> " " <> T.pack (show stripping) <> + " | FORMAT=" <> format <> " " <> hsTmpDir <> "/simpleDecodeDotProto " + Turtle.shell cmd empty >>= (@?= ExitSuccess) + + -- Not using bracket so that we can inspect the output to fix the tests + Turtle.rmtree hsTmpDir + Turtle.rmtree pyTmpDir + -- * Helpers hsTmpDir, pyTmpDir :: IsString a => a @@ -312,6 +368,25 @@ Turtle.shell cmd empty >>= (@?= ExitSuccess) Turtle.touch (pyTmpDir Turtle. "__init__.py") + +-- | Compile our generated encoder +compileHaskellEncoder :: Bool -> IO () +compileHaskellEncoder direct = do + let encodeCmd = "tests/encode.sh " <> hsTmpDir + <> (if direct then " -DTYPE_LEVEL_FORMAT" else "") +#if DHALL + <> " -DDHALL" +#endif + Turtle.shell encodeCmd empty >>= (@?= ExitSuccess) + +-- | Compile our generated decoder +compileHaskellDecoder :: IO () +compileHaskellDecoder = do + let decodeCmd = "tests/decode.sh " <> hsTmpDir +#if DHALL + <> " -DDHALL" +#endif + Turtle.shell decodeCmd empty >>= (@?= ExitSuccess) dotProtoTests :: TestTree dotProtoTests = testGroup "dotProto method tests" 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 @@ -32,7 +32,7 @@ extraInstances = many $ strOption $ long "extraInstanceFile" <> metavar "FILE" - <> help "Additional file to provide instances that would otherwise be generated. Can be used multiple times. Types for which instance overrides are given must be fully qualified." + <> help "Additional file to provide instance declarations or standalone deriving declarations that would otherwise be generated. Can be used multiple times. Types for which instance overrides are given must be fully qualified." proto = strOption $ long "proto"