diff --git a/avro.cabal b/avro.cabal --- a/avro.cabal +++ b/avro.cabal @@ -2,10 +2,10 @@ -- -- see: https://github.com/sol/hpack -- --- hash: d00924760f916aaff838af8858aa0535e6b78f32409c94cd4ca2258f7b68f921 +-- hash: 759fe76ae3c64abc46a255c2a85695fd7860adbf99c1d5d0190e76189fc0f949 name: avro -version: 0.3.0.2 +version: 0.3.0.3 synopsis: Avro serialization support for Haskell description: Avro serialization and deserialization support for Haskell category: Data @@ -116,6 +116,7 @@ Avro.DefaultsSpec Avro.EncodeRawSpec Avro.JSONSpec + Avro.NormSchemaSpec Avro.THEncodeContainerSpec Avro.THEnumSpec Avro.THReusedSpec 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 @@ -19,7 +19,7 @@ import Data.Avro.Schema as S import qualified Data.Avro.Types as AT import Data.ByteString (ByteString) -import qualified Data.ByteString as B +import qualified Data.ByteString as B import Data.Char (isAlphaNum) import Data.Int import Data.List.NonEmpty (NonEmpty ((:|))) diff --git a/src/Data/Avro/Deriving/NormSchema.hs b/src/Data/Avro/Deriving/NormSchema.hs --- a/src/Data/Avro/Deriving/NormSchema.hs +++ b/src/Data/Avro/Deriving/NormSchema.hs @@ -1,16 +1,18 @@ -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} module Data.Avro.Deriving.NormSchema where -import Data.Avro.Schema -import qualified Data.Set as S -import Data.List.NonEmpty (NonEmpty( (:|) )) import Control.Monad.State.Strict -import Data.Text (Text) -import qualified Data.Text as T -import qualified Data.List as L -import Data.Maybe (catMaybes, fromMaybe) -import Data.Semigroup ((<>)) +import Data.Avro.Schema +import qualified Data.List as L +import Data.List.NonEmpty (NonEmpty ((:|))) +import qualified Data.Map.Strict as M +import Data.Maybe (catMaybes, fromMaybe) +import Data.Semigroup ((<>)) +import qualified Data.Set as S +import Data.Text (Text) +import qualified Data.Text as T -- | Extracts all the records from the schema (flattens the schema) -- Named types get resolved when needed to include at least one "inlined" @@ -19,46 +21,49 @@ -- namespaces (including inlined into full names) will be ignored -- during names resolution. extractDerivables :: Schema -> [Schema] -extractDerivables s = flip evalState S.empty . normSchema rawRecs <$> rawRecs +extractDerivables s = flip evalState state . normSchema . snd <$> rawRecs where rawRecs = getTypes s - getTypes rec = case rec of - r@(Record _ _ _ _ _ fs) -> r : (fs >>= (getTypes . fldType)) - Array t -> getTypes t - Union (t1 :| ts) _ -> getTypes t1 <> concatMap getTypes ts - Map t -> getTypes t - e@Enum{} -> [e] - f@Fixed{} -> [f] - _ -> [] + state = M.fromList rawRecs --- TODO: Currently ensures normalisation: only in one way --- that is needed for "extractRecord". --- it ensures that an "extracted" record is self-contained and +getTypes :: Type -> [(TypeName, Type)] +getTypes rec = case rec of + r@Record{name, fields} -> (name,r) : (fields >>= (getTypes . fldType)) + Array t -> getTypes t + Union (t1 :| ts) _ -> getTypes t1 <> concatMap getTypes ts + Map t -> getTypes t + e@Enum{name} -> [(name, e)] + f@Fixed{name} -> [(name, f)] + _ -> [] + +-- Ensures normalisation: "extracted" record is self-contained and -- all the named types are resolvable within the scope of the schema. --- The other way around (to each record is inlined only once and is referenced --- as a named type after that) is not implemented. -normSchema :: [Schema] -- ^ List of all possible records - -> Schema -- ^ Schema to normalise - -> State (S.Set TypeName) Schema -normSchema rs r = case r of +-- TODO: Improve story with namespaces +normSchema :: Schema -> State (M.Map TypeName Schema) Schema +normSchema r = case r of t@(NamedType tn) -> do let sn = shortName tn resolved <- get - if S.member sn resolved - then pure t - else do - modify' (S.insert sn) - pure $ fromMaybe (error $ "Unable to resolve schema: " <> show (typeName t)) (findSchema tn) - Array s -> Array <$> normSchema rs s - Map s -> Map <$> normSchema rs s - Record{name = tn} -> do + case M.lookup sn resolved of + Just rs -> + -- use the looked up schema (which might be a full record) and replace + -- it in the state with NamedType for future resolves + -- because only one full definition per schema is needed + modify' (M.insert sn t) >> pure rs + + -- NamedType but no corresponding record?! Baaad! + Nothing -> + error $ "Unable to resolve schema: " <> show (typeName t) + + Array s -> Array <$> normSchema s + Map s -> Map <$> normSchema s + r@Record{name = tn} -> do let sn = shortName tn - modify' (S.insert sn) - flds <- mapM (\fld -> setType fld <$> normSchema rs (fldType fld)) (fields r) + modify' (M.insert sn r) + flds <- mapM (\fld -> setType fld <$> normSchema (fldType fld)) (fields r) pure $ r { fields = flds } s -> pure s where shortName tn = TN $ T.takeWhileEnd (/='.') (unTN tn) setType fld t = fld { fldType = t} fullName s = TN $ maybe (typeName s) (\n -> typeName s <> "." <> n) (namespace s) - findSchema tn = L.find (\s -> name s == tn || fullName s == tn) rs diff --git a/test/Avro/NormSchemaSpec.hs b/test/Avro/NormSchemaSpec.hs new file mode 100644 --- /dev/null +++ b/test/Avro/NormSchemaSpec.hs @@ -0,0 +1,21 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +module Avro.NormSchemaSpec +where + +import Data.Avro +import Data.Avro.Deriving +import Data.Avro.Schema (Type (..), fields, fldType) +import qualified Data.Set as S + +import Test.Hspec + +{-# ANN module ("HLint: ignore Redundant do" :: String) #-} + +deriveAvro "test/data/reused.avsc" + +spec :: Spec +spec = describe "Avro.NormSchemaSpec" $ do + it "should have one full inner schema for each type" $ + (fldType <$> fields schema'ContainerChild) `shouldBe` [schema'ReusedChild, NamedType "ReusedChild"]