{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
module Data.Avro.Deriving
(
DeriveOptions(..)
, FieldStrictness(..)
, FieldUnpackedness(..)
, NamespaceBehavior(..)
, defaultDeriveOptions
, mkPrefixedFieldName
, mkAsIsFieldName
, mkLazyField
, mkStrictPrimitiveField
, makeSchema
, makeSchemaFrom
, makeSchemaFromByteString
, deriveAvroWithOptions
, deriveAvroWithOptions'
, deriveAvroFromByteString
, deriveAvro
, deriveAvro'
, r
)
where
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.Encoding.ToAvro (ToAvro (..))
import Data.Avro.Internal.EncodeRaw (putI)
import Data.Avro.Schema.Schema as S
import Data.ByteString (ByteString)
import qualified Data.ByteString as B
import Data.Char (isAlphaNum)
import qualified Data.Foldable as Foldable
import Data.Int
import Data.List.NonEmpty (NonEmpty ((:|)))
import qualified Data.List.NonEmpty as NE
import Data.Map (Map)
import Data.Maybe (fromMaybe)
import Data.Semigroup ((<>))
import qualified Data.Text as Text
import Data.Time (Day, DiffTime, LocalTime, UTCTime)
import Data.UUID (UUID)
import Text.RawString.QQ (r)
import qualified Data.Avro.Encoding.FromAvro as AV
import GHC.Generics (Generic)
import Language.Haskell.TH as TH hiding (notStrict)
import Language.Haskell.TH.Lib as TH hiding (notStrict)
import Language.Haskell.TH.Syntax
import Data.Avro.Deriving.NormSchema
import Data.Avro.EitherN
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as LBS
import qualified Data.ByteString.Lazy.Char8 as LBSC8
import qualified Data.HashMap.Strict as HM
import qualified Data.Set as S
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Vector as V
import Data.Avro.Deriving.Lift ()
data NamespaceBehavior =
IgnoreNamespaces
| HandleNamespaces
| Custom (T.Text -> [T.Text] -> T.Text)
data FieldStrictness = StrictField | LazyField
deriving forall x. Rep FieldStrictness x -> FieldStrictness
forall x. FieldStrictness -> Rep FieldStrictness x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep FieldStrictness x -> FieldStrictness
$cfrom :: forall x. FieldStrictness -> Rep FieldStrictness x
Generic
data FieldUnpackedness = UnpackedField | NonUnpackedField
deriving forall x. Rep FieldUnpackedness x -> FieldUnpackedness
forall x. FieldUnpackedness -> Rep FieldUnpackedness x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep FieldUnpackedness x -> FieldUnpackedness
$cfrom :: forall x. FieldUnpackedness -> Rep FieldUnpackedness x
Generic
data DeriveOptions = DeriveOptions
{
DeriveOptions -> Text -> Field -> Text
fieldNameBuilder :: Text -> Field -> T.Text
, DeriveOptions
-> TypeName -> Field -> (FieldStrictness, FieldUnpackedness)
fieldRepresentation :: TypeName -> Field -> (FieldStrictness, FieldUnpackedness)
, DeriveOptions -> NamespaceBehavior
namespaceBehavior :: NamespaceBehavior
} deriving forall x. Rep DeriveOptions x -> DeriveOptions
forall x. DeriveOptions -> Rep DeriveOptions x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep DeriveOptions x -> DeriveOptions
$cfrom :: forall x. DeriveOptions -> Rep DeriveOptions x
Generic
defaultDeriveOptions :: DeriveOptions
defaultDeriveOptions = DeriveOptions
{ fieldNameBuilder :: Text -> Field -> Text
fieldNameBuilder = Text -> Field -> Text
mkPrefixedFieldName
, fieldRepresentation :: TypeName -> Field -> (FieldStrictness, FieldUnpackedness)
fieldRepresentation = TypeName -> Field -> (FieldStrictness, FieldUnpackedness)
mkLazyField
, namespaceBehavior :: NamespaceBehavior
namespaceBehavior = NamespaceBehavior
IgnoreNamespaces
}
mkPrefixedFieldName :: Text -> Field -> T.Text
mkPrefixedFieldName :: Text -> Field -> Text
mkPrefixedFieldName Text
prefix Field
fld =
Text -> Text
sanitiseName forall a b. (a -> b) -> a -> b
$ (Text -> Text) -> Text -> Text
updateFirst Text -> Text
T.toLower Text
prefix forall a. Semigroup a => a -> a -> a
<> (Text -> Text) -> Text -> Text
updateFirst Text -> Text
T.toUpper (Field -> Text
fldName Field
fld)
mkLazyField :: TypeName -> Field -> (FieldStrictness, FieldUnpackedness)
mkLazyField :: TypeName -> Field -> (FieldStrictness, FieldUnpackedness)
mkLazyField TypeName
_ Field
_ =
(FieldStrictness
LazyField, FieldUnpackedness
NonUnpackedField)
mkStrictPrimitiveField :: TypeName -> Field -> (FieldStrictness, FieldUnpackedness)
mkStrictPrimitiveField :: TypeName -> Field -> (FieldStrictness, FieldUnpackedness)
mkStrictPrimitiveField TypeName
_ Field
field =
if Bool
shouldStricten
then (FieldStrictness
StrictField, FieldUnpackedness
unpackedness)
else (FieldStrictness
LazyField, FieldUnpackedness
NonUnpackedField)
where
unpackedness :: FieldUnpackedness
unpackedness =
case Field -> Schema
S.fldType Field
field of
Schema
S.Null -> FieldUnpackedness
NonUnpackedField
Schema
S.Boolean -> FieldUnpackedness
NonUnpackedField
Schema
_ -> FieldUnpackedness
UnpackedField
shouldStricten :: Bool
shouldStricten =
case Field -> Schema
S.fldType Field
field of
Schema
S.Null -> Bool
True
Schema
S.Boolean -> Bool
True
S.Int Maybe LogicalTypeInt
_ -> Bool
True
S.Long Maybe LogicalTypeLong
_ -> Bool
True
Schema
S.Float -> Bool
True
Schema
S.Double -> Bool
True
Schema
_ -> Bool
False
mkAsIsFieldName :: Text -> Field -> Text
mkAsIsFieldName :: Text -> Field -> Text
mkAsIsFieldName Text
_ = Text -> Text
sanitiseName forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Text) -> Text -> Text
updateFirst Text -> Text
T.toLower forall b c a. (b -> c) -> (a -> b) -> a -> c
. Field -> Text
fldName
deriveAvroWithOptions :: DeriveOptions -> FilePath -> Q [Dec]
deriveAvroWithOptions :: DeriveOptions -> String -> Q [Dec]
deriveAvroWithOptions DeriveOptions
o String
p = String -> Q Schema
readSchema String
p forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= DeriveOptions -> Schema -> Q [Dec]
deriveAvroWithOptions' DeriveOptions
o
deriveAvroWithOptions' :: DeriveOptions -> Schema -> Q [Dec]
deriveAvroWithOptions' :: DeriveOptions -> Schema -> Q [Dec]
deriveAvroWithOptions' DeriveOptions
o Schema
s = do
let schemas :: [Schema]
schemas = Schema -> [Schema]
extractDerivables Schema
s
[[Dec]]
types <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (DeriveOptions -> Schema -> Q [Dec]
genType DeriveOptions
o) [Schema]
schemas
[[Dec]]
hasSchema <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (NamespaceBehavior -> Schema -> Q [Dec]
genHasAvroSchema forall a b. (a -> b) -> a -> b
$ DeriveOptions -> NamespaceBehavior
namespaceBehavior DeriveOptions
o) [Schema]
schemas
[[Dec]]
fromAvros <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (NamespaceBehavior -> Schema -> Q [Dec]
genFromValue forall a b. (a -> b) -> a -> b
$ DeriveOptions -> NamespaceBehavior
namespaceBehavior DeriveOptions
o) [Schema]
schemas
[[Dec]]
encodeAvros <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (DeriveOptions -> Schema -> Q [Dec]
genToAvro DeriveOptions
o) [Schema]
schemas
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => m (m a) -> m a
join [[Dec]]
types forall a. Semigroup a => a -> a -> a
<> forall (m :: * -> *) a. Monad m => m (m a) -> m a
join [[Dec]]
hasSchema forall a. Semigroup a => a -> a -> a
<> forall (m :: * -> *) a. Monad m => m (m a) -> m a
join [[Dec]]
fromAvros forall a. Semigroup a => a -> a -> a
<> forall (m :: * -> *) a. Monad m => m (m a) -> m a
join [[Dec]]
encodeAvros
deriveAvro :: FilePath -> Q [Dec]
deriveAvro :: String -> Q [Dec]
deriveAvro = DeriveOptions -> String -> Q [Dec]
deriveAvroWithOptions DeriveOptions
defaultDeriveOptions
deriveAvro' :: Schema -> Q [Dec]
deriveAvro' :: Schema -> Q [Dec]
deriveAvro' = DeriveOptions -> Schema -> Q [Dec]
deriveAvroWithOptions' DeriveOptions
defaultDeriveOptions
deriveAvroFromByteString :: LBS.ByteString -> Q [Dec]
deriveAvroFromByteString :: ByteString -> Q [Dec]
deriveAvroFromByteString ByteString
bs = case forall a. FromJSON a => ByteString -> Either String a
eitherDecode ByteString
bs of
Right Schema
schema -> DeriveOptions -> Schema -> Q [Dec]
deriveAvroWithOptions' DeriveOptions
defaultDeriveOptions Schema
schema
Left String
err -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"Unable to generate Avro from bytestring: " forall a. Semigroup a => a -> a -> a
<> String
err
makeSchema :: FilePath -> Q Exp
makeSchema :: String -> Q Exp
makeSchema String
p = String -> Q Schema
readSchema String
p forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall t (m :: * -> *). (Lift t, Quote m) => t -> m Exp
lift
makeSchemaFromByteString :: LBS.ByteString -> Q Exp
makeSchemaFromByteString :: ByteString -> Q Exp
makeSchemaFromByteString ByteString
bs = case forall a. FromJSON a => ByteString -> Either String a
eitherDecode @Schema ByteString
bs of
Right Schema
schema -> forall t (m :: * -> *). (Lift t, Quote m) => t -> m Exp
lift Schema
schema
Left String
err -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"Unable to generate Avro Schema from bytestring: " forall a. Semigroup a => a -> a -> a
<> String
err
makeSchemaFrom :: FilePath -> Text -> Q Exp
makeSchemaFrom :: String -> Text -> Q Exp
makeSchemaFrom String
p Text
name = do
Schema
s <- String -> Q Schema
readSchema String
p
case Schema -> Text -> Maybe Schema
subdefinition Schema
s Text
name of
Maybe Schema
Nothing -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"No such entity '" forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack Text
name forall a. Semigroup a => a -> a -> a
<> String
"' defined in " forall a. Semigroup a => a -> a -> a
<> String
p
Just Schema
ss -> forall t (m :: * -> *). (Lift t, Quote m) => t -> m Exp
lift Schema
ss
readSchema :: FilePath -> Q Schema
readSchema :: String -> Q Schema
readSchema String
p = do
forall (m :: * -> *). Quasi m => String -> m ()
qAddDependentFile String
p
Either String Schema
mbSchema <- forall a. IO a -> Q a
runIO forall a b. (a -> b) -> a -> b
$ String -> IO (Either String Schema)
decodeSchema String
p
case Either String Schema
mbSchema of
Left String
err -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"Unable to generate AVRO for " forall a. Semigroup a => a -> a -> a
<> String
p forall a. Semigroup a => a -> a -> a
<> String
": " forall a. Semigroup a => a -> a -> a
<> String
err
Right Schema
sch -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Schema
sch
badValueNew :: Show v => v -> String -> Either String a
badValueNew :: forall v a. Show v => v -> String -> Either String a
badValueNew v
v String
t = forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ String
"Unexpected value for '" forall a. Semigroup a => a -> a -> a
<> String
t forall a. Semigroup a => a -> a -> a
<> String
"': " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show v
v
genFromValue :: NamespaceBehavior -> Schema -> Q [Dec]
genFromValue :: NamespaceBehavior -> Schema -> Q [Dec]
genFromValue NamespaceBehavior
namespaceBehavior (S.Enum TypeName
n [TypeName]
_ Maybe Text
_ Vector Text
_ ) =
[d| instance AV.FromAvro $(conT $ mkDataTypeName namespaceBehavior n) where
fromAvro (AV.Enum _ i _) = $([| pure . toEnum|]) i
fromAvro value = $( [|\v -> badValueNew v $(mkTextLit $ S.renderFullname n)|] ) value
|]
genFromValue NamespaceBehavior
namespaceBehavior (S.Record TypeName
n [TypeName]
_ Maybe Text
_ [Field]
fs) =
[d| instance AV.FromAvro $(conT $ mkDataTypeName namespaceBehavior n) where
fromAvro (AV.Record _ r) =
$(genFromAvroNewFieldsExp (mkDataTypeName namespaceBehavior n) fs) r
fromAvro value = $( [|\v -> badValueNew v $(mkTextLit $ S.renderFullname n)|] ) value
|]
genFromValue NamespaceBehavior
namespaceBehavior (S.Fixed TypeName
n [TypeName]
_ Int
s Maybe LogicalTypeFixed
_) =
[d| instance AV.FromAvro $(conT $ mkDataTypeName namespaceBehavior n) where
fromAvro (AV.Fixed _ v)
| BS.length v == s = pure $ $(conE (mkDataTypeName namespaceBehavior n)) v
fromAvro value = $( [|\v -> badValueNew v $(mkTextLit $ S.renderFullname n)|] ) value
|]
genFromValue NamespaceBehavior
_ Schema
_ = forall (f :: * -> *) a. Applicative f => a -> f a
pure []
genFromAvroNewFieldsExp :: Name -> [Field] -> Q Exp
genFromAvroNewFieldsExp :: Name -> [Field] -> Q Exp
genFromAvroNewFieldsExp Name
n [Field]
xs =
[| \r ->
$(let ctor = [| pure $(conE n) |]
in foldl (\expr (i, _) -> [| $expr <*> AV.fromAvro (r V.! i) |]) ctor (zip [(0 :: Int)..] xs)
)
|]
genHasAvroSchema :: NamespaceBehavior -> Schema -> Q [Dec]
genHasAvroSchema :: NamespaceBehavior -> Schema -> Q [Dec]
genHasAvroSchema NamespaceBehavior
namespaceBehavior Schema
s = do
let sname :: Name
sname = NamespaceBehavior -> TypeName -> Name
mkSchemaValueName NamespaceBehavior
namespaceBehavior (Schema -> TypeName
name Schema
s)
[Dec]
sdef <- Name -> Schema -> Q [Dec]
schemaDef Name
sname Schema
s
[Dec]
idef <- forall {m :: * -> *}. Quote m => Name -> m [Dec]
hasAvroSchema Name
sname
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Dec]
sdef forall a. Semigroup a => a -> a -> a
<> [Dec]
idef)
where
hasAvroSchema :: Name -> m [Dec]
hasAvroSchema Name
sname =
[d| instance HasAvroSchema $(conT $ mkDataTypeName namespaceBehavior (name s)) where
schema = pure $(varE sname)
|]
newNames :: String
-> Int
-> Q [Name]
newNames :: String -> Int -> Q [Name]
newNames String
base Int
n = forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [forall (m :: * -> *). Quote m => String -> m Name
newName (String
base forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
i) | Int
i <- [Int
1..Int
n]]
genToAvro :: DeriveOptions -> Schema -> Q [Dec]
genToAvro :: DeriveOptions -> Schema -> Q [Dec]
genToAvro DeriveOptions
opts s :: Schema
s@(S.Enum TypeName
n [TypeName]
_ Maybe Text
_ Vector Text
_) =
forall {m :: * -> *} {p}. Quote m => p -> m [Dec]
encodeAvroInstance (NamespaceBehavior -> TypeName -> Name
mkSchemaValueName (DeriveOptions -> NamespaceBehavior
namespaceBehavior DeriveOptions
opts) TypeName
n)
where
encodeAvroInstance :: p -> m [Dec]
encodeAvroInstance p
sname =
[d| instance ToAvro $(conT $ mkDataTypeName (namespaceBehavior opts) n) where
toAvro = $([| \_ x -> putI (fromEnum x) |])
|]
genToAvro DeriveOptions
opts s :: Schema
s@(S.Record TypeName
n [TypeName]
_ Maybe Text
_ [Field]
fs) =
forall {p}. p -> Q [Dec]
encodeAvroInstance (NamespaceBehavior -> TypeName -> Name
mkSchemaValueName (DeriveOptions -> NamespaceBehavior
namespaceBehavior DeriveOptions
opts) TypeName
n)
where
encodeAvroInstance :: p -> Q [Dec]
encodeAvroInstance p
sname =
[d| instance ToAvro $(conT $ mkDataTypeName (namespaceBehavior opts) n) where
toAvro = $(encodeAvroFieldsExp sname)
|]
encodeAvroFieldsExp :: p -> Q Exp
encodeAvroFieldsExp p
sname = do
[Name]
names <- String -> Int -> Q [Name]
newNames String
"p_" (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Field]
fs)
Q Pat
wn <- forall (m :: * -> *). Quote m => Name -> m Pat
varP forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). Quote m => String -> m Name
newName String
"_"
let con :: Q Pat
con = forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP (NamespaceBehavior -> TypeName -> Name
mkDataTypeName (DeriveOptions -> NamespaceBehavior
namespaceBehavior DeriveOptions
opts) TypeName
n) (forall (m :: * -> *). Quote m => Name -> m Pat
varP forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Name]
names)
forall (m :: * -> *). Quote m => [m Pat] -> m Exp -> m Exp
lamE [Q Pat
wn, Q Pat
con]
[| mconcat $( let build (fld, n) = [| toAvro (fldType fld) $(varE n) |]
in listE $ build <$> zip fs names
)
|]
genToAvro DeriveOptions
opts s :: Schema
s@(S.Fixed TypeName
n [TypeName]
_ Int
_ Maybe LogicalTypeFixed
_) =
forall {m :: * -> *}. Quote m => Name -> m [Dec]
encodeAvroInstance (NamespaceBehavior -> TypeName -> Name
mkSchemaValueName (DeriveOptions -> NamespaceBehavior
namespaceBehavior DeriveOptions
opts) TypeName
n)
where
encodeAvroInstance :: Name -> m [Dec]
encodeAvroInstance Name
sname =
[d| instance ToAvro $(conT $ mkDataTypeName (namespaceBehavior opts) n) where
toAvro = $(do
x <- newName "x"
wc <- newName "_"
lamE [varP wc, conP (mkDataTypeName (namespaceBehavior opts) n) [varP x]] [| toAvro $(varE sname) $(varE x) |])
|]
genToAvro DeriveOptions
_ Schema
_ = forall (f :: * -> *) a. Applicative f => a -> f a
pure []
schemaDef :: Name -> Schema -> Q [Dec]
schemaDef :: Name -> Schema -> Q [Dec]
schemaDef Name
sname Schema
sch = Name -> Q [Dec] -> Q [Dec]
setName Name
sname
[d|
x :: Schema
x = sch
|]
setName :: Name -> Q [Dec] -> Q [Dec]
setName :: Name -> Q [Dec] -> Q [Dec]
setName = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Dec -> Dec
sn
where
sn :: Name -> Dec -> Dec
sn Name
n (SigD Name
_ Type
t) = Name -> Type -> Dec
SigD Name
n Type
t
sn Name
n (ValD (VarP Name
_) Body
x [Dec]
y) = Pat -> Body -> [Dec] -> Dec
ValD (Name -> Pat
VarP Name
n) Body
x [Dec]
y
sn Name
_ Dec
d = Dec
d
genType :: DeriveOptions -> Schema -> Q [Dec]
genType :: DeriveOptions -> Schema -> Q [Dec]
genType DeriveOptions
opts (S.Record TypeName
n [TypeName]
_ Maybe Text
_ [Field]
fs) = do
[VarStrictType]
flds <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (DeriveOptions -> TypeName -> Field -> Q VarStrictType
mkField DeriveOptions
opts TypeName
n) [Field]
fs
let dname :: Name
dname = NamespaceBehavior -> TypeName -> Name
mkDataTypeName (DeriveOptions -> NamespaceBehavior
namespaceBehavior DeriveOptions
opts) TypeName
n
forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
sequenceA [Name -> [VarStrictType] -> Q Dec
genDataType Name
dname [VarStrictType]
flds]
genType DeriveOptions
opts (S.Enum TypeName
n [TypeName]
_ Maybe Text
_ Vector Text
vs) = do
let dname :: Name
dname = NamespaceBehavior -> TypeName -> Name
mkDataTypeName (DeriveOptions -> NamespaceBehavior
namespaceBehavior DeriveOptions
opts) TypeName
n
forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
sequenceA [Name -> [Name] -> Q Dec
genEnum Name
dname (NamespaceBehavior -> TypeName -> Text -> Name
mkAdtCtorName (DeriveOptions -> NamespaceBehavior
namespaceBehavior DeriveOptions
opts) TypeName
n forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Vector a -> [a]
V.toList Vector Text
vs)]
genType DeriveOptions
opts (S.Fixed TypeName
n [TypeName]
_ Int
s Maybe LogicalTypeFixed
_) = do
let dname :: Name
dname = NamespaceBehavior -> TypeName -> Name
mkDataTypeName (DeriveOptions -> NamespaceBehavior
namespaceBehavior DeriveOptions
opts) TypeName
n
forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
sequenceA [Name -> Q Dec
genNewtype Name
dname]
genType DeriveOptions
_ Schema
_ = forall (f :: * -> *) a. Applicative f => a -> f a
pure []
mkFieldTypeName :: NamespaceBehavior -> S.Schema -> Q TH.Type
mkFieldTypeName :: NamespaceBehavior -> Schema -> Q Type
mkFieldTypeName NamespaceBehavior
namespaceBehavior = \case
Schema
S.Null -> [t| () |]
Schema
S.Boolean -> [t| Bool |]
S.Long (Just (DecimalL (Decimal Integer
p Integer
s)))
-> [t| Decimal $(litT $ numTyLit p) $(litT $ numTyLit s) |]
S.Long (Just LogicalTypeLong
TimeMicros)
-> [t| DiffTime |]
S.Long (Just LogicalTypeLong
TimestampMicros)
-> [t| UTCTime |]
S.Long (Just LogicalTypeLong
TimestampMillis)
-> [t| UTCTime |]
S.Long (Just LogicalTypeLong
LocalTimestampMillis)
-> [t| LocalTime |]
S.Long (Just LogicalTypeLong
LocalTimestampMicros)
-> [t| LocalTime |]
S.Long Maybe LogicalTypeLong
Nothing -> [t| Int64 |]
S.Int (Just LogicalTypeInt
Date) -> [t| Day |]
S.Int (Just LogicalTypeInt
TimeMillis)
-> [t| DiffTime |]
S.Int Maybe LogicalTypeInt
_ -> [t| Int32 |]
Schema
S.Float -> [t| Float |]
Schema
S.Double -> [t| Double |]
S.Bytes Maybe LogicalTypeBytes
_ -> [t| ByteString |]
S.String Maybe LogicalTypeString
Nothing -> [t| Text |]
S.String (Just LogicalTypeString
UUID) -> [t| UUID |]
S.Union Vector Schema
branches -> [Schema] -> Q Type
union (forall (t :: * -> *) a. Foldable t => t a -> [a]
Foldable.toList Vector Schema
branches)
S.Record TypeName
n [TypeName]
_ Maybe Text
_ [Field]
_ -> [t| $(conT $ mkDataTypeName namespaceBehavior n) |]
S.Map Schema
x -> [t| Map Text $(go x) |]
S.Array Schema
x -> [t| [$(go x)] |]
S.NamedType TypeName
n -> [t| $(conT $ mkDataTypeName namespaceBehavior n)|]
S.Fixed TypeName
n [TypeName]
_ Int
_ Maybe LogicalTypeFixed
_ -> [t| $(conT $ mkDataTypeName namespaceBehavior n)|]
S.Enum TypeName
n [TypeName]
_ Maybe Text
_ Vector Text
_ -> [t| $(conT $ mkDataTypeName namespaceBehavior n)|]
where go :: Schema -> Q Type
go = NamespaceBehavior -> Schema -> Q Type
mkFieldTypeName NamespaceBehavior
namespaceBehavior
union :: [Schema] -> Q Type
union = \case
[] ->
forall a. HasCallStack => String -> a
error String
"Empty union types are not supported"
[Schema
x] -> [t| Identity $(go x) |]
[Schema
Null, Schema
x] -> [t| Maybe $(go x) |]
[Schema
x, Schema
Null] -> [t| Maybe $(go x) |]
[Schema
x, Schema
y] -> [t| Either $(go x) $(go y) |]
[Schema
a, Schema
b, Schema
c] -> [t| Either3 $(go a) $(go b) $(go c) |]
[Schema
a, Schema
b, Schema
c, Schema
d] -> [t| Either4 $(go a) $(go b) $(go c) $(go d) |]
[Schema
a, Schema
b, Schema
c, Schema
d, Schema
e] -> [t| Either5 $(go a) $(go b) $(go c) $(go d) $(go e) |]
[Schema
a, Schema
b, Schema
c, Schema
d, Schema
e, Schema
f] -> [t| Either6 $(go a) $(go b) $(go c) $(go d) $(go e) $(go f) |]
[Schema
a, Schema
b, Schema
c, Schema
d, Schema
e, Schema
f, Schema
g] -> [t| Either7 $(go a) $(go b) $(go c) $(go d) $(go e) $(go f) $(go g)|]
[Schema
a, Schema
b, Schema
c, Schema
d, Schema
e, Schema
f, Schema
g, Schema
h] -> [t| Either8 $(go a) $(go b) $(go c) $(go d) $(go e) $(go f) $(go g) $(go h)|]
[Schema
a, Schema
b, Schema
c, Schema
d, Schema
e, Schema
f, Schema
g, Schema
h, Schema
i] -> [t| Either9 $(go a) $(go b) $(go c) $(go d) $(go e) $(go f) $(go g) $(go h) $(go i)|]
[Schema
a, Schema
b, Schema
c, Schema
d, Schema
e, Schema
f, Schema
g, Schema
h, Schema
i, Schema
j] -> [t| Either10 $(go a) $(go b) $(go c) $(go d) $(go e) $(go f) $(go g) $(go h) $(go i) $(go j)|]
[Schema]
ls ->
forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"Unions with more than 10 elements are not yet supported: Union has " forall a. Semigroup a => a -> a -> a
<> (forall a. Show a => a -> String
show forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> Int
length) [Schema]
ls forall a. Semigroup a => a -> a -> a
<> String
" elements"
updateFirst :: (Text -> Text) -> Text -> Text
updateFirst :: (Text -> Text) -> Text -> Text
updateFirst Text -> Text
f Text
t =
let (Text
l, Text
ls) = Int -> Text -> (Text, Text)
T.splitAt Int
1 Text
t
in Text -> Text
f Text
l forall a. Semigroup a => a -> a -> a
<> Text
ls
decodeSchema :: FilePath -> IO (Either String Schema)
decodeSchema :: String -> IO (Either String Schema)
decodeSchema String
p = forall a. FromJSON a => ByteString -> Either String a
eitherDecode forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO ByteString
LBS.readFile String
p
mkAdtCtorName :: NamespaceBehavior -> TypeName -> Text -> Name
mkAdtCtorName :: NamespaceBehavior -> TypeName -> Text -> Name
mkAdtCtorName NamespaceBehavior
namespaceBehavior TypeName
prefix Text
nm =
Name -> Name -> Name
concatNames (NamespaceBehavior -> TypeName -> Name
mkDataTypeName NamespaceBehavior
namespaceBehavior TypeName
prefix) (Text -> Name
mkDataTypeName' Text
nm)
concatNames :: Name -> Name -> Name
concatNames :: Name -> Name -> Name
concatNames Name
a Name
b = String -> Name
mkName forall a b. (a -> b) -> a -> b
$ Name -> String
nameBase Name
a forall a. Semigroup a => a -> a -> a
<> Name -> String
nameBase Name
b
sanitiseName :: Text -> Text
sanitiseName :: Text -> Text
sanitiseName =
let valid :: Char -> Bool
valid Char
c = Char -> Bool
isAlphaNum Char
c Bool -> Bool -> Bool
|| Char
c forall a. Eq a => a -> a -> Bool
== Char
'\'' Bool -> Bool -> Bool
|| Char
c forall a. Eq a => a -> a -> Bool
== Char
'_'
in [Text] -> Text
T.concat forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> Text -> [Text]
T.split (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Bool
valid)
renderName :: NamespaceBehavior
-> TypeName
-> Text
renderName :: NamespaceBehavior -> TypeName -> Text
renderName NamespaceBehavior
namespaceBehavior (TN Text
name [Text]
namespace) = case NamespaceBehavior
namespaceBehavior of
NamespaceBehavior
HandleNamespaces -> Text -> [Text] -> Text
Text.intercalate Text
"'" forall a b. (a -> b) -> a -> b
$ [Text]
namespace forall a. Semigroup a => a -> a -> a
<> [Text
name]
NamespaceBehavior
IgnoreNamespaces -> Text
name
Custom Text -> [Text] -> Text
f -> Text -> [Text] -> Text
f Text
name [Text]
namespace
mkSchemaValueName :: NamespaceBehavior -> TypeName -> Name
mkSchemaValueName :: NamespaceBehavior -> TypeName -> Name
mkSchemaValueName NamespaceBehavior
namespaceBehavior TypeName
typeName =
Text -> Name
mkTextName forall a b. (a -> b) -> a -> b
$ Text
"schema'" forall a. Semigroup a => a -> a -> a
<> NamespaceBehavior -> TypeName -> Text
renderName NamespaceBehavior
namespaceBehavior TypeName
typeName
mkDataTypeName :: NamespaceBehavior -> TypeName -> Name
mkDataTypeName :: NamespaceBehavior -> TypeName -> Name
mkDataTypeName NamespaceBehavior
namespaceBehavior = Text -> Name
mkDataTypeName' forall b c a. (b -> c) -> (a -> b) -> a -> c
. NamespaceBehavior -> TypeName -> Text
renderName NamespaceBehavior
namespaceBehavior
mkDataTypeName' :: Text -> Name
mkDataTypeName' :: Text -> Name
mkDataTypeName' =
Text -> Name
mkTextName forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
sanitiseName forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Text) -> Text -> Text
updateFirst Text -> Text
T.toUpper forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> Text -> Text
T.takeWhileEnd (forall a. Eq a => a -> a -> Bool
/=Char
'.')
mkField :: DeriveOptions -> TypeName -> Field -> Q VarStrictType
mkField :: DeriveOptions -> TypeName -> Field -> Q VarStrictType
mkField DeriveOptions
opts TypeName
typeName Field
field = do
Type
ftype <- NamespaceBehavior -> Schema -> Q Type
mkFieldTypeName (DeriveOptions -> NamespaceBehavior
namespaceBehavior DeriveOptions
opts) (Field -> Schema
fldType Field
field)
let prefix :: Text
prefix = NamespaceBehavior -> TypeName -> Text
renderName (DeriveOptions -> NamespaceBehavior
namespaceBehavior DeriveOptions
opts) TypeName
typeName
fName :: Name
fName = Text -> Name
mkTextName forall a b. (a -> b) -> a -> b
$ DeriveOptions -> Text -> Field -> Text
fieldNameBuilder DeriveOptions
opts Text
prefix Field
field
(FieldStrictness
fieldStrictness, FieldUnpackedness
fieldUnpackedness) =
DeriveOptions
-> TypeName -> Field -> (FieldStrictness, FieldUnpackedness)
fieldRepresentation DeriveOptions
opts TypeName
typeName Field
field
strictness :: Strict
strictness =
case FieldStrictness
fieldStrictness of
FieldStrictness
StrictField -> FieldUnpackedness -> Strict
strict FieldUnpackedness
fieldUnpackedness
FieldStrictness
LazyField -> Strict
notStrict
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Name
fName, Strict
strictness, Type
ftype)
genNewtype :: Name -> Q Dec
#if MIN_VERSION_template_haskell(2,12,0)
genNewtype :: Name -> Q Dec
genNewtype Name
dn = do
[Type]
ders <- forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
sequenceA [[t|Eq|], [t|Show|], [t|Generic|]]
Type
fldType <- [t|ByteString|]
let ctor :: Con
ctor = Name -> [VarStrictType] -> Con
RecC Name
dn [(String -> Name
mkName (String
"un" forall a. [a] -> [a] -> [a]
++ Name -> String
nameBase Name
dn), Strict
notStrict, Type
fldType)]
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ [Type]
-> Name
-> [TyVarBndr ()]
-> Maybe Type
-> Con
-> [DerivClause]
-> Dec
NewtypeD [] Name
dn [] forall a. Maybe a
Nothing Con
ctor [Maybe DerivStrategy -> [Type] -> DerivClause
DerivClause forall a. Maybe a
Nothing [Type]
ders]
#elif MIN_VERSION_template_haskell(2,11,0)
genNewtype dn = do
ders <- sequenceA [[t|Eq|], [t|Show|], [t|Generic|]]
fldType <- [t|ByteString|]
let ctor = RecC dn [(mkName ("un" ++ nameBase dn), notStrict, fldType)]
pure $ NewtypeD [] dn [] Nothing ctor ders
#else
genNewtype dn = do
[ConT eq, ConT sh, ConT gen] <- sequenceA [[t|Eq|], [t|Show|], [t|Generic|]]
fldType <- [t|ByteString|]
let ctor = RecC dn [(mkName ("un" ++ nameBase dn), notStrict, fldType)]
pure $ NewtypeD [] dn [] ctor [eq, sh, gen]
#endif
genEnum :: Name -> [Name] -> Q Dec
#if MIN_VERSION_template_haskell(2,12,0)
genEnum :: Name -> [Name] -> Q Dec
genEnum Name
dn [Name]
vs = do
[Type]
ders <- forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
sequenceA [[t|Eq|], [t|Show|], [t|Ord|], [t|Enum|], [t|Bounded|], [t|Generic|]]
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ [Type]
-> Name
-> [TyVarBndr ()]
-> Maybe Type
-> [Con]
-> [DerivClause]
-> Dec
DataD [] Name
dn [] forall a. Maybe a
Nothing ((\Name
n -> Name -> [BangType] -> Con
NormalC Name
n []) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Name]
vs) [Maybe DerivStrategy -> [Type] -> DerivClause
DerivClause forall a. Maybe a
Nothing [Type]
ders]
#elif MIN_VERSION_template_haskell(2,11,0)
genEnum dn vs = do
ders <- sequenceA [[t|Eq|], [t|Show|], [t|Ord|], [t|Enum|], [t|Bounded|], [t|Generic|]]
pure $ DataD [] dn [] Nothing ((\n -> NormalC n []) <$> vs) ders
#else
genEnum dn vs = do
[ConT eq, ConT sh, ConT or, ConT en, ConT gen] <- sequenceA [[t|Eq|], [t|Show|], [t|Ord|], [t|Enum|], [t|Bounded|], [t|Generic|]]
pure $ DataD [] dn [] ((\n -> NormalC n []) <$> vs) [eq, sh, or, en, gen]
#endif
genDataType :: Name -> [VarStrictType] -> Q Dec
#if MIN_VERSION_template_haskell(2,12,0)
genDataType :: Name -> [VarStrictType] -> Q Dec
genDataType Name
dn [VarStrictType]
flds = do
[Type]
ders <- forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
sequenceA [[t|Eq|], [t|Show|], [t|Generic|]]
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ [Type]
-> Name
-> [TyVarBndr ()]
-> Maybe Type
-> [Con]
-> [DerivClause]
-> Dec
DataD [] Name
dn [] forall a. Maybe a
Nothing [Name -> [VarStrictType] -> Con
RecC Name
dn [VarStrictType]
flds] [Maybe DerivStrategy -> [Type] -> DerivClause
DerivClause forall a. Maybe a
Nothing [Type]
ders]
#elif MIN_VERSION_template_haskell(2,11,0)
genDataType dn flds = do
ders <- sequenceA [[t|Eq|], [t|Show|], [t|Generic|]]
pure $ DataD [] dn [] Nothing [RecC dn flds] ders
#else
genDataType dn flds = do
[ConT eq, ConT sh, ConT gen] <- sequenceA [[t|Eq|], [t|Show|], [t|Generic|]]
pure $ DataD [] dn [] [RecC dn flds] [eq, sh, gen]
#endif
notStrict :: Strict
#if MIN_VERSION_template_haskell(2,11,0)
notStrict :: Strict
notStrict = SourceUnpackedness -> SourceStrictness -> Strict
Bang SourceUnpackedness
SourceNoUnpack SourceStrictness
NoSourceStrictness
#else
notStrict = NotStrict
#endif
strict :: FieldUnpackedness -> Strict
#if MIN_VERSION_template_haskell(2,11,0)
strict :: FieldUnpackedness -> Strict
strict FieldUnpackedness
UnpackedField = SourceUnpackedness -> SourceStrictness -> Strict
Bang SourceUnpackedness
SourceUnpack SourceStrictness
SourceStrict
strict FieldUnpackedness
NonUnpackedField = SourceUnpackedness -> SourceStrictness -> Strict
Bang SourceUnpackedness
SourceNoUnpack SourceStrictness
SourceStrict
#else
strict UnpackedField = Unpacked
strict NonUnpackedField = IsStrict
#endif
mkTextName :: Text -> Name
mkTextName :: Text -> Name
mkTextName = String -> Name
mkName forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack
mkLit :: String -> ExpQ
mkLit :: String -> Q Exp
mkLit = forall (m :: * -> *). Quote m => Lit -> m Exp
litE forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Lit
StringL
mkTextLit :: Text -> ExpQ
mkTextLit :: Text -> Q Exp
mkTextLit = forall (m :: * -> *). Quote m => Lit -> m Exp
litE forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Lit
StringL forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack