{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
module Data.Avro.Deriving.NormSchema
where
import Control.Monad.State.Strict
import Data.Avro.Schema.Schema
import qualified Data.Foldable as Foldable
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
import qualified Data.Vector as V
extractDerivables :: Schema -> [Schema]
Schema
s = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall s a. State s a -> s -> a
evalState Map TypeName Schema
state forall b c a. (b -> c) -> (a -> b) -> a -> c
. Schema -> State (Map TypeName Schema) Schema
normSchema forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(TypeName, Schema)]
rawRecs
where
rawRecs :: [(TypeName, Schema)]
rawRecs = Schema -> [(TypeName, Schema)]
getTypes Schema
s
state :: Map TypeName Schema
state = forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [(TypeName, Schema)]
rawRecs
getTypes :: Schema -> [(TypeName, Schema)]
getTypes :: Schema -> [(TypeName, Schema)]
getTypes Schema
rec = case Schema
rec of
r :: Schema
r@Record{TypeName
name :: Schema -> TypeName
name :: TypeName
name, [Field]
fields :: Schema -> [Field]
fields :: [Field]
fields} -> (TypeName
name,Schema
r) forall a. a -> [a] -> [a]
: ([Field]
fields forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Schema -> [(TypeName, Schema)]
getTypes forall b c a. (b -> c) -> (a -> b) -> a -> c
. Field -> Schema
fldType))
Array Schema
t -> Schema -> [(TypeName, Schema)]
getTypes Schema
t
Union Vector Schema
ts -> forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Schema -> [(TypeName, Schema)]
getTypes (forall (t :: * -> *) a. Foldable t => t a -> [a]
Foldable.toList Vector Schema
ts)
Map Schema
t -> Schema -> [(TypeName, Schema)]
getTypes Schema
t
e :: Schema
e@Enum{TypeName
name :: TypeName
name :: Schema -> TypeName
name} -> [(TypeName
name, Schema
e)]
f :: Schema
f@Fixed{TypeName
name :: TypeName
name :: Schema -> TypeName
name} -> [(TypeName
name, Schema
f)]
Schema
_ -> []
normSchema :: Schema -> State (M.Map TypeName Schema) Schema
normSchema :: Schema -> State (Map TypeName Schema) Schema
normSchema Schema
r = case Schema
r of
t :: Schema
t@(NamedType TypeName
tn) -> do
Map TypeName Schema
resolved <- forall s (m :: * -> *). MonadState s m => m s
get
case forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup TypeName
tn Map TypeName Schema
resolved of
Just Schema
rs ->
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify' (forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert TypeName
tn Schema
t) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> case Schema
rs of
NamedType TypeName
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Schema
rs
Schema
_ -> Schema -> State (Map TypeName Schema) Schema
normSchema Schema
rs
Maybe Schema
Nothing ->
forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ [Char]
"Unable to resolve schema: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show (Schema -> Text
typeName Schema
t)
Array Schema
s -> Schema -> Schema
Array forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Schema -> State (Map TypeName Schema) Schema
normSchema Schema
s
Map Schema
s -> Schema -> Schema
Map forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Schema -> State (Map TypeName Schema) Schema
normSchema Schema
s
Union Vector Schema
l -> Vector Schema -> Schema
Union forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Schema -> State (Map TypeName Schema) Schema
normSchema Vector Schema
l
r :: Schema
r@Record{name :: Schema -> TypeName
name = TypeName
tn} -> do
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify' (forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert TypeName
tn (TypeName -> Schema
NamedType TypeName
tn))
[Field]
flds <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\Field
fld -> Field -> Schema -> Field
setType Field
fld forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Schema -> State (Map TypeName Schema) Schema
normSchema (Field -> Schema
fldType Field
fld)) (Schema -> [Field]
fields Schema
r)
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Schema
r { fields :: [Field]
fields = [Field]
flds }
r :: Schema
r@Fixed{name :: Schema -> TypeName
name = TypeName
tn} -> do
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify' (forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert TypeName
tn (TypeName -> Schema
NamedType TypeName
tn))
forall (f :: * -> *) a. Applicative f => a -> f a
pure Schema
r
r :: Schema
r@Enum{name :: Schema -> TypeName
name = TypeName
tn} -> do
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify' (forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert TypeName
tn (TypeName -> Schema
NamedType TypeName
tn))
forall (f :: * -> *) a. Applicative f => a -> f a
pure Schema
r
Schema
s -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Schema
s
where
setType :: Field -> Schema -> Field
setType Field
fld Schema
t = Field
fld { fldType :: Schema
fldType = Schema
t}