diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,11 @@ +# 0.7.0 +* Support GHC 9.2, 9.4. +* Support proto files without a package declaration. +* Modify "Eq (Enumerated a)" to identify "Enumerated (Right e)" + with "Enumerated (Left (fromProtoEnum e))" because those two + values encode to the same octet sequence. They are already + equivalent as arguments to "isDefault @(Enumerated e)". +* Derive Data and Generic instances for Protobuf AST types. # 0.6.0 * Support use of ShortText as the Haskell type of a protobuf string. 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.6.0 +version: 0.7.0 synopsis: A higher-level API to the proto3-wire library description: This library provides a higher-level API to @@ -56,13 +56,13 @@ if flag(dhall) exposed-modules: Proto3.Suite.DhallPB - build-depends: dhall >=1.13 && < 1.39 + build-depends: dhall >=1.13 && < 1.43 cpp-options: -DDHALL if flag(swagger) exposed-modules: Proto3.Suite.DotProto.Generate.Swagger Proto3.Suite.DotProto.Generate.Swagger.Wrappers - build-depends: swagger2 >=2.1.6 && <2.8 + build-depends: swagger2 >=2.1.6 && <2.9 cpp-options: -DSWAGGER if flag(swagger-wrapper-format) hs-source-dirs: src/swagger-wrapper-format @@ -71,7 +71,7 @@ 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, + build-depends: dhall >=1.34 && < 1.43, large-generics, large-records cpp-options: -DLARGE_RECORDS @@ -99,7 +99,7 @@ other-modules: Turtle.Compat - build-depends: aeson >= 1.1.1.0 && < 2.1, + build-depends: aeson >= 1.1.1.0 && < 2.2, aeson-pretty, attoparsec >= 0.13.0.1, base >=4.8 && <5.0, @@ -124,12 +124,12 @@ pretty-show >= 1.6.12 && < 2.0, proto3-wire >= 1.2.2 && < 1.5, QuickCheck >=2.10 && <2.15, - quickcheck-instances < 0.4, + quickcheck-instances >=0.3.26 && < 0.4, safe ==0.3.*, split, system-filepath, time, - text >= 0.2 && <1.3, + text >= 0.2 && <2.1, text-short >=0.1.3 && <0.2, transformers >=0.4 && <0.6, turtle < 1.6.0 || >= 1.6.1 && < 1.7.0, @@ -152,7 +152,7 @@ if flag(dhall) other-modules: TestDhall - build-depends: dhall >=1.13 && < 1.39 + build-depends: dhall >=1.13 && < 1.43 cpp-options: -DDHALL if flag(swagger) @@ -191,7 +191,7 @@ Test.Proto.Parse.Option build-depends: - aeson >= 1.1.1.0 && < 2.1 + aeson >= 1.1.1.0 && < 2.2 , attoparsec >= 0.13.0.1 , base >=4.8 && <5.0 , base64-bytestring >= 1.0.0.1 && < 1.3 @@ -209,11 +209,12 @@ , proto3-suite , proto3-wire >= 1.2 && < 1.5 , QuickCheck >=2.10 && <2.15 + , record-hasfield , tasty >= 0.11 && <1.5 , tasty-hedgehog , tasty-hunit >= 0.9 && <0.11 , tasty-quickcheck >= 0.8.4 && <0.11 - , text >= 0.2 && <1.3 + , text >= 0.2 && <2.1 , text-short >=0.1.3 && <0.2 , transformers >=0.4 && <0.6 , turtle diff --git a/src/Proto3/Suite/Class.hs b/src/Proto3/Suite/Class.hs --- a/src/Proto3/Suite/Class.hs +++ b/src/Proto3/Suite/Class.hs @@ -57,6 +57,7 @@ -- > Right msg -> msg {-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DefaultSignatures #-} @@ -107,6 +108,7 @@ import qualified Data.Foldable as Foldable import Data.Functor (($>)) import Data.Int (Int32, Int64) +import Data.Kind (Type) import qualified Data.Map as M import Data.Maybe (fromMaybe, isNothing) import Data.Proxy (Proxy (..)) @@ -115,7 +117,6 @@ 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) import Data.Word (Word32, Word64) import GHC.Exts (fromList, Proxy#, proxy#) @@ -229,7 +230,7 @@ def = codeToEnumerated 0 isDefault = (== 0) . codeFromEnumerated -deriving via (a :: *) instance HasDefault a => HasDefault (Wrapped a) +deriving via (a :: Type) instance HasDefault a => HasDefault (Wrapped a) instance HasDefault (UnpackedVec a) where def = mempty @@ -266,7 +267,7 @@ def = M.empty isDefault = M.null -class GenericHasDefault (f :: * -> *) where +class GenericHasDefault (f :: Type -> Type) where genericDef :: f x instance HasDefault f => GenericHasDefault (K1 i f) where genericDef = K1 (def @f) @@ -301,7 +302,7 @@ default nameOf :: (IsString string, GenericNamed (Rep a)) => Proxy# a -> string nameOf _ = genericNameOf (proxy# :: Proxy# (Rep a)) -class GenericNamed (f :: * -> *) where +class GenericNamed (f :: Type -> Type) where genericNameOf :: IsString string => Proxy# f -> string instance Datatype d => GenericNamed (M1 D d f) where @@ -367,7 +368,7 @@ where enumField (name, value) = DotProtoEnumField (Single name) value [] -class GenericFinite (f :: * -> *) where +class GenericFinite (f :: Type -> Type) where genericEnumerate :: IsString string => [(string, f p)] instance ( GenericFinite f @@ -426,107 +427,126 @@ unsafeCoerceOver = unsafeCoerce instance Primitive Int32 where - encodePrimitive = Encode.int32 + encodePrimitive !num = Encode.int32 num + {-# INLINE encodePrimitive #-} decodePrimitive = Decode.int32 primType _ = Int32 instance Primitive Int64 where - encodePrimitive = Encode.int64 + encodePrimitive !num = Encode.int64 num + {-# INLINE encodePrimitive #-} decodePrimitive = Decode.int64 primType _ = Int64 instance Primitive Word32 where - encodePrimitive = Encode.uint32 + encodePrimitive !num = Encode.uint32 num + {-# INLINE encodePrimitive #-} decodePrimitive = Decode.uint32 primType _ = UInt32 instance Primitive Word64 where - encodePrimitive = Encode.uint64 + encodePrimitive !num = Encode.uint64 num + {-# INLINE encodePrimitive #-} decodePrimitive = Decode.uint64 primType _ = UInt64 instance Primitive (Signed Int32) where - encodePrimitive num = Encode.sint32 num . coerce + encodePrimitive !num = Encode.sint32 num . coerce + {-# INLINE encodePrimitive #-} decodePrimitive = coerce Decode.sint32 primType _ = SInt32 instance Primitive (Signed Int64) where - encodePrimitive num = Encode.sint64 num . coerce + encodePrimitive !num = Encode.sint64 num . coerce + {-# INLINE encodePrimitive #-} decodePrimitive = coerce Decode.sint64 primType _ = SInt64 instance Primitive (Fixed Word32) where - encodePrimitive num = Encode.fixed32 num . coerce + encodePrimitive !num = Encode.fixed32 num . coerce + {-# INLINE encodePrimitive #-} decodePrimitive = coerce Decode.fixed32 primType _ = Fixed32 instance Primitive (Fixed Word64) where - encodePrimitive num = Encode.fixed64 num . coerce + encodePrimitive !num = Encode.fixed64 num . coerce + {-# INLINE encodePrimitive #-} decodePrimitive = coerce Decode.fixed64 primType _ = Fixed64 instance Primitive (Signed (Fixed Int32)) where - encodePrimitive num = Encode.sfixed32 num . coerce + encodePrimitive !num = Encode.sfixed32 num . coerce + {-# INLINE encodePrimitive #-} decodePrimitive = coerce Decode.sfixed32 primType _ = SFixed32 instance Primitive (Signed (Fixed Int64)) where - encodePrimitive num = Encode.sfixed64 num . coerce + encodePrimitive !num = Encode.sfixed64 num . coerce + {-# INLINE encodePrimitive #-} decodePrimitive = coerce Decode.sfixed64 primType _ = SFixed64 instance Primitive Bool where - encodePrimitive = Encode.bool + encodePrimitive !num = Encode.bool num + {-# INLINE encodePrimitive #-} decodePrimitive = Decode.bool primType _ = Bool instance Primitive Float where - encodePrimitive = Encode.float + encodePrimitive !num = Encode.float num + {-# INLINE encodePrimitive #-} decodePrimitive = Decode.float primType _ = Float instance Primitive Double where - encodePrimitive = Encode.double + encodePrimitive !num = Encode.double num + {-# INLINE encodePrimitive #-} decodePrimitive = Decode.double primType _ = Double instance Primitive T.Text where - encodePrimitive fn = Encode.text fn . TL.fromStrict + encodePrimitive !fn = Encode.text fn . TL.fromStrict + {-# INLINE encodePrimitive #-} 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 + encodePrimitive !num = Encode.text num + {-# INLINE encodePrimitive #-} 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 + encodePrimitive !num = Encode.shortText num + {-# INLINE encodePrimitive #-} 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 + encodePrimitive !num = Encode.byteString num + {-# INLINE encodePrimitive #-} 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 + encodePrimitive !num = Encode.lazyByteString num + {-# INLINE encodePrimitive #-} 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 + encodePrimitive !num = either (Encode.int32 num) (Encode.enum num) . enumerated + {-# INLINE encodePrimitive #-} decodePrimitive = coerce @(Parser RawPrimitive (Either Int32 e)) @(Parser RawPrimitive (Enumerated e)) @@ -534,7 +554,8 @@ primType _ = Named (Single (nameOf (proxy# :: Proxy# e))) instance (Primitive a) => Primitive (ForceEmit a) where - encodePrimitive num = encodePrimitive num . forceEmit + encodePrimitive !num = encodePrimitive num . forceEmit + {-# INLINE encodePrimitive #-} decodePrimitive = coerce @(Parser RawPrimitive a) @(Parser RawPrimitive (ForceEmit a)) decodePrimitive primType _ = primType (proxy# :: Proxy# a) @@ -549,9 +570,10 @@ default encodeMessageField :: (HasDefault a, Primitive a) => FieldNumber -> a -> Encode.MessageBuilder - encodeMessageField num x + encodeMessageField !num x | isDefault x = mempty | otherwise = encodePrimitive num x + {-# INLINE encodeMessageField #-} default decodeMessageField :: (HasDefault a, Primitive a) => Parser RawField a decodeMessageField = one decodePrimitive def @@ -603,7 +625,12 @@ instance (Named e, ProtoEnum e) => MessageField (Enumerated e) instance (Ord k, Primitive k, MessageField k, Primitive v, MessageField v) => MessageField (M.Map k v) where - encodeMessageField num = foldMap (Encode.embedded num . encodeMessage (fieldNumber 1)) . M.toList + encodeMessageField !num = go op + where + go f = foldMap f . M.toList + op = Encode.embedded num . encodeMessage (fieldNumber 1) + {-# INLINABLE op #-} -- To allow specialization to a particular type class or field number. + {-# INLINE encodeMessageField #-} -- Data.Map.fromList will retain the last key/value mapping. From the spec: -- @@ -614,7 +641,12 @@ protoType _ = messageField (Map (primType (proxy# :: Proxy# k)) (primType (proxy# :: Proxy# v))) Nothing instance {-# OVERLAPS #-} (Ord k, Primitive k, Named v, Message v, MessageField k) => MessageField (M.Map k (Nested v)) where - encodeMessageField num = foldMap (Encode.embedded num . encodeMessage (fieldNumber 1)) . M.toList + encodeMessageField !num = go op + where + go f = foldMap f . M.toList + op = Encode.embedded num . encodeMessage (fieldNumber 1) + {-# INLINABLE op #-} -- To allow specialization to a particular type class or field number. + {-# INLINE encodeMessageField #-} -- Data.Map.fromList will retain the last key/value mapping. From the spec: -- @@ -625,23 +657,38 @@ protoType _ = messageField (Map (primType (proxy# :: Proxy# k)) (Named . Single $ nameOf (proxy# :: Proxy# v))) Nothing instance (HasDefault a, Primitive a) => MessageField (ForceEmit a) where - encodeMessageField = encodePrimitive + encodeMessageField !num = encodePrimitive num + {-# INLINE encodeMessageField #-} instance (Named a, Message a) => MessageField (Nested a) where - encodeMessageField num = foldMap (Encode.embedded num . encodeMessage (fieldNumber 1)) - . coerce @(Nested a) @(Maybe a) + encodeMessageField !num = go op + where + go f = foldMap f . coerce @(Nested a) @(Maybe a) + op = Encode.embedded num . encodeMessage (fieldNumber 1) + {-# INLINABLE op #-} -- To allow specialization to a particular type class or field number. + {-# INLINE encodeMessageField #-} decodeMessageField = coerce @(Parser RawField (Maybe a)) @(Parser RawField (Nested a)) (Decode.embedded (decodeMessage (fieldNumber 1))) protoType _ = messageField (Prim . Named . Single $ nameOf (proxy# :: Proxy# a)) Nothing instance Primitive a => MessageField (UnpackedVec a) where - encodeMessageField fn = Encode.vectorMessageBuilder (encodePrimitive fn) . unpackedvec + encodeMessageField !fn = go op + where + go f = Encode.vectorMessageBuilder f . unpackedvec + op = encodePrimitive fn + {-# INLINABLE op #-} -- To allow specialization to a particular type class or field number. + {-# INLINE encodeMessageField #-} decodeMessageField = UnpackedVec . fromList . Foldable.toList <$> repeated decodePrimitive 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 + encodeMessageField !fn = go op + where + go f = Encode.vectorMessageBuilder f . nestedvec + op = Encode.embedded fn . encodeMessage (fieldNumber 1) + {-# INLINABLE op #-} -- To allow specialization to a particular type class or field number. + {-# INLINE encodeMessageField #-} decodeMessageField = fmap (coerce @(Vector a) @(NestedVec a) . fromList . Foldable.toList) (repeated (Decode.embedded' oneMsg)) @@ -651,12 +698,16 @@ 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.map codeFromEnumerated . packedvec + encodeMessageField !fn = + omittingDefault (Encode.packedVarintsV (fromIntegral . codeFromEnumerated) fn) + . packedvec + {-# INLINE encodeMessageField #-} -- Let 'Encode.packedVarintsV' figure out how much to inline. 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 + encodeMessageField !fn = omittingDefault (Encode.packedBoolsV id fn) . packedvec + {-# INLINE encodeMessageField #-} -- Let 'Encode.packedBoolsV' figure out how much to inline. decodeMessageField = fmap (fmap toBool) (decodePacked Decode.packedVarints) where toBool :: Word64 -> Bool @@ -665,29 +716,35 @@ protoType _ = messageField (Repeated Bool) (Just PackedField) instance MessageField (PackedVec Word32) where - encodeMessageField fn = omittingDefault (Encode.packedVarintsV fromIntegral fn) . packedvec + encodeMessageField !fn = omittingDefault (Encode.packedVarintsV fromIntegral fn) . packedvec + {-# INLINE encodeMessageField #-} -- Let 'Encode.packedVarintsV' figure out how much to inline. decodeMessageField = decodePacked Decode.packedVarints protoType _ = messageField (Repeated UInt32) (Just PackedField) instance MessageField (PackedVec Word64) where - encodeMessageField fn = omittingDefault (Encode.packedVarintsV id fn) . packedvec + encodeMessageField !fn = omittingDefault (Encode.packedVarintsV id fn) . packedvec + {-# INLINE encodeMessageField #-} -- Let 'Encode.packedVarintsV' figure out how much to inline. decodeMessageField = decodePacked Decode.packedVarints protoType _ = messageField (Repeated UInt64) (Just PackedField) instance MessageField (PackedVec Int32) where - encodeMessageField fn = omittingDefault (Encode.packedVarintsV fromIntegral fn) . packedvec + encodeMessageField !fn = omittingDefault (Encode.packedVarintsV fromIntegral fn) . packedvec + {-# INLINE encodeMessageField #-} -- Let 'Encode.packedVarintsV' figure out how much to inline. decodeMessageField = decodePacked Decode.packedVarints protoType _ = messageField (Repeated Int32) (Just PackedField) instance MessageField (PackedVec Int64) where - encodeMessageField fn = omittingDefault (Encode.packedVarintsV fromIntegral fn) . packedvec + encodeMessageField !fn = omittingDefault (Encode.packedVarintsV fromIntegral fn) . packedvec + {-# INLINE encodeMessageField #-} -- Let 'Encode.packedVarintsV' figure out how much to inline. decodeMessageField = decodePacked Decode.packedVarints protoType _ = messageField (Repeated Int64) (Just PackedField) instance MessageField (PackedVec (Signed Int32)) where - encodeMessageField fn = omittingDefault (Encode.packedVarintsV zigZag fn) . coerce @_ @(Vector Int32) + encodeMessageField !fn = + omittingDefault (Encode.packedVarintsV zigZag fn) . coerce @_ @(Vector Int32) where zigZag = fromIntegral . Encode.zigZagEncode + {-# INLINE encodeMessageField #-} -- Let 'Encode.packedVarintsV' figure out how much to inline. decodeMessageField = decodePacked (fmap (fmap zagZig) Decode.packedVarints) where @@ -700,9 +757,11 @@ protoType _ = messageField (Repeated SInt32) (Just PackedField) instance MessageField (PackedVec (Signed Int64)) where - encodeMessageField fn = omittingDefault (Encode.packedVarintsV zigZag fn) . coerce @_ @(Vector Int64) + encodeMessageField !fn = + omittingDefault (Encode.packedVarintsV zigZag fn) . coerce @_ @(Vector Int64) where zigZag = fromIntegral . Encode.zigZagEncode + {-# INLINE encodeMessageField #-} -- Let 'Encode.packedVarintsV' figure out how much to inline. decodeMessageField = decodePacked (fmap (fmap zagZig) Decode.packedVarints) where @@ -716,45 +775,56 @@ instance MessageField (PackedVec (Fixed Word32)) where - encodeMessageField fn = omittingDefault (Encode.packedFixed32V id fn) . coerce @_ @(Vector Word32) + encodeMessageField !fn = + omittingDefault (Encode.packedFixed32V id fn) . coerce @_ @(Vector Word32) + {-# INLINE encodeMessageField #-} -- Let 'Encode.packedFixed32V' figure out how much to inline. decodeMessageField = coerce @(Parser RawField (PackedVec Word32)) @(Parser RawField (PackedVec (Fixed Word32))) (decodePacked Decode.packedFixed32) protoType _ = messageField (Repeated Fixed32) (Just PackedField) instance MessageField (PackedVec (Fixed Word64)) where - encodeMessageField fn = omittingDefault (Encode.packedFixed64V id fn) . coerce @_ @(Vector Word64) + encodeMessageField !fn = + omittingDefault (Encode.packedFixed64V id fn) . coerce @_ @(Vector Word64) + {-# INLINE encodeMessageField #-} -- Let 'Encode.packedFixed64V' figure out how much to inline. decodeMessageField = coerce @(Parser RawField (PackedVec Word64)) @(Parser RawField (PackedVec (Fixed Word64))) (decodePacked Decode.packedFixed64) protoType _ = messageField (Repeated Fixed64) (Just PackedField) instance MessageField (PackedVec (Signed (Fixed Int32))) where - encodeMessageField fn = omittingDefault (Encode.packedFixed32V fromIntegral fn) . coerce @_ @(Vector Int32) + encodeMessageField !fn = + omittingDefault (Encode.packedFixed32V fromIntegral fn) . coerce @_ @(Vector Int32) + {-# INLINE encodeMessageField #-} -- Let 'Encode.packedFixed32V' figure out how much to inline. decodeMessageField = coerce @(Parser RawField (PackedVec Int32)) @(Parser RawField (PackedVec (Signed (Fixed Int32)))) (decodePacked Decode.packedFixed32) protoType _ = messageField (Repeated SFixed32) (Just PackedField) instance MessageField (PackedVec (Signed (Fixed Int64))) where - encodeMessageField fn = omittingDefault (Encode.packedFixed64V fromIntegral fn) . coerce @_ @(Vector Int64) + encodeMessageField !fn = + omittingDefault (Encode.packedFixed64V fromIntegral fn) . coerce @_ @(Vector Int64) + {-# INLINE encodeMessageField #-} -- Let 'Encode.packedFixed64V' figure out how much to inline. decodeMessageField = coerce @(Parser RawField (PackedVec Int64)) @(Parser RawField (PackedVec (Signed (Fixed Int64)))) (decodePacked Decode.packedFixed64) protoType _ = messageField (Repeated SFixed64) (Just PackedField) instance MessageField (PackedVec Float) where - encodeMessageField fn = omittingDefault (Encode.packedFloatsV id fn) . packedvec + encodeMessageField !fn = omittingDefault (Encode.packedFloatsV id fn) . packedvec + {-# INLINE encodeMessageField #-} -- Let 'Encode.packedFloatsV' figure out how much to inline. decodeMessageField = decodePacked Decode.packedFloats protoType _ = messageField (Repeated Float) (Just PackedField) instance MessageField (PackedVec Double) where - encodeMessageField fn = omittingDefault (Encode.packedDoublesV id fn) . packedvec + encodeMessageField !fn = omittingDefault (Encode.packedDoublesV id fn) . packedvec + {-# INLINE encodeMessageField #-} -- Let 'Encode.packedDoublesV' figure out how much to inline. decodeMessageField = decodePacked Decode.packedDoubles protoType _ = messageField (Repeated Double) (Just PackedField) instance (MessageField e, KnownSymbol comments) => MessageField (e // comments) where - encodeMessageField fn = encodeMessageField fn . unCommented + encodeMessageField !fn = encodeMessageField fn . unCommented + {-# INLINE encodeMessageField #-} decodeMessageField = coerce @(Parser RawField e) @(Parser RawField (Commented comments e)) decodeMessageField @@ -915,7 +985,7 @@ -- * Generic Instances -class GenericMessage (f :: * -> *) where +class GenericMessage (f :: Type -> Type) where type GenericFieldCount f :: Nat genericEncodeMessage :: FieldNumber -> f a -> Encode.MessageBuilder 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 @@ -156,11 +156,13 @@ -------------------------------------------------------------------------------- -- Inject integer scalar types +#if !(MIN_VERSION_dhall(1,41,0)) instance Dhall.ToDhall Int32 where injectWith = fmap (contramap toInteger) Dhall.injectWith instance Dhall.ToDhall Int64 where injectWith = fmap (contramap toInteger) Dhall.injectWith +#endif instance Dhall.ToDhall (Fixed Int32) where injectWith = fmap (contramap fixed) Dhall.injectWith 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 @@ -38,7 +38,8 @@ import Control.Applicative import Control.Lens ((&), ix, over, has, filtered) -import Control.Monad.Except +import Control.Monad.Except (MonadError(..), runExceptT) +import Control.Monad.IO.Class (MonadIO(..)) import Data.Char import Data.Coerce import Data.Either (partitionEithers) @@ -71,6 +72,9 @@ import qualified Turtle.Compat as Turtle (encodeString) import Turtle (FilePath, (), (<.>)) +-- $setup +-- >>> :set -XTypeApplications + -------------------------------------------------------------------------------- -- @@ -787,10 +791,12 @@ [ recDecl_ (HsIdent messageName) flds ] defaultMessageDeriving +#ifdef SWAGGER let getName = \case DotProtoMessageField fld -> (: []) <$> getFieldNameForSchemaInstanceDeclaration fld DotProtoMessageOneOf ident _ -> (: []) . (Nothing, ) <$> dpIdentUnqualName ident _ -> pure [] +#endif messageDataDecl <- mkDataDecl <$> foldMapM (messagePartFieldD messageName) messageParts @@ -922,7 +928,13 @@ [HsPWildCard, HsPRec (unqual_ msgName) punnedFieldsP] (HsUnGuardedRhs encodeMessageE) [] - encodeMessageE = apply mconcatE [HsList encodedFields] + encodeMessageE = case encodedFields of + [] -> memptyE + (field : fields) -> foldl op (paren field) fields + where op fs f = apply (apply mappendE [fs]) [paren f] + -- NOTE: We use a left fold because this way the leftmost field + -- is the most nested and the rightmost field--the one to be written + -- first by the right-to-left builder--is the one that is least nested. punnedFieldsP = map (fp . coerce . recordFieldName) qualifiedFields where fp nm = HsPFieldPat (unqual_ nm) (HsPVar (HsIdent nm)) @@ -1963,9 +1975,45 @@ RegularRecords -> [] LargeRecords -> [ importDecl_ (m "Data.Record.Generic") & qualified lrNS & everything + -- "large-records" stopped exporting "grnf"; we try + -- to get it directly from "large-generics" if we can. + -- + -- Ideally we would generate CPP conditionals so that + -- the version check happens when the generated code + -- is built, but as yet it is unclear how to do that. + -- + -- As a result, we have to enable the version check + -- based on the package version available when building + -- compile-proto-file, and only if large record support + -- is enabled in the library code. +#ifdef LARGE_RECORDS +#if MIN_VERSION_large_generics(0,2,1) + , importDecl_ (m "Data.Record.Generic.NFData") & qualified lrNS & everything +#endif +#endif , 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 + -- + -- says that as of large-records-0.4 the plugin does not generate + -- imports, and that "code must now import Data.Record.Plugin to + -- bring largeRecord into scope (necessary for ANN annotations)." + -- We also seem to need to import some Prelude identifiers. + -- + -- Ideally we would generate CPP conditionals so that + -- the version check happens when the generated code + -- is built, but as yet it is unclear how to do that. + -- + -- As a result, we have to enable the version check + -- based on the package version available when building + -- compile-proto-file, and only if large record support + -- is enabled in the library code. +#ifdef LARGE_RECORDS +#if MIN_VERSION_large_records(0,4,0) + , importDecl_ (m "Data.Record.Plugin") & unqualified & selecting [i"largeRecord"] + , importDecl_ (m "Prelude") & unqualified & selecting [i"Eq", i"Int", i"Ord", i"Show", i"error"] +#endif +#endif ] where m = Module 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,14 +1,15 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DerivingVia #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE MonoLocalBinds #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE MonoLocalBinds #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-} @@ -53,10 +54,10 @@ insOrdFromList = Data.HashMap.Strict.InsOrd.fromList -- Distinctions between varint and fixed-width formats do not matter to JSONPB. -deriving via a instance ToSchema a => ToSchema (Fixed a) +deriving newtype instance ToSchema a => ToSchema (Fixed a) -- Zig-zag encoding issues do not matter to JSONPB. -deriving via a instance ToSchema a => ToSchema (Signed a) +deriving newtype instance ToSchema a => ToSchema (Signed a) -- Packed/unpacked distinctions do not matter to JSONPB. deriving via (V.Vector a) instance ToSchema a => ToSchema (NestedVec a) @@ -65,7 +66,7 @@ -- 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) +deriving newtype instance ToSchema a => ToSchema (Wrapped a) instance ToSchema (Proto3.Suite.Types.String a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy String) diff --git a/src/Proto3/Suite/DotProto/Generate/Syntax.hs b/src/Proto3/Suite/DotProto/Generate/Syntax.hs --- a/src/Proto3/Suite/DotProto/Generate/Syntax.hs +++ b/src/Proto3/Suite/DotProto/Generate/Syntax.hs @@ -107,10 +107,9 @@ 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 + identifierC, stringLitC, intLitC, floatLitC, boolLitC, trueC, falseC, nothingC, + justC, forceEmitC, encodeMessageFieldE, fromStringE, decodeMessageFieldE, + pureE, returnE, mappendE, memptyE, msumE, atE, oneofE, fmapE :: HsExp dotProtoFieldC = HsVar (protobufASTName "DotProtoField") primC = HsVar (protobufASTName "Prim") @@ -140,10 +139,10 @@ 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") +mappendE = HsVar (haskellName "mappend") memptyE = HsVar (haskellName "mempty") msumE = HsVar (haskellName "msum") fmapE = HsVar (haskellName "fmap") 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,15 +1,16 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingVia #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE OverloadedLists #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# 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 @@ -73,7 +74,9 @@ (.!=)) import qualified Data.Aeson.Encoding as E import qualified Data.Aeson.Encoding.Internal as E +#if !MIN_VERSION_aeson(2,1,0) import qualified Data.Aeson.Internal as A (formatError, iparse) +#endif #if MIN_VERSION_aeson(2,0,0) import qualified Data.Aeson.Key as A #endif @@ -82,7 +85,14 @@ Series, explicitParseField, explicitParseFieldMaybe, - object, toJSONKeyText, +#if MIN_VERSION_aeson(2,1,0) + formatError, + iparse, +#endif + object, +#if !(MIN_VERSION_aeson(2,0,2)) + toJSONKeyText, +#endif typeMismatch,) import qualified Data.Attoparsec.ByteString as Atto (skipWhile) import qualified Data.Attoparsec.ByteString.Char8 as Atto (Parser, endOfInput) @@ -154,10 +164,10 @@ parseJSONPB = pure -- | JSONPB format shortcuts Google wrappers types. -deriving via a instance FromJSONPB a => FromJSONPB (Wrapped a) +deriving newtype instance FromJSONPB a => FromJSONPB (Wrapped a) -- | JSONPB format shortcuts Google wrappers types. -deriving via a instance ToJSONPB a => ToJSONPB (Wrapped a) +deriving newtype instance ToJSONPB a => ToJSONPB (Wrapped a) -- * JSONPB codec entry points @@ -219,13 +229,13 @@ => A.Object -> Key -> A.Parser a parseField = A.explicitParseField parseJSONPB --- | >>> isDefault (def @E.Encoding) +-- | >>> isDefault (def :: E.Encoding) -- True instance HasDefault E.Encoding where def = E.empty isDefault = E.nullEncoding --- | >>> isDefault (def @A.Value) +-- | >>> isDefault (def :: A.Value) -- True instance HasDefault A.Value where def = A.Null @@ -398,12 +408,12 @@ parseJSONPB = parseNumOrDecimalString "int64 / sint64" -- 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) +deriving newtype instance FromJSONPB a => FromJSONPB (Fixed a) +deriving newtype instance ToJSONPB a => ToJSONPB (Fixed a) -- 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) +deriving newtype instance FromJSONPB a => FromJSONPB (Signed a) +deriving newtype instance ToJSONPB a => ToJSONPB (Signed a) -------------------------------------------------------------------------------- -- Floating point scalar types @@ -449,8 +459,8 @@ 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) +deriving newtype instance ToJSONPB a => ToJSONPB (Proto3.Suite.Types.String a) +deriving newtype instance FromJSONPB a => FromJSONPB (Proto3.Suite.Types.String a) -- bytes @@ -469,8 +479,8 @@ 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) +deriving newtype instance ToJSONPB a => ToJSONPB (Proto3.Suite.Types.Bytes a) +deriving newtype instance FromJSONPB a => FromJSONPB (Proto3.Suite.Types.Bytes a) -------------------------------------------------------------------------------- -- Enumerated types @@ -543,11 +553,11 @@ -------------------------------------------------------------------------------- -- 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 newtype instance A.FromJSONKey a => A.FromJSONKey (Fixed a) +deriving newtype 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 newtype instance A.FromJSONKey a => A.FromJSONKey (Signed a) +deriving newtype 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) diff --git a/src/Proto3/Suite/Tutorial.hs b/src/Proto3/Suite/Tutorial.hs --- a/src/Proto3/Suite/Tutorial.hs +++ b/src/Proto3/Suite/Tutorial.hs @@ -1,8 +1,6 @@ -- | -- = Tutorial -- --- >>> :set -XOverloadedStrings --- -- This module contains a worked example of encoding and decoding messages, -- and exporting a corresponding .proto file from Haskell types. -- @@ -41,6 +39,9 @@ enum, message, packageFromDefs, toProtoFileDef) import Proto3.Wire.Class (ProtoEnum) +-- $setup +-- >>> :set -XOverloadedStrings + -- | -- == Defining Message Types -- @@ -65,7 +66,7 @@ -- -- We can also decode messages using `fromByteString`: -- --- >>> Proto3.Suite.fromByteString "\b*\DC2\SOH{" :: Either [Proto3.Suite..Decode.Parser.ParseError] Foo +-- >>> Proto3.Suite.fromByteString "\b*\DC2\SOH{" :: Either Proto3.Wire.Decode.ParseError Foo -- Right (Foo {fooX = 42, fooY = PackedVec {packedvec = [123]}}) data Foo = Foo { fooX :: Word32 @@ -125,12 +126,12 @@ -- } -- message Foo { -- uint32 fooX = 1; --- repeated int32 fooY = 2 [packed=true]; +-- repeated int32 fooY = 2 [packed = true]; -- } -- message Bar { -- Shape barShape = 1; -- Foo barFoo = 2; --- repeated Foo foos = 3 [packed=false]; +-- repeated Foo foos = 3; -- } protoFile :: String 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 @@ -35,6 +35,7 @@ import Control.DeepSeq (NFData) import GHC.Exts (IsList(..)) import GHC.Generics +import Data.Function (on) import Data.Int (Int32) import qualified Data.Vector as V import GHC.TypeLits (Symbol) @@ -55,8 +56,17 @@ -- | 'Enumerated' lifts any type with an 'IsEnum' instance so that it can be encoded -- with 'HasEncoding'. newtype Enumerated a = Enumerated { enumerated :: Either Int32 a } - deriving (Show, Eq, Ord, Generic, NFData - , Functor, Foldable, Traversable) + deriving (Show, Generic, NFData, Functor, Foldable, Traversable) + +-- | We consider two enumerated values to be equal if they serialize to the same code. +instance ProtoEnum a => Eq (Enumerated a) where + (==) = (==) `on` either id fromProtoEnum . enumerated + {-# INLINABLE (==) #-} + +-- | We compare two enumerated values by comparing the code to which they serialize. +instance ProtoEnum a => Ord (Enumerated a) where + compare = compare `on` either id fromProtoEnum . enumerated + {-# INLINABLE compare #-} instance ProtoEnum a => Arbitrary (Enumerated a) where arbitrary = do diff --git a/tests/ArbitraryGeneratedTestTypes.hs b/tests/ArbitraryGeneratedTestTypes.hs --- a/tests/ArbitraryGeneratedTestTypes.hs +++ b/tests/ArbitraryGeneratedTestTypes.hs @@ -4,7 +4,6 @@ module ArbitraryGeneratedTestTypes where 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) @@ -14,10 +13,6 @@ 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 diff --git a/tests/Main.hs b/tests/Main.hs --- a/tests/Main.hs +++ b/tests/Main.hs @@ -66,9 +66,8 @@ docTests = testCase "doctests" $ do putStrLn "Running all doctests..." Test.DocTest.doctest - [ "-isrc" - , "-itests" - , "-igen" + [ "--verbose" + , "-isrc" #ifdef SWAGGER #ifdef SWAGGER_WRAPPER_FORMAT , "-isrc/swagger-wrapper-format" @@ -85,8 +84,9 @@ , "-DLARGE_RECORDS" #endif , "src/Proto3/Suite/DotProto/Internal.hs" + , "src/Proto3/Suite/DotProto/Generate.hs" , "src/Proto3/Suite/JSONPB/Class.hs" - , "tests/TestCodeGen.hs" + , "src/Proto3/Suite/Tutorial.hs" ] -------------------------------------------------------------------------------- @@ -327,11 +327,11 @@ ++ "\n\nInitial AST:\n\n" dotProtoRoundtripExtend :: TestTree -dotProtoRoundtripExtend = +dotProtoRoundtripExtend = let expected :: DotProto expected = DotProto [] [] DotProtoNoPackage [] (DotProtoMeta (Path ("test-files" NE.:| ["test_proto_extend"]))) in testCase - "Round-trip for a message extension" + "Round-trip for a message extension" (testDotProtoRoundtrip expected) -------------------------------------------------------------------------------- diff --git a/tests/TestCodeGen.hs b/tests/TestCodeGen.hs --- a/tests/TestCodeGen.hs +++ b/tests/TestCodeGen.hs @@ -1,6 +1,8 @@ {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE CPP #-} +{-# LANGUAGE DisambiguateRecordFields #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedLists #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} @@ -12,7 +14,6 @@ import Control.Monad import qualified Data.Aeson import qualified Data.ByteString.Lazy as LBS -import qualified Data.ByteString.Lazy.Char8 as LBS8 import Data.Proxy (Proxy(..)) import Data.String (IsString) import Data.Swagger (ToSchema) @@ -22,21 +23,30 @@ tyConName, typeRep) import Google.Protobuf.Timestamp (Timestamp(..)) import Prelude hiding (FilePath) +import Proto3.Suite.Class (def) import Proto3.Suite.DotProto.Generate import Proto3.Suite.DotProto (fieldLikeName, prefixedEnumFieldName, typeLikeName) import Proto3.Suite.JSONPB (FromJSONPB (..), Options (..), - ToJSONPB (..), eitherDecode, - encode, defaultOptions) + ToJSONPB (..), defaultOptions, + eitherDecode, encode, + jsonPBOptions) +import Proto3.Suite.Types (Enumerated(..)) import System.Exit import Test.Tasty import Test.Tasty.HUnit (testCase, (@?=)) +import Test.Tasty.QuickCheck (Arbitrary, (===), testProperty) import qualified Turtle import qualified Turtle.Format as F +import qualified TestProto +import qualified TestProtoOneof import qualified TestProtoWrappers codeGenTests :: TestTree codeGenTests = testGroup "Code generator unit tests" - [ swaggerWrapperFormat + [ jsonpbTests + , swaggerTests + , hasDefaultTests + , swaggerWrapperFormat , pascalCaseMessageNames , camelCaseMessageFieldNames , don'tAlterEnumFieldNames @@ -65,17 +75,17 @@ "{\"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\"}" + "{\"properties\":{\"wrapper\":{\"format\":\"Int64Value\",\"maximum\":9223372036854775807,\"minimum\":-9223372036854775808,\"type\":\"integer\"}},\"type\":\"object\"}" + "{\"properties\":{\"wrapper\":{\"format\":\"int64\",\"maximum\":9223372036854775807,\"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\"}" + "{\"properties\":{\"wrapper\":{\"format\":\"UInt64Value\",\"maximum\":18446744073709551615,\"minimum\":0,\"type\":\"integer\"}},\"type\":\"object\"}" + "{\"properties\":{\"wrapper\":{\"format\":\"int64\",\"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\"}" + "{\"properties\":{\"wrapper\":{\"format\":\"Int32Value\",\"maximum\":2147483647,\"minimum\":-2147483648,\"type\":\"integer\"}},\"type\":\"object\"}" + "{\"properties\":{\"wrapper\":{\"format\":\"int32\",\"maximum\":2147483647,\"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\"}" + "{\"properties\":{\"wrapper\":{\"format\":\"UInt32Value\",\"maximum\":4294967295,\"minimum\":0,\"type\":\"integer\"}},\"type\":\"object\"}" + "{\"properties\":{\"wrapper\":{\"format\":\"int32\",\"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\"}" @@ -174,11 +184,11 @@ compileTestDotProtos recStyle decodedStringType -- Compile our generated encoder - let args = [hsTmpDir] + let encodeCmd = "tests/encode.sh " <> hsTmpDir #if DHALL - ++ ["-DDHALL"] + <> " -DDHALL" #endif - Turtle.proc "tests/encode.sh" args empty >>= (@?= ExitSuccess) + Turtle.shell encodeCmd empty >>= (@?= ExitSuccess) -- The python encoder test exits with a special error code to indicate -- all tests were successful @@ -200,11 +210,11 @@ compileTestDotProtos recStyle decodedStringType -- Compile our generated decoder - let args = [hsTmpDir] + let decodeCmd = "tests/decode.sh " <> hsTmpDir #if DHALL - ++ ["-DDHALL"] + <> " -DDHALL" #endif - Turtle.proc "tests/decode.sh" args empty >>= (@?= ExitSuccess) + Turtle.shell decodeCmd empty >>= (@?= ExitSuccess) setPythonPath let cmd = "python tests/send_simple_dot_proto.py " <> format <> " | FORMAT=" <> format <> " " <> hsTmpDir <> "/simpleDecodeDotProto " @@ -227,7 +237,8 @@ compileTestDotProtos recStyle decodedStringType = do Turtle.mktree hsTmpDir Turtle.mktree pyTmpDir - let protoFiles = + let protoFiles :: [Turtle.FilePath] + protoFiles = [ "test_proto.proto" , "test_proto_import.proto" , "test_proto_oneof.proto" @@ -259,111 +270,151 @@ Turtle.touch (pyTmpDir Turtle. "__init__.py") --- * Doctests for JSONPB - --- $setup --- >>> import qualified Data.Text.Lazy as TL --- >>> import qualified Data.Vector as V --- >>> import Proto3.Suite --- >>> import Proto3.Suite.JSONPB --- >>> import TestProto --- >>> import TestProtoOneof --- >>> import TestProtoWrappers --- >>> :set -XOverloadedStrings --- >>> :set -XOverloadedLists --- >>> :set -XTypeApplications --- >>> let jsonPB = jsonPBOptions --- >>> let json = defaultOptions +jsonpbTests :: TestTree +jsonpbTests = testGroup "JSONPB tests" + [ testGroup "Round-trip tests" + [ roundTripTest @TestProto.Trivial + , roundTripTest @TestProto.MultipleFields + , roundTripTest @TestProto.SignedInts + , testProperty "roundTrip (SignedInts minBound minBound)" $ + roundTrip (TestProto.SignedInts minBound minBound) + , testProperty "roundTrip (SignedInts maxBound maxBound)" $ + roundTrip (TestProto.SignedInts maxBound maxBound) + , testProperty "roundTrip . WithEnum . Enumerated . Right" $ + roundTrip . TestProto.WithEnum . Enumerated . Right + , roundTripTest @TestProto.WithNesting + , roundTripTest @TestProto.WithNestingRepeated + , roundTripTest @TestProto.WithNestingRepeatedInts + , roundTripTest @TestProto.WithBytes + , roundTripTest @TestProto.OutOfOrderFields + , roundTripTest @TestProto.UsingImported + , roundTripTest @TestProto.Wrapped + , roundTripTest @TestProtoOneof.Something + , roundTripTest @TestProtoOneof.WithImported + ] + , testGroup "Specific encoding tests" $ + let jsonPB = jsonPBOptions + json = defaultOptions + in + [ encodesAs jsonPB (TestProto.MultipleFields 0 0 0 0 "" False) "{}" + , encodesAs json (TestProto.MultipleFields 0 2.0 0 0 "" True) "{\"multiFieldDouble\":0.0,\"multiFieldFloat\":2.0,\"multiFieldInt32\":0,\"multiFieldInt64\":\"0\",\"multiFieldString\":\"\",\"multiFieldBool\":true}" + , encodesAs jsonPB (TestProto.SignedInts minBound minBound) + "{\"signed32\":-2147483648,\"signed64\":\"-9223372036854775808\"}" + , encodesAs jsonPB (TestProto.SignedInts maxBound maxBound) + "{\"signed32\":2147483647,\"signed64\":\"9223372036854775807\"}" + , encodesAs jsonPB (TestProto.WithEnum (Enumerated (Right TestProto.WithEnum_TestEnumENUM1))) + "{}" + , encodesAs json (TestProto.WithEnum (Enumerated (Right TestProto.WithEnum_TestEnumENUM1))) + "{\"enumField\":\"ENUM1\"}" + , encodesAs jsonPB (TestProto.WithEnum (Enumerated (Right TestProto.WithEnum_TestEnumENUM3))) + "{\"enumField\":\"ENUM3\"}" + , encodesAs jsonPB (TestProto.WithNesting $ Just $ TestProto.WithNesting_Nested "" 0 [1,2] [66,99]) + "{\"nestedMessage\":{\"nestedPacked\":[1,2],\"nestedUnpacked\":[66,99]}}" + , encodesAs jsonPB (TestProtoOneof.Something 42 99 (Just (TestProtoOneof.SomethingPickOneName ""))) + "{\"value\":\"42\",\"another\":99,\"name\":\"\"}" + , encodesAs jsonPB (TestProtoOneof.Something 42 99 (Just (TestProtoOneof.SomethingPickOneSomeid 0))) + "{\"value\":\"42\",\"another\":99,\"someid\":0}" + , encodesAs jsonPB (TestProtoOneof.Something 42 99 (Just (TestProtoOneof.SomethingPickOneDummyMsg1 (TestProtoOneof.DummyMsg 66)))) + "{\"value\":\"42\",\"another\":99,\"dummyMsg1\":{\"dummy\":66}}" + , encodesAs jsonPB (TestProtoOneof.Something 42 99 (Just (TestProtoOneof.SomethingPickOneDummyMsg2 (TestProtoOneof.DummyMsg 67)))) + "{\"value\":\"42\",\"another\":99,\"dummyMsg2\":{\"dummy\":67}}" + , encodesAs jsonPB (TestProtoOneof.Something 42 99 (Just (TestProtoOneof.SomethingPickOneDummyEnum (Enumerated (Right TestProtoOneof.DummyEnumDUMMY0))))) + "{\"value\":\"42\",\"another\":99,\"dummyEnum\":\"DUMMY0\"}" + , encodesAs jsonPB (TestProtoOneof.Something 42 99 Nothing) + "{\"value\":\"42\",\"another\":99}" + , encodesAs json (TestProtoOneof.Something 42 99 (Just (TestProtoOneof.SomethingPickOneName ""))) + "{\"value\":\"42\",\"another\":99,\"pickOne\":{\"name\":\"\"}}" + , encodesAs json (TestProtoOneof.Something 42 99 (Just (TestProtoOneof.SomethingPickOneSomeid 0))) + "{\"value\":\"42\",\"another\":99,\"pickOne\":{\"someid\":0}}" + , encodesAs json (TestProtoOneof.Something 42 99 (Just (TestProtoOneof.SomethingPickOneDummyMsg1 (TestProtoOneof.DummyMsg 66)))) + "{\"value\":\"42\",\"another\":99,\"pickOne\":{\"dummyMsg1\":{\"dummy\":66}}}" + , encodesAs json (TestProtoOneof.Something 42 99 (Just (TestProtoOneof.SomethingPickOneDummyMsg2 (TestProtoOneof.DummyMsg 67)))) + "{\"value\":\"42\",\"another\":99,\"pickOne\":{\"dummyMsg2\":{\"dummy\":67}}}" + , encodesAs json (TestProtoOneof.Something 42 99 (Just (TestProtoOneof.SomethingPickOneDummyEnum (Enumerated (Right TestProtoOneof.DummyEnumDUMMY0))))) + "{\"value\":\"42\",\"another\":99,\"pickOne\":{\"dummyEnum\":\"DUMMY0\"}}" + , encodesAs json (TestProtoOneof.Something 42 99 Nothing) + "{\"value\":\"42\",\"another\":99,\"pickOne\":null}" + ] + , testGroup "Specific decoding tests" $ + [ decodesAs "{\"signed32\":2147483647,\"signed64\":\"9223372036854775807\"}" + (TestProto.SignedInts 2147483647 9223372036854775807) + , decodesAs "{\"enumField\":\"ENUM3\"}" (TestProto.WithEnum (Enumerated (Right TestProto.WithEnum_TestEnumENUM3))) + , decodesAs "{\"enumField\":null}" + (TestProto.WithEnum (Enumerated (Right TestProto.WithEnum_TestEnumENUM1))) + , decodesAs "{}" + (TestProto.WithEnum (Enumerated (Right TestProto.WithEnum_TestEnumENUM1))) + , decodesAs "{\"nestedMessage\":{}}" + (TestProto.WithNesting $ Just $ TestProto.WithNesting_Nested "" 0 [] []) + , testGroup "JSONPB" + [ decodesAs "{\"value\":\"42\",\"another\":99,\"someid\":66}" + (TestProtoOneof.Something 42 99 (Just (TestProtoOneof.SomethingPickOneSomeid 66))) + , decodesAs "{\"value\":\"42\",\"another\":99,\"name\":\"foo\"}" + (TestProtoOneof.Something 42 99 (Just (TestProtoOneof.SomethingPickOneName "foo"))) + , decodesAs "{\"value\":\"42\",\"another\":99,\"dummyMsg1\":{\"dummy\":41}}" + (TestProtoOneof.Something 42 99 (Just (TestProtoOneof.SomethingPickOneDummyMsg1 (TestProtoOneof.DummyMsg 41)))) + , decodesAs "{\"value\":\"42\",\"another\":99,\"dummyMsg2\":{\"dummy\":43}}" + (TestProtoOneof.Something 42 99 (Just (TestProtoOneof.SomethingPickOneDummyMsg2 (TestProtoOneof.DummyMsg 43)))) + , decodesAs "{\"value\":\"42\",\"another\":99,\"dummyEnum\":\"DUMMY0\"}" + (TestProtoOneof.Something 42 99 (Just (TestProtoOneof.SomethingPickOneDummyEnum (Enumerated (Right TestProtoOneof.DummyEnumDUMMY0))))) + , decodesAs "{\"value\":\"42\",\"another\":99}" + (TestProtoOneof.Something 42 99 Nothing) + ] + , testGroup "JSON" + [ decodesAs "{\"value\":\"42\",\"another\":99,\"pickOne\":{\"name\":\"\"}}" + (TestProtoOneof.Something 42 99 (Just (TestProtoOneof.SomethingPickOneName ""))) + , decodesAs "{\"value\":\"42\",\"another\":99,\"pickOne\":{\"someid\":0}}" + (TestProtoOneof.Something 42 99 (Just (TestProtoOneof.SomethingPickOneSomeid 0))) + , decodesAs "{\"value\":\"42\",\"another\":99,\"pickOne\":{\"dummyMsg1\":{\"dummy\":66}}}" + (TestProtoOneof.Something 42 99 (Just (TestProtoOneof.SomethingPickOneDummyMsg1 (TestProtoOneof.DummyMsg 66)))) + , decodesAs "{\"value\":\"42\",\"another\":99,\"pickOne\":{\"dummyMsg2\":{\"dummy\":67}}}" + (TestProtoOneof.Something 42 99 (Just (TestProtoOneof.SomethingPickOneDummyMsg2 (TestProtoOneof.DummyMsg 67)))) + , decodesAs "{\"value\":\"42\",\"another\":99,\"pickOne\":{\"dummyEnum\":\"DUMMY0\"}}" + (TestProtoOneof.Something 42 99 (Just (TestProtoOneof.SomethingPickOneDummyEnum (Enumerated (Right TestProtoOneof.DummyEnumDUMMY0))))) + , decodesAs "{\"value\":\"42\",\"another\":99,\"pickOne\":{}}" (TestProtoOneof.Something 42 99 Nothing) + , decodesAs "{\"value\":\"42\",\"another\":99,\"pickOne\":null}" (TestProtoOneof.Something 42 99 Nothing) + ] + ] + ] --- | Round-trip tests --- prop> roundTrip (x :: Trivial) --- prop> roundTrip (x :: MultipleFields) --- prop> roundTrip (x :: SignedInts) --- prop> roundTrip (SignedInts minBound minBound) --- prop> roundTrip (SignedInts maxBound maxBound) --- prop> roundTrip (WithEnum (Enumerated (Right x))) --- prop> roundTrip (x :: WithNesting) --- prop> roundTrip (x :: WithNestingRepeated) --- prop> roundTrip (x :: WithNestingRepeatedInts) --- prop> roundTrip (x :: WithBytes) --- prop> roundTrip (x :: OutOfOrderFields) --- prop> roundTrip (x :: UsingImported) --- prop> roundTrip (x :: Wrapped) --- prop> roundTrip (x :: Something) --- prop> roundTrip (x :: WithImported) +swaggerTests :: TestTree +swaggerTests = testGroup "Swagger tests" + [ schemaOf @TestProtoOneof.Something + "{\"properties\":{\"value\":{\"format\":\"int64\",\"maximum\":9223372036854775807,\"minimum\":-9223372036854775808,\"type\":\"integer\"},\"another\":{\"format\":\"int32\",\"maximum\":2147483647,\"minimum\":-2147483648,\"type\":\"integer\"},\"pickOne\":{\"$ref\":\"#/definitions/SomethingPickOne\"}},\"type\":\"object\"}" + , schemaOf @TestProtoOneof.SomethingPickOne + "{\"properties\":{\"name\":{\"type\":\"string\"},\"someid\":{\"format\":\"int32\",\"maximum\":2147483647,\"minimum\":-2147483648,\"type\":\"integer\"},\"dummyMsg1\":{\"$ref\":\"#/definitions/DummyMsg\"},\"dummyMsg2\":{\"$ref\":\"#/definitions/DummyMsg\"},\"dummyEnum\":{\"$ref\":\"#/definitions/DummyEnum\"}},\"maxProperties\":1,\"minProperties\":1,\"type\":\"object\"}" + , schemaOf @TestProtoOneof.DummyMsg + "{\"properties\":{\"dummy\":{\"format\":\"int32\",\"maximum\":2147483647,\"minimum\":-2147483648,\"type\":\"integer\"}},\"type\":\"object\"}" + , schemaOf @(Enumerated TestProtoOneof.DummyEnum) + "{\"enum\":[\"DUMMY0\",\"DUMMY1\"],\"type\":\"string\"}" --- | Specific encoding tests --- prop> encodesAs jsonPB (MultipleFields 0 0 0 0 "" False) "{}" --- prop> encodesAs json (MultipleFields 0 2.0 0 0 "" True) "{\"multiFieldDouble\":0.0,\"multiFieldFloat\":2.0,\"multiFieldInt32\":0,\"multiFieldInt64\":\"0\",\"multiFieldString\":\"\",\"multiFieldBool\":true}" --- prop> encodesAs jsonPB (SignedInts minBound minBound) "{\"signed32\":-2147483648,\"signed64\":\"-9223372036854775808\"}" --- prop> encodesAs jsonPB (SignedInts maxBound maxBound) "{\"signed32\":2147483647,\"signed64\":\"9223372036854775807\"}" --- prop> encodesAs jsonPB (WithEnum (Enumerated (Right WithEnum_TestEnumENUM1))) "{}" --- prop> encodesAs json (WithEnum (Enumerated (Right WithEnum_TestEnumENUM1))) "{\"enumField\":\"ENUM1\"}" --- prop> encodesAs jsonPB (WithEnum (Enumerated (Right WithEnum_TestEnumENUM3))) "{\"enumField\":\"ENUM3\"}" --- prop> encodesAs jsonPB (WithNesting $ Just $ WithNesting_Nested "" 0 [1,2] [66,99]) "{\"nestedMessage\":{\"nestedPacked\":[1,2],\"nestedUnpacked\":[66,99]}}" --- prop> encodesAs jsonPB (Something 42 99 (Just (SomethingPickOneName ""))) "{\"value\":\"42\",\"another\":99,\"name\":\"\"}" --- prop> encodesAs jsonPB (Something 42 99 (Just (SomethingPickOneSomeid 0))) "{\"value\":\"42\",\"another\":99,\"someid\":0}" --- prop> encodesAs jsonPB (Something 42 99 (Just (SomethingPickOneDummyMsg1 (DummyMsg 66)))) "{\"value\":\"42\",\"another\":99,\"dummyMsg1\":{\"dummy\":66}}" --- prop> encodesAs jsonPB (Something 42 99 (Just (SomethingPickOneDummyMsg2 (DummyMsg 67)))) "{\"value\":\"42\",\"another\":99,\"dummyMsg2\":{\"dummy\":67}}" --- prop> encodesAs jsonPB (Something 42 99 (Just (SomethingPickOneDummyEnum (Enumerated (Right DummyEnumDUMMY0))))) "{\"value\":\"42\",\"another\":99,\"dummyEnum\":\"DUMMY0\"}" --- prop> encodesAs jsonPB (Something 42 99 Nothing) "{\"value\":\"42\",\"another\":99}" --- prop> encodesAs json (Something 42 99 (Just (SomethingPickOneName ""))) "{\"value\":\"42\",\"another\":99,\"pickOne\":{\"name\":\"\"}}" --- prop> encodesAs json (Something 42 99 (Just (SomethingPickOneSomeid 0))) "{\"value\":\"42\",\"another\":99,\"pickOne\":{\"someid\":0}}" --- prop> encodesAs json (Something 42 99 (Just (SomethingPickOneDummyMsg1 (DummyMsg 66)))) "{\"value\":\"42\",\"another\":99,\"pickOne\":{\"dummyMsg1\":{\"dummy\":66}}}" --- prop> encodesAs json (Something 42 99 (Just (SomethingPickOneDummyMsg2 (DummyMsg 67)))) "{\"value\":\"42\",\"another\":99,\"pickOne\":{\"dummyMsg2\":{\"dummy\":67}}}" --- prop> encodesAs json (Something 42 99 (Just (SomethingPickOneDummyEnum (Enumerated (Right DummyEnumDUMMY0))))) "{\"value\":\"42\",\"another\":99,\"pickOne\":{\"dummyEnum\":\"DUMMY0\"}}" --- prop> encodesAs json (Something 42 99 Nothing) "{\"value\":\"42\",\"another\":99,\"pickOne\":null}" + ] --- | Specific decoding tests --- prop> decodesAs "{\"signed32\":2147483647,\"signed64\":\"9223372036854775807\"}" (SignedInts 2147483647 9223372036854775807) --- prop> decodesAs "{\"enumField\":\"ENUM3\"}" (WithEnum (Enumerated (Right WithEnum_TestEnumENUM3))) --- prop> decodesAs "{\"enumField\":null}" (WithEnum (Enumerated (Right WithEnum_TestEnumENUM1))) --- prop> decodesAs "{}" (WithEnum (Enumerated (Right WithEnum_TestEnumENUM1))) --- prop> decodesAs "{\"nestedMessage\":{}}" (WithNesting $ Just $ WithNesting_Nested "" 0 [] []) --- --- JSONPB --- --- prop> decodesAs "{\"value\":\"42\",\"another\":99,\"someid\":66}" (Something 42 99 (Just (SomethingPickOneSomeid 66))) --- prop> decodesAs "{\"value\":\"42\",\"another\":99,\"name\":\"foo\"}" (Something 42 99 (Just (SomethingPickOneName "foo"))) --- prop> decodesAs "{\"value\":\"42\",\"another\":99,\"dummyMsg1\":{\"dummy\":41}}" (Something 42 99 (Just (SomethingPickOneDummyMsg1 (DummyMsg 41)))) --- prop> decodesAs "{\"value\":\"42\",\"another\":99,\"dummyMsg2\":{\"dummy\":43}}" (Something 42 99 (Just (SomethingPickOneDummyMsg2 (DummyMsg 43)))) --- prop> decodesAs "{\"value\":\"42\",\"another\":99,\"dummyEnum\":\"DUMMY0\"}" (Something 42 99 (Just (SomethingPickOneDummyEnum (Enumerated (Right DummyEnumDUMMY0))))) --- prop> decodesAs "{\"value\":\"42\",\"another\":99}" (Something 42 99 Nothing) --- --- JSON --- --- prop> decodesAs "{\"value\":\"42\",\"another\":99,\"pickOne\":{\"name\":\"\"}}" (Something 42 99 (Just (SomethingPickOneName ""))) --- prop> decodesAs "{\"value\":\"42\",\"another\":99,\"pickOne\":{\"someid\":0}}" (Something 42 99 (Just (SomethingPickOneSomeid 0))) --- prop> decodesAs "{\"value\":\"42\",\"another\":99,\"pickOne\":{\"dummyMsg1\":{\"dummy\":66}}}" (Something 42 99 (Just (SomethingPickOneDummyMsg1 (DummyMsg 66)))) --- prop> decodesAs "{\"value\":\"42\",\"another\":99,\"pickOne\":{\"dummyMsg2\":{\"dummy\":67}}}" (Something 42 99 (Just (SomethingPickOneDummyMsg2 (DummyMsg 67)))) --- prop> decodesAs "{\"value\":\"42\",\"another\":99,\"pickOne\":{\"dummyEnum\":\"DUMMY0\"}}" (Something 42 99 (Just (SomethingPickOneDummyEnum (Enumerated (Right DummyEnumDUMMY0))))) --- prop> decodesAs "{\"value\":\"42\",\"another\":99,\"pickOne\":{}}" (Something 42 99 Nothing) --- prop> decodesAs "{\"value\":\"42\",\"another\":99,\"pickOne\":null}" (Something 42 99 Nothing) --- --- Swagger --- --- >>> schemaOf @Something --- {"properties":{"value":{"maximum":9223372036854775807,"format":"int64","minimum":-9223372036854775808,"type":"integer"},"another":{"maximum":2147483647,"format":"int32","minimum":-2147483648,"type":"integer"},"pickOne":{"$ref":"#/definitions/SomethingPickOne"}},"type":"object"} --- >>> schemaOf @SomethingPickOne --- {"properties":{"name":{"type":"string"},"someid":{"maximum":2147483647,"format":"int32","minimum":-2147483648,"type":"integer"},"dummyMsg1":{"$ref":"#/definitions/DummyMsg"},"dummyMsg2":{"$ref":"#/definitions/DummyMsg"},"dummyEnum":{"$ref":"#/definitions/DummyEnum"}},"maxProperties":1,"minProperties":1,"type":"object"} --- >>> schemaOf @DummyMsg --- {"properties":{"dummy":{"maximum":2147483647,"format":"int32","minimum":-2147483648,"type":"integer"}},"type":"object"} --- >>> schemaOf @(Enumerated DummyEnum) --- {"type":"string","enum":["DUMMY0","DUMMY1"]} --- --- Generic HasDefault --- --- >>> def :: MultipleFields --- MultipleFields {multipleFieldsMultiFieldDouble = 0.0, multipleFieldsMultiFieldFloat = 0.0, multipleFieldsMultiFieldInt32 = 0, multipleFieldsMultiFieldInt64 = 0, multipleFieldsMultiFieldString = "", multipleFieldsMultiFieldBool = False} --- >>> def :: WithNesting --- WithNesting {withNestingNestedMessage = Nothing} --- >>> def :: WithNestingRepeated --- WithNestingRepeated {withNestingRepeatedNestedMessages = []} --- >>> def :: WithEnum --- WithEnum {withEnumEnumField = Enumerated {enumerated = Right WithEnum_TestEnumENUM1}} +hasDefaultTests :: TestTree +hasDefaultTests = testGroup "Generic HasDefault" + [ testProperty "MultipleFields" $ + (def :: TestProto.MultipleFields) === + TestProto.MultipleFields {multipleFieldsMultiFieldDouble = 0.0, multipleFieldsMultiFieldFloat = 0.0, multipleFieldsMultiFieldInt32 = 0, multipleFieldsMultiFieldInt64 = 0, multipleFieldsMultiFieldString = "", multipleFieldsMultiFieldBool = False} + , testProperty "WithNesting" $ + (def :: TestProto.WithNesting) === + TestProto.WithNesting {withNestingNestedMessage = Nothing} + , testProperty "WithNestingRepeated" $ + (def :: TestProto.WithNestingRepeated) === + TestProto.WithNestingRepeated {withNestingRepeatedNestedMessages = []} + , testProperty "WithEnum" $ + (def :: TestProto.WithEnum) === + TestProto.WithEnum {withEnumEnumField = Enumerated {enumerated = Right TestProto.WithEnum_TestEnumENUM1}} + ] -- * Helper quickcheck props +roundTripTest :: + forall a . + (ToJSONPB a, FromJSONPB a, Eq a, Arbitrary a, Show a, Typeable a) => + TestTree +roundTripTest = + testProperty ("roundTripTest @" ++ show (typeRep (Proxy :: Proxy a))) $ + roundTrip @a + roundTrip :: (ToJSONPB a, FromJSONPB a, Eq a) => a -> Bool roundTrip x = roundTrip' False && roundTrip' True @@ -373,16 +424,47 @@ == Right x -encodesAs :: (ToJSONPB a) - => Options -> a -> LBS.ByteString -> Bool -encodesAs opts x bs = encode opts x == bs +encodesAs :: + forall a . + (ToJSONPB a, Eq a, Show a, Typeable a) => + Options -> a -> LBS.ByteString -> TestTree +encodesAs opts x bs = testProperty (testName "") (encode opts x === bs) + where + testName = + showString "encode @" . + showsPrec 11 (typeRep (Proxy :: Proxy a)) . + showChar ' ' . + showsPrec 11 opts . + showChar ' ' . + showsPrec 11 x . + showString " == " . + showsPrec 5 bs -decodesAs :: (Eq a, FromJSONPB a) - => LBS.ByteString -> a -> Bool -decodesAs bs x = eitherDecode bs == Right x +decodesAs :: + forall a . + (FromJSONPB a, Eq a, Show a, Typeable a) => + LBS.ByteString -> a -> TestTree +decodesAs bs x = testProperty (testName "") (eitherDecode bs === Right x) + where + testName = + showString "eitherDecode @" . + showsPrec 11 (typeRep (Proxy :: Proxy a)) . + showChar ' ' . + showsPrec 11 bs . + showString " == Right " . + showsPrec 11 x -schemaOf :: forall a . ToSchema a => IO () -schemaOf = LBS8.putStrLn (lbsSchemaOf @a) +schemaOf :: + forall a . + (ToSchema a, Eq a, Show a, Typeable a) => + LBS.ByteString -> TestTree +schemaOf bs = testProperty (testName "") (lbsSchemaOf @a === bs) + where + testName = + showString "lbsSchemaOf @" . + showsPrec 11 (typeRep (Proxy :: Proxy a)) . + showString " == " . + showsPrec 5 bs 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,3 +1,4 @@ +#!/usr/bin/env bash set -eu hsTmpDir=$1 shift diff --git a/tests/encode.sh b/tests/encode.sh --- a/tests/encode.sh +++ b/tests/encode.sh @@ -1,3 +1,4 @@ +#!/usr/bin/env bash set -eu hsTmpDir=$1 shift