diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -106,7 +106,7 @@ schema'Person :: Schema schema'Person = - Record "Person" [] Nothing Nothing + Record "Person" [] Nothing [ fld "fullName" (String Nothing) Nothing , fld "age" (Int Nothing) Nothing , fld "ssn" (mkUnion $ Null :| [(String Nothing)]) Nothing diff --git a/avro.cabal b/avro.cabal --- a/avro.cabal +++ b/avro.cabal @@ -1,7 +1,7 @@ cabal-version: 2.4 name: avro -version: 0.5.0.0 +version: 0.5.1.0 synopsis: Avro serialization support for Haskell description: Avro serialization and deserialization support for Haskell category: Data @@ -196,13 +196,14 @@ Avro.Codec.ZigZagSpec Avro.Data.Deconflict.Read Avro.Data.Deconflict.Write + Avro.Data.Endpoint Avro.Data.Enums Avro.Data.FixedTypes Avro.Data.Karma Avro.Data.Logical Avro.Data.Maybe + Avro.Data.Recursive Avro.Data.Reused - Avro.Data.Endpoint Avro.Data.Unions Avro.Decode.ContainerSpec Avro.Decode.RawBlocksSpec @@ -227,6 +228,7 @@ Avro.ManualSpec Avro.NamespaceSpec Avro.NormSchemaSpec + Avro.RecursiveSpec Avro.ReuseFixedSpec Avro.SchemaSpec Avro.TestUtils diff --git a/src/Data/Avro/Deriving.hs b/src/Data/Avro/Deriving.hs --- a/src/Data/Avro/Deriving.hs +++ b/src/Data/Avro/Deriving.hs @@ -319,7 +319,7 @@ fromAvro (AV.Enum _ i _) = $([| pure . toEnum|]) i fromAvro value = $( [|\v -> badValueNew v $(mkTextLit $ S.renderFullname n)|] ) value |] -genFromValue namespaceBehavior (S.Record n _ _ _ fs) = +genFromValue namespaceBehavior (S.Record n _ _ fs) = [d| instance AV.FromAvro $(conT $ mkDataTypeName namespaceBehavior n) where fromAvro (AV.Record _ r) = $(genFromAvroNewFieldsExp (mkDataTypeName namespaceBehavior n) fs) r @@ -373,7 +373,7 @@ toAvro = $([| \_ x -> putI (fromEnum x) |]) |] -genToAvro opts s@(S.Record n _ _ _ fs) = +genToAvro opts s@(S.Record n _ _ fs) = encodeAvroInstance (mkSchemaValueName (namespaceBehavior opts) n) where encodeAvroInstance sname = @@ -420,7 +420,7 @@ sn _ d = d genType :: DeriveOptions -> Schema -> Q [Dec] -genType opts (S.Record n _ _ _ fs) = do +genType opts (S.Record n _ _ fs) = do flds <- traverse (mkField opts n) fs let dname = mkDataTypeName (namespaceBehavior opts) n sequenceA [genDataType dname flds] @@ -454,7 +454,7 @@ S.String Nothing -> [t| Text |] S.String (Just UUID) -> [t| UUID |] S.Union branches -> union (Foldable.toList branches) - S.Record n _ _ _ _ -> [t| $(conT $ mkDataTypeName namespaceBehavior n) |] + S.Record n _ _ _ -> [t| $(conT $ mkDataTypeName namespaceBehavior n) |] S.Map x -> [t| Map Text $(go x) |] S.Array x -> [t| [$(go x)] |] S.NamedType n -> [t| $(conT $ mkDataTypeName namespaceBehavior n)|] @@ -522,7 +522,7 @@ renderName namespaceBehavior (TN name namespace) = case namespaceBehavior of HandleNamespaces -> Text.intercalate "'" $ namespace <> [name] IgnoreNamespaces -> name - Custom f -> f name namespace + Custom f -> f name namespace mkSchemaValueName :: NamespaceBehavior -> TypeName -> Name mkSchemaValueName namespaceBehavior typeName = diff --git a/src/Data/Avro/Encoding/FromAvro.hs b/src/Data/Avro/Encoding/FromAvro.hs --- a/src/Data/Avro/Encoding/FromAvro.hs +++ b/src/Data/Avro/Encoding/FromAvro.hs @@ -258,7 +258,7 @@ ReadSchema.Double ReadSchema.DoubleFromLong -> fmap (Double sch . fromIntegral) Get.getLong ReadSchema.String _ -> fmap (String sch) Get.getString - ReadSchema.Record _ _ _ _ fields -> fmap (Record sch) (getRecord env fields) + ReadSchema.Record _ _ _ fields -> fmap (Record sch) (getRecord env fields) ReadSchema.Bytes _ -> fmap (Bytes sch) Get.getBytes ReadSchema.NamedType tn -> diff --git a/src/Data/Avro/Encoding/ToAvro.hs b/src/Data/Avro/Encoding/ToAvro.hs --- a/src/Data/Avro/Encoding/ToAvro.hs +++ b/src/Data/Avro/Encoding/ToAvro.hs @@ -46,7 +46,7 @@ (.=) fieldName fieldValue = (fieldName, Encoder (flip toAvro fieldValue)) record :: Schema -> [(Text, Encoder)] -> Builder -record (S.Record _ _ _ _ fs) vs = +record (S.Record _ _ _ fs) vs = foldMap (mapField provided) fs where provided :: HashMap Text Encoder diff --git a/src/Data/Avro/Schema/Deconflict.hs b/src/Data/Avro/Schema/Deconflict.hs --- a/src/Data/Avro/Schema/Deconflict.hs +++ b/src/Data/Avro/Schema/Deconflict.hs @@ -24,6 +24,8 @@ import Data.Avro.Schema.ReadSchema (FieldStatus (..), ReadField, ReadSchema) import qualified Data.Avro.Schema.ReadSchema as Read +import Debug.Trace + -- | @deconflict writer reader@ will produce a schema that can decode -- with the writer's schema into the form specified by the reader's schema. -- @@ -74,13 +76,12 @@ } deconflict w@S.Record {} r@S.Record {} - | name w == name r && order r `moreSpecified` order w = do + | name w == name r = do fields' <- deconflictFields (fields w) (fields r) pure Read.Record { Read.name = name r , Read.aliases = aliases w <> aliases r , Read.doc = doc r - , Read.order = order r , Read.fields = fields' } @@ -94,14 +95,6 @@ Read.FreeUnion ix <$> deconflict nonUnion y deconflict a b = Left $ "Can not resolve differing writer and reader schemas: " ++ show (a, b) - - -moreSpecified :: Maybe Order -> Maybe Order -> Bool -moreSpecified _ Nothing = True -moreSpecified _ (Just Ignore) = True -moreSpecified (Just Ascending) (Just Ascending) = True -moreSpecified (Just Descending) (Just Descending) = True -moreSpecified _ _ = False contains :: V.Vector Text -> V.Vector Text -> Bool contains container elts = diff --git a/src/Data/Avro/Schema/ReadSchema.hs b/src/Data/Avro/Schema/ReadSchema.hs --- a/src/Data/Avro/Schema/ReadSchema.hs +++ b/src/Data/Avro/Schema/ReadSchema.hs @@ -86,7 +86,6 @@ | Record { name :: TypeName , aliases :: [TypeName] , doc :: Maybe Text - , order :: Maybe Order , fields :: [ReadField] } | Enum { name :: TypeName @@ -158,7 +157,6 @@ { name = S.name v , aliases = S.aliases v , doc = S.doc v - , order = S.order v , fields = (\(i, x) -> fromField (AsIs i) x) <$> zip [0..] (S.fields v) } v@S.Enum{} -> Enum diff --git a/src/Data/Avro/Schema/Schema.hs b/src/Data/Avro/Schema/Schema.hs --- a/src/Data/Avro/Schema/Schema.hs +++ b/src/Data/Avro/Schema/Schema.hs @@ -130,7 +130,6 @@ | Record { name :: TypeName , aliases :: [TypeName] , doc :: Maybe Text - , order :: Maybe Order , fields :: [Field] } | Enum { name :: TypeName @@ -202,7 +201,7 @@ Map ty == Map ty2 = ty == ty2 NamedType t == NamedType t2 = t == t2 - Record name1 _ _ _ fs1 == Record name2 _ _ _ fs2 = + Record name1 _ _ fs1 == Record name2 _ _ fs2 = (name1 == name2) && (fs1 == fs2) Enum name1 _ _ s == Enum name2 _ _ s2 = (name1 == name2) && (s == s2) @@ -461,9 +460,8 @@ mkAlias name = mkTypeName (Just typeName) name Nothing aliases <- mkAliases typeName <$> (o .:? "aliases" .!= []) doc <- o .:? "doc" - order <- o .:? "order" .!= Just Ascending fields <- mapM (parseField typeName) =<< (o .: "fields") - pure $ Record typeName aliases doc order fields + pure $ Record typeName aliases doc fields "enum" -> do name <- o .: "name" namespace <- o .:? "namespace" @@ -583,8 +581,7 @@ NamedType name -> toJSON $ render context name Record {..} -> let opts = catMaybes - [ ("order" .=) <$> order - , ("doc" .=) <$> doc + [ ("doc" .=) <$> doc ] in object $ opts ++ [ "type" .= ("record" :: Text) diff --git a/test/Avro/Data/Deconflict/Read.hs b/test/Avro/Data/Deconflict/Read.hs --- a/test/Avro/Data/Deconflict/Read.hs +++ b/test/Avro/Data/Deconflict/Read.hs @@ -17,7 +17,7 @@ "name": "Bar", "type": "record", "fields": [ - { "name": "barInt", "type": "int" }, + { "name": "barInt", "type": "int", "order": "descending" }, { "name": "barTime", "type": { "logicalType": "timestamp-millis", "type": "long" } }, { "name": "barLong", "type": { "logicalType": "timestamp-micros", "type": "long" } }, { "name": "barString", "type": "string" }, diff --git a/test/Avro/Data/Deconflict/Write.hs b/test/Avro/Data/Deconflict/Write.hs --- a/test/Avro/Data/Deconflict/Write.hs +++ b/test/Avro/Data/Deconflict/Write.hs @@ -33,7 +33,7 @@ "name": "Bar", "type": "record", "fields": [ - { "name": "barInt", "type": "int" }, + { "name": "barInt", "type": "int", "order": "ascending" }, { "name": "barTime", "type": "int" }, { "name": "barLong", "type": "long" }, { "name": "barString", "type": "string" }, diff --git a/test/Avro/Data/Recursive.hs b/test/Avro/Data/Recursive.hs new file mode 100644 --- /dev/null +++ b/test/Avro/Data/Recursive.hs @@ -0,0 +1,78 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE NumDecimals #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE StrictData #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} +module Avro.Data.Recursive +where + +import Data.Avro.Internal.Time (microsToDiffTime, microsToUTCTime, millisToDiffTime, millisToUTCTime) + +import Data.Avro.Deriving (deriveAvroFromByteString, r) + +import Hedgehog +import Hedgehog.Gen as Gen +import Hedgehog.Range as Range + +deriveAvroFromByteString [r| +{ + "type": "record", + "name": "Recursive", + "fields": [ + { "name": "index", "type": "int" }, + { "name": "tag", "type": ["null", "Recursive"] } + ] +} +|] + +deriveAvroFromByteString [r| +{ + "type": "record", + "name": "RecursiveA", + "fields": [ + { "name": "index", "type": "int" }, + { "name": "recursiveB", + "type": { + "type": "record", + "name": "RecursiveB", + "fields": [ + { "name": "index", "type": "int"}, + { "name": "recursiveA", "type": ["null", "RecursiveA"] } + ] + } + } + ] +} +|] + + +recursiveGen :: MonadGen m => m Recursive +recursiveGen = Recursive + <$> Gen.int32 Range.linearBounded + <*> Gen.maybe recursiveGen + +recursiveAGen :: MonadGen m => m RecursiveA +recursiveAGen = RecursiveA + <$> Gen.int32 Range.linearBounded + <*> recursiveBGen + +recursiveBGen :: MonadGen m => m RecursiveB +recursiveBGen = RecursiveB + <$> Gen.int32 Range.linearBounded + <*> Gen.maybe recursiveAGen + +-- maybeTestGen :: MonadGen m => m MaybeTest +-- maybeTestGen = MaybeTest +-- <$> Gen.maybe (Gen.text (Range.linear 0 50) Gen.alphaNum) +-- <*> (FixedTag <$> Gen.bytes (Range.singleton 3)) +-- <*> Gen.bytes (Range.linear 0 30) diff --git a/test/Avro/Encoding/DeconflictSpec.hs b/test/Avro/Encoding/DeconflictSpec.hs --- a/test/Avro/Encoding/DeconflictSpec.hs +++ b/test/Avro/Encoding/DeconflictSpec.hs @@ -28,6 +28,8 @@ x <- forAll Write.genFoo schema <- evalEither $ deconflict Write.schema'Foo Read.schema'Foo + footnoteShow schema + let bs = encodeValueWithSchema Write.schema'Foo x x' <- evalEither $ decodeValueWithSchema @Read.Foo schema bs diff --git a/test/Avro/ManualSpec.hs b/test/Avro/ManualSpec.hs --- a/test/Avro/ManualSpec.hs +++ b/test/Avro/ManualSpec.hs @@ -34,7 +34,7 @@ schema'Person :: Schema schema'Person = - Record "Person" [] Nothing Nothing + Record "Person" [] Nothing [ fld "fullName" (String Nothing) Nothing , fld "age" (Int Nothing) Nothing , fld "ssn" (mkUnion $ Null :| [(String Nothing)]) Nothing diff --git a/test/Avro/NamespaceSpec.hs b/test/Avro/NamespaceSpec.hs --- a/test/Avro/NamespaceSpec.hs +++ b/test/Avro/NamespaceSpec.hs @@ -40,7 +40,6 @@ { name = "com.example.Foo" , aliases = ["com.example.FooBar", "com.example.not.Bar"] , doc = Just "An example schema to test namespace handling." - , order = Just Ascending , fields = [field "bar" bar, field "baz" $ NamedType "com.example.baz.Baz"] } where field name schema = Field name [] Nothing (Just Ascending) schema Nothing @@ -49,7 +48,6 @@ { name = "com.example.Bar" , aliases = ["com.example.Bar2", "com.example.not.Foo"] , doc = Nothing - , order = Just Ascending , fields = [ field "baz" baz , field "bazzy" $ NamedType "com.example.Bazzy" ] @@ -59,7 +57,6 @@ { name = "com.example.baz.Baz" , aliases = ["com.example.Bazzy"] , doc = Nothing - , order = Just Ascending , fields = [ field "baz" $ NamedType "com.example.baz.Baz" , field "bazzy" $ NamedType "com.example.Bazzy" ] @@ -71,7 +68,6 @@ { name = "Foo" , aliases = [] , doc = Just "An example schema to test null namespace handling." - , order = Just Ascending , fields = [field "bar" $ NamedType "Bar", field "baz" $ NamedType "com.example.Baz"] } where field name schema = Field name [] Nothing (Just Ascending) schema Nothing diff --git a/test/Avro/RecursiveSpec.hs b/test/Avro/RecursiveSpec.hs new file mode 100644 --- /dev/null +++ b/test/Avro/RecursiveSpec.hs @@ -0,0 +1,22 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +module Avro.RecursiveSpec +where + +import Avro.Data.Recursive +import Data.Avro.Deriving + +import Avro.TestUtils (roundtripGen) +import HaskellWorks.Hspec.Hedgehog +import Hedgehog +import Test.Hspec + +{-# ANN module ("HLint: ignore Redundant do" :: String) #-} + +spec :: Spec +spec = describe "Avro.RecursiveSpec" $ do + it "should roundtrip recursive type" $ require $ property $ + roundtripGen schema'Recursive recursiveGen + + it "should roundrip mutually recursive type" $ require $ property $ + roundtripGen schema'RecursiveA recursiveAGen diff --git a/test/data/namespace-inference.json b/test/data/namespace-inference.json --- a/test/data/namespace-inference.json +++ b/test/data/namespace-inference.json @@ -4,7 +4,6 @@ "name" : "com.example.Foo", "aliases" : ["FooBar", "com.example.not.Bar"], "doc" : "An example schema to test namespace handling.", - "order" : "ascending", "fields" : [ { "name" : "bar", @@ -13,7 +12,6 @@ "type" : { "type" : "record", "name" : "Bar", - "order" : "ascending", "aliases" : ["Bar2", "com.example.not.Foo"], "fields" : [ { @@ -22,7 +20,6 @@ "order" : "ascending", "type" : { "type" : "record", - "order" : "ascending", "name" : "com.example.baz.Baz", "aliases" : ["com.example.Bazzy"], "fields" : [