From 6dbac820591d0299197ae07485fad2fdf55672e9 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Jonne=20Mickelin=20S=C3=A4therblom?= Date: Thu, 13 Feb 2020 13:54:53 +0100 Subject: [PATCH] Add deriving for unions with a single constructor --- README.md | 1 + src/Data/Avro/Decode/Lazy/FromLazyAvro.hs | 8 +++++++ src/Data/Avro/Deriving.hs | 26 ++++++++++++--------- src/Data/Avro/FromAvro.hs | 9 +++++++- src/Data/Avro/HasAvroSchema.hs | 28 +++++++++++++---------- src/Data/Avro/ToAvro.hs | 7 ++++++ test/Avro/JSONSpec.hs | 9 +++++--- test/Avro/THUnionSpec.hs | 17 +++++++++----- test/data/unions-object-a.json | 1 + test/data/unions-object-b.json | 1 + test/data/unions.avsc | 1 + 11 files changed, 75 insertions(+), 33 deletions(-) diff --git a/README.md b/README.md index bb6c73c..2c9dff5 100644 --- a/README.md +++ b/README.md @@ -26,6 +26,7 @@ This library provides the following conversions between Haskell types and Avro t | ByteString | "bytes" | | Maybe a | ["null", "a"] | | Either a b | ["a", "b"] | +| Identity a | ["a"] | | Map Text a | {"type": "map", "value": "a"} | | Map String a | {"type": "map", "value": "a"} | | HashMap Text a | {"type": "map", "value": "a"} | diff --git a/src/Data/Avro/Decode/Lazy/FromLazyAvro.hs b/src/Data/Avro/Decode/Lazy/FromLazyAvro.hs index e5d2a60..2a79866 100644 --- a/src/Data/Avro/Decode/Lazy/FromLazyAvro.hs +++ b/src/Data/Avro/Decode/Lazy/FromLazyAvro.hs @@ -6,6 +6,7 @@ module Data.Avro.Decode.Lazy.FromLazyAvro where +import Control.Monad.Identity (Identity(..)) import Control.Arrow (first) import Data.Avro.Decode.Lazy.LazyValue as T import qualified Data.Avro.Encode as E @@ -44,6 +45,13 @@ class HasAvroSchema a => FromLazyAvro a where Nothing -> fail $ "Requested field not available: " <> show key Just v -> fromLazyAvro v +instance (FromLazyAvro a) => FromLazyAvro (Identity a) where + fromLazyAvro e@(T.Union _ branch x) + | S.matches branch sch = Identity <$> fromLazyAvro x + | otherwise = badValue e "Identity" + where Tagged sch = schema :: Tagged a Schema + fromLazyAvro x = badValue x "Identity" + instance (FromLazyAvro a, FromLazyAvro b) => FromLazyAvro (Either a b) where fromLazyAvro e@(T.Union _ branch x) | S.matches branch schemaA = Left <$> fromLazyAvro x diff --git a/src/Data/Avro/Deriving.hs b/src/Data/Avro/Deriving.hs index d5f5241..d376358 100644 --- a/src/Data/Avro/Deriving.hs +++ b/src/Data/Avro/Deriving.hs @@ -33,15 +33,16 @@ module Data.Avro.Deriving ) where -import Control.Monad (join) -import Data.Aeson (eitherDecode) -import qualified Data.Aeson as J -import Data.Avro hiding (decode, encode) -import Data.Avro.Schema as S -import qualified Data.Avro.Types as AT -import Data.ByteString (ByteString) -import qualified Data.ByteString as B -import Data.Char (isAlphaNum) +import Control.Monad (join) +import Control.Monad.Identity (Identity) +import Data.Aeson (eitherDecode) +import qualified Data.Aeson as J +import Data.Avro hiding (decode, encode) +import Data.Avro.Schema as S +import qualified Data.Avro.Types as AT +import Data.ByteString (ByteString) +import qualified Data.ByteString as B +import Data.Char (isAlphaNum) import Data.Int import Data.List.NonEmpty (NonEmpty ((:|))) import qualified Data.List.NonEmpty as NE @@ -515,14 +516,17 @@ mkFieldTypeName namespaceBehavior = \case t -> error $ "Avro type is not supported: " <> show t where go = mkFieldTypeName namespaceBehavior union = \case + [] -> + error "Empty union types are not supported" + [x] -> [t| Identity $(go x) |] [Null, x] -> [t| Maybe $(go x) |] [x, Null] -> [t| Maybe $(go x) |] [x, y] -> [t| Either $(go x) $(go y) |] [a, b, c] -> [t| Either3 $(go a) $(go b) $(go c) |] [a, b, c, d] -> [t| Either4 $(go a) $(go b) $(go c) $(go d) |] [a, b, c, d, e] -> [t| Either5 $(go a) $(go b) $(go c) $(go d) $(go e) |] - _ -> - error "Unions with more than 5 elements are not yet supported" + ls -> + error $ "Unions with more than 5 elements are not yet supported: Union has " <> (show . length) ls <> " elements" updateFirst :: (Text -> Text) -> Text -> Text updateFirst f t = diff --git a/src/Data/Avro/FromAvro.hs b/src/Data/Avro/FromAvro.hs index a5bc9dd..be8706d 100644 --- a/src/Data/Avro/FromAvro.hs +++ b/src/Data/Avro/FromAvro.hs @@ -8,6 +8,7 @@ module Data.Avro.FromAvro where import Control.Arrow (first) +import Control.Monad.Identity (Identity(..)) import qualified Data.Avro.Encode as E import Data.Avro.HasAvroSchema import Data.Avro.Schema as S @@ -43,6 +44,13 @@ class HasAvroSchema a => FromAvro a where Nothing -> fail $ "Requested field not available: " <> show key Just v -> fromAvro v +instance (FromAvro a) => FromAvro (Identity a) where + fromAvro e@(T.Union _ branch x) + | S.matches branch sch = Identity <$> fromAvro x + | otherwise = badValue e "Identity" + where Tagged sch = schema :: Tagged a Schema + fromAvro x = badValue x "Identity" + instance (FromAvro a, FromAvro b) => FromAvro (Either a b) where fromAvro e@(T.Union _ branch x) | S.matches branch schemaA = Left <$> fromAvro x @@ -146,4 +154,3 @@ instance (FromAvro a) => FromAvro (HashMap.HashMap Text a) where fromAvro (T.Record _ mp) = mapM fromAvro mp fromAvro (T.Map mp) = mapM fromAvro mp fromAvro v = badValue v "HashMap Text a" - diff --git a/src/Data/Avro/HasAvroSchema.hs b/src/Data/Avro/HasAvroSchema.hs index 9e64db9..895eebf 100644 --- a/src/Data/Avro/HasAvroSchema.hs +++ b/src/Data/Avro/HasAvroSchema.hs @@ -3,21 +3,22 @@ {-# LANGUAGE ScopedTypeVariables #-} module Data.Avro.HasAvroSchema where -import qualified Data.Array as Ar -import Data.Avro.Schema as S -import Data.Avro.Types as T +import Control.Monad.Identity (Identity) +import qualified Data.Array as Ar +import Data.Avro.Schema as S +import Data.Avro.Types as T import Data.Avro.Types.Decimal as D -import qualified Data.ByteString as B -import Data.ByteString.Lazy (ByteString) -import qualified Data.ByteString.Lazy as BL -import qualified Data.HashMap.Strict as HashMap +import qualified Data.ByteString as B +import Data.ByteString.Lazy (ByteString) +import qualified Data.ByteString.Lazy as BL +import qualified Data.HashMap.Strict as HashMap import Data.Int -import Data.Ix (Ix) -import Data.List.NonEmpty (NonEmpty (..)) -import qualified Data.Map as Map -import Data.Monoid ((<>)) +import Data.Ix (Ix) +import Data.List.NonEmpty (NonEmpty (..)) +import qualified Data.Map as Map +import Data.Monoid ((<>)) import Data.Proxy -import qualified Data.Set as S +import qualified Data.Set as S import Data.Tagged import Data.Text (Text) import qualified Data.Text as Text @@ -103,6 +104,9 @@ instance HasAvroSchema Time.DiffTime where instance HasAvroSchema Time.UTCTime where schema = Tagged $ S.Long (Just TimestampMicros) +instance (HasAvroSchema a) => HasAvroSchema (Identity a) where + schema = Tagged $ S.Union $ V.fromListN 1 [untag (schema :: Tagged a Schema)] + instance (HasAvroSchema a, HasAvroSchema b) => HasAvroSchema (Either a b) where schema = Tagged $ S.Union $ V.fromListN 2 [untag (schema :: Tagged a Schema), untag (schema :: Tagged b Schema)] diff --git a/src/Data/Avro/ToAvro.hs b/src/Data/Avro/ToAvro.hs index 2a8b1fc..0a488f2 100644 --- a/src/Data/Avro/ToAvro.hs +++ b/src/Data/Avro/ToAvro.hs @@ -5,6 +5,7 @@ module Data.Avro.ToAvro where +import Control.Monad.Identity (Identity(..)) import Control.Arrow (first) import Data.Avro.HasAvroSchema import Data.Avro.Schema as S @@ -81,6 +82,12 @@ instance ToAvro Time.Day where instance ToAvro Time.DiffTime where toAvro = T.Long . fromIntegral . diffTimeToMicros +instance (ToAvro a) => ToAvro (Identity a) where + toAvro e@(Identity a) = + let sch = options (schemaOf e) + in + T.Union sch (schemaOf a) (toAvro a) + instance (ToAvro a, ToAvro b) => ToAvro (Either a b) where toAvro e = let sch = options (schemaOf e) diff --git a/test/Avro/JSONSpec.hs b/test/Avro/JSONSpec.hs index 792bb49..25fdd36 100644 --- a/test/Avro/JSONSpec.hs +++ b/test/Avro/JSONSpec.hs @@ -6,9 +6,10 @@ module Avro.JSONSpec where import Control.Monad (forM_) -import qualified Data.Aeson as Aeson -import qualified Data.ByteString.Lazy as LBS -import qualified Data.Map as Map +import Control.Monad.Identity (Identity (..)) +import qualified Data.Aeson as Aeson +import qualified Data.ByteString.Lazy as LBS +import qualified Data.Map as Map import Data.Avro.Deriving import Data.Avro.EitherN @@ -75,6 +76,7 @@ spec = describe "Avro.JSONSpec: JSON serialization/parsing" $ do , unionsRecords = Left $ Foo { fooStuff = "stuff" } , unionsSameFields = Left $ Foo { fooStuff = "foo stuff" } , unionsArrayAndMap = Left ["foo"] + , unionsOne = Identity 42 , unionsThree = E3_1 37 , unionsFour = E4_2 "foo" , unionsFive = E5_4 $ Foo { fooStuff = "foo stuff" } @@ -87,6 +89,7 @@ spec = describe "Avro.JSONSpec: JSON serialization/parsing" $ do } , unionsSameFields = Right $ NotFoo { notFooStuff = "not foo stuff" } , unionsArrayAndMap = Right $ Map.fromList [("a", 5)] + , unionsOne = Identity 42 , unionsThree = E3_3 37 , unionsFour = E4_4 $ Foo { fooStuff = "foo stuff" } , unionsFive = E5_5 $ NotFoo { notFooStuff = "not foo stuff" } diff --git a/test/Avro/THUnionSpec.hs b/test/Avro/THUnionSpec.hs index 1b88307..abd10b7 100644 --- a/test/Avro/THUnionSpec.hs +++ b/test/Avro/THUnionSpec.hs @@ -7,15 +7,17 @@ where import qualified Data.List.NonEmpty as NE -import qualified Data.Aeson as Aeson + +import Control.Monad.Identity (Identity (..)) +import qualified Data.Aeson as Aeson import Data.Avro import Data.Avro.Deriving import Data.Avro.EitherN -import qualified Data.Avro.Schema as Schema -import qualified Data.Avro.Types as Avro -import qualified Data.ByteString.Lazy as LBS -import qualified Data.Map as Map -import qualified Data.Vector as V +import qualified Data.Avro.Schema as Schema +import qualified Data.Avro.Types as Avro +import qualified Data.ByteString.Lazy as LBS +import qualified Data.Map as Map +import qualified Data.Vector as V import System.Directory (doesFileExist) @@ -33,6 +35,7 @@ spec = describe "Avro.THUnionSpec: Schema with unions." $ do , unionsRecords = Left $ Foo { fooStuff = "stuff" } , unionsSameFields = Left $ Foo { fooStuff = "more stuff" } , unionsArrayAndMap = Left ["foo"] + , unionsOne = Identity 42 , unionsThree = E3_1 37 , unionsFour = E4_2 "foo" , unionsFive = E5_4 $ Foo { fooStuff = "foo stuff" } @@ -45,6 +48,7 @@ spec = describe "Avro.THUnionSpec: Schema with unions." $ do } , unionsSameFields = Right $ NotFoo { notFooStuff = "different from Foo" } , unionsArrayAndMap = Right $ Map.fromList [("a", 5)] + , unionsOne = Identity 42 , unionsThree = E3_3 37 , unionsFour = E4_4 $ Foo { fooStuff = "foo stuff" } , unionsFive = E5_5 $ NotFoo { notFooStuff = "not foo stuff" } @@ -64,6 +68,7 @@ spec = describe "Avro.THUnionSpec: Schema with unions." $ do , field "sameFields" (Schema.mkUnion (NE.fromList [foo, notFooSchema])) Nothing , field "arrayAndMap" (Schema.mkUnion (NE.fromList [array, map])) Nothing + , field "one" (Schema.mkUnion (NE.fromList [Schema.Int'])) Nothing , field "three" (Schema.mkUnion (NE.fromList [Schema.Int', Schema.String', Schema.Long'])) Nothing , field "four" (Schema.mkUnion (NE.fromList [Schema.Int', Schema.String', Schema.Long', foo])) Nothing , field "five" (Schema.mkUnion (NE.fromList [Schema.Int', Schema.String', Schema.Long', foo, notFoo])) Nothing diff --git a/test/data/unions-object-a.json b/test/data/unions-object-a.json index e2c49b6..ef7c220 100644 --- a/test/data/unions-object-a.json +++ b/test/data/unions-object-a.json @@ -16,6 +16,7 @@ "arrayAndMap" : { "array" : ["foo"] }, + "one": { "int": 42 }, "three": { "int": 37 }, "four": { "string": "foo" }, "five": { diff --git a/test/data/unions-object-b.json b/test/data/unions-object-b.json index d384a22..3df7122 100644 --- a/test/data/unions-object-b.json +++ b/test/data/unions-object-b.json @@ -21,6 +21,7 @@ "arrayAndMap" : { "map" : { "a" : 5 } }, + "one": { "int": 42 }, "three": { "long": 37 }, "four": { "haskell.avro.example.Foo": { "stuff" : "foo stuff" } diff --git a/test/data/unions.avsc b/test/data/unions.avsc index 5628a07..512596f 100644 --- a/test/data/unions.avsc +++ b/test/data/unions.avsc @@ -54,6 +54,7 @@ } ] }, + { "name" : "one", "type" : ["int"] }, { "name" : "three", "type" : ["int", "string", "long"] }, { "name" : "four", "type" : ["int", "string", "long", "Foo"] }, { "name" : "five", "type" : ["int", "string", "long", "Foo", "NotFoo"] }