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