{-# LANGUAGE CPP                #-}
{-# LANGUAGE DeriveGeneric      #-}
{-# LANGUAGE LambdaCase         #-}
{-# LANGUAGE OverloadedStrings  #-}
{-# LANGUAGE RecordWildCards    #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell    #-}
{-# LANGUAGE TypeApplications   #-}

-- | This module lets us derive Haskell types from an Avro schema that
-- can be serialized/deserialized to Avro.
module Data.Avro.Deriving
  ( -- * Deriving options
    DeriveOptions(..)
  , FieldStrictness(..)
  , FieldUnpackedness(..)
  , NamespaceBehavior(..)
  , defaultDeriveOptions
  , mkPrefixedFieldName
  , mkAsIsFieldName
  , mkLazyField
  , mkStrictPrimitiveField

  -- * Deriving Haskell types from Avro schema
  , makeSchema
  , makeSchemaFrom
  , makeSchemaFromByteString
  , deriveAvroWithOptions
  , deriveAvroWithOptions'
  , deriveAvroFromByteString
  , deriveAvro
  , deriveAvro'

  -- * Re-exporting a quasiquoter for raw string literals
  , 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


-- | How to treat Avro namespaces in the generated Haskell types.
data NamespaceBehavior =
    IgnoreNamespaces
    -- ^ Namespaces are ignored completely. Haskell identifiers are
    -- generated from types' base names. This produces nicer types but
    -- fails on valid Avro schemas where the same base name occurs in
    -- different namespaces.
    --
    -- The Avro type @com.example.Foo@ would generate the Haskell type
    -- @Foo@. If @Foo@ had a field called @bar@, the generated Haskell
    -- record would have a field called @fooBar@.
  | HandleNamespaces
    -- ^ Haskell types and field names are generated with
    -- namespaces. See 'deriveAvroWithNamespaces' for an example of
    -- how this works.
    --
    -- The Avro type @com.example.Foo@ would generate the Haskell type
    -- @Com'example'Foo@. If @Foo@ had a field called @bar@, the
    -- generated Haskell record would have the field
    -- @com'example'FooBar@.
  | Custom (Text -> [Text] -> Text)
    -- ^ Provide a custom mapping from the name of the Avro type and
    -- its namespace that will be used to generate Haskell types and
    -- fields.


-- | Describes the strictness of a field for a derived
-- data type. The field will be derived as if it were
-- written with a @!@.
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

-- | Describes the representation of a field for a derived
-- data type. The field will be derived as if it were written
-- with an @{-# UNPACK #-}@ pragma.
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

-- | Derives Avro from a given schema file.
-- Generates data types, FromAvro and ToAvro instances.
data DeriveOptions = DeriveOptions
  { -- | How to build field names for generated data types. The first
    -- argument is the type name to use as a prefix, rendered
    -- according to the 'namespaceBehavior' setting.
    DeriveOptions -> Text -> Field -> Text
fieldNameBuilder    :: Text -> Field -> Text

    -- | Determines field representation of generated data types
  , DeriveOptions
-> TypeName -> Field -> (FieldStrictness, FieldUnpackedness)
fieldRepresentation :: TypeName -> Field -> (FieldStrictness, FieldUnpackedness)

    -- | Controls how we handle namespaces when defining Haskell type
    -- and field names.
  , 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

-- | Default deriving options
--
-- @
-- defaultDeriveOptions = 'DeriveOptions'
--   { fieldNameBuilder  = 'mkPrefixedFieldName'
--   , fieldStrictness   = 'mkLazyField'
--   , namespaceBehavior = 'IgnoreNamespaces'
--   }
-- @
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
  }

-- | Generates a field name that is prefixed with the type name.
--
-- For example, if the schema defines type 'Person' that has a field 'firstName',
-- then the generated Haskell type will be like
--
-- @
-- Person { personFirstName :: Text }
-- @
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)

-- | Marks any field as non-strict in the generated data types.
mkLazyField :: TypeName -> Field -> (FieldStrictness, FieldUnpackedness)
mkLazyField :: TypeName -> Field -> (FieldStrictness, FieldUnpackedness)
mkLazyField TypeName
_ Field
_ =
  (FieldStrictness
LazyField, FieldUnpackedness
NonUnpackedField)


-- | Make a field strict and unpacked if it has a primitive representation.
-- Primitive types are types which GHC has either a static or an unlifted
-- representation: `()`, `Boolean`, `Int32`, `Int64`, `Float`, `Double`.
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

-- | Generates a field name that matches the field name in schema
-- (sanitised for Haskell, so first letter is lower cased)
--
-- For example, if the schema defines type 'Person' that has a field 'firstName',
-- then the generated Haskell type will be like
--
-- @
-- Person { firstName :: Text }
-- @
-- You may want to enable 'DuplicateRecordFields' if you want to use this method.
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

-- | Derives Haskell types from the given Avro schema file. These
-- Haskell types support both reading and writing to Avro.
--
-- For an Avro schema with a top-level record called
-- @com.example.Foo@, this generates:
--
--   * a 'Schema' with the name @schema'Foo@ or
--     @schema'com'example'Foo@, depending on the 'namespaceBehavior'
--     setting.
--
--   * Haskell types for each named type defined in the schema
--     * 'HasSchema' instances for each type
--     * 'FromAvro' instances for each type
--     * 'ToAvro' instances for each type
--
-- This function ignores namespaces when generated Haskell type and
-- field names. This will fail on valid Avro schemas which contain
-- types with the same base name in different namespaces. It will also
-- fail for schemas that contain types with base names that are the
-- same except for the capitalization of the first letter.
--
-- The type @com.example.Foo@ will generate a Haskell type @Foo@. If
-- @com.example.Foo@ has a field named @Bar@, the field in the Haskell
-- record will be called @fooBar@.
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

-- | Derive Haskell types from the given Avro schema.
--
-- For an Avro schema with a top-level definition @com.example.Foo@, this
-- generates:
--
--   * a 'Schema' with the name @schema'Foo@ or
--     @schema'com'example'Foo@ depending on namespace handling
--
--   * Haskell types for each named type defined in the schema
--     * 'HasSchema' instances for each type
--     * 'FromAvro' instances for each type
--     * 'ToAvro' instances for each type
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

-- | Same as 'deriveAvroWithOptions' but uses 'defaultDeriveOptions'
--
-- @
-- deriveAvro = 'deriveAvroWithOptions' 'defaultDeriveOptions'
-- @
deriveAvro :: FilePath -> Q [Dec]
deriveAvro :: String -> Q [Dec]
deriveAvro = DeriveOptions -> String -> Q [Dec]
deriveAvroWithOptions DeriveOptions
defaultDeriveOptions

-- | Same as 'deriveAvroWithOptions'' but uses 'defaultDeriveOptions'
--
-- @
-- deriveAvro' = 'deriveAvroWithOptions'' 'defaultDeriveOptions'
-- @
deriveAvro' :: Schema -> Q [Dec]
deriveAvro' :: Schema -> Q [Dec]
deriveAvro' = DeriveOptions -> Schema -> Q [Dec]
deriveAvroWithOptions' DeriveOptions
defaultDeriveOptions

-- | Same as 'deriveAvro' but takes a ByteString rather than FilePath
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

-- | Generates the value of type 'Schema' that it can later be used with
-- 'deriveAvro'' or 'deriveAvroWithOptions''.
--
-- @
-- mySchema :: Schema
-- mySchema = $(makeSchema "schemas/my-schema.avsc")
-- @
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

---------------------------- New FromAvro -----------------------------------------

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)
    )
  |]

----------------------- HasAvroSchema ----------------------------------------

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
            -- ^ base name
         -> Int
            -- ^ count
         -> 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]]

------------------------- ToAvro ------------------------------------------------

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
  |]

-- | A hack around TemplateHaskell limitation:
-- It is currently not possible to splice variable name in QQ.
-- This function allows to replace hardcoded name into the specified one.
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)

-- | Renders a fully qualified Avro name to a valid Haskell
-- identifier. This does not change capitalization—make sure to
-- capitalize as needed depending on whether the name is a Haskell
-- type, constructor, variable or field.
--
-- With 'HandleNamespaces', namespace components (if any) are
-- separated with @'@. The Avro name @"com.example.foo"@ would be
-- rendered as @com'example'foo@.
--
-- With 'IgnoreNamespaces', only the base name of the type is
-- used. The Avro name @"com.example.foo"@ would be rendered as
-- @"foo"@.
renderName :: NamespaceBehavior
              -- ^ How to handle namespaces when generating the type
              -- name.
           -> TypeName
              -- ^ The name to transform into a valid Haskell
              -- identifier.
           -> 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