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

{- HLINT ignore "Avoid lambda using `infix`" -}

-- | This module lets us derive Haskell types from an Avro schema that
-- can be serialized/deserialzed 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
  , r
)
where

import           Control.Monad                (join)
import           Control.Monad.Identity       (Identity)
import           Data.Aeson                   (eitherDecode)
import qualified Data.Aeson                   as J
import           Data.Avro                    hiding (decode, encode)
import           Data.Avro.Encoding.ToAvro    (ToAvro (..))
import           Data.Avro.Internal.EncodeRaw (putI)
import           Data.Avro.Schema.Schema      as S
import           Data.ByteString              (ByteString)
import qualified Data.ByteString              as B
import           Data.Char                    (isAlphaNum)
import qualified Data.Foldable                as Foldable
import           Data.Int
import           Data.List.NonEmpty           (NonEmpty ((:|)))
import qualified Data.List.NonEmpty           as NE
import           Data.Map                     (Map)
import           Data.Maybe                   (fromMaybe)
import           Data.Semigroup               ((<>))
import qualified Data.Text                    as Text
import           Data.Time                    (Day, DiffTime, LocalTime, UTCTime)
import           Data.UUID                    (UUID)
import           Text.RawString.QQ            (r)

import qualified Data.Avro.Encoding.FromAvro as AV

import GHC.Generics (Generic)

import Language.Haskell.TH        as TH hiding (notStrict)
import Language.Haskell.TH.Lib    as TH hiding (notStrict)
import Language.Haskell.TH.Syntax

import Data.Avro.Deriving.NormSchema
import Data.Avro.EitherN

import qualified Data.ByteString            as BS
import qualified Data.ByteString.Lazy       as LBS
import qualified Data.ByteString.Lazy.Char8 as LBSC8
import qualified Data.HashMap.Strict        as HM
import qualified Data.Set                   as S
import           Data.Text                  (Text)
import qualified Data.Text                  as T
import qualified Data.Vector                as V

import Data.Avro.Deriving.Lift ()

-- | 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 (T.Text -> [T.Text] -> T.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
$cto :: forall x. Rep FieldStrictness x -> FieldStrictness
$cfrom :: forall x. FieldStrictness -> Rep FieldStrictness x
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
$cto :: forall x. Rep FieldUnpackedness x -> FieldUnpackedness
$cfrom :: forall x. FieldUnpackedness -> Rep FieldUnpackedness x
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 -> T.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
$cto :: forall x. Rep DeriveOptions x -> DeriveOptions
$cfrom :: forall x. DeriveOptions -> Rep DeriveOptions x
Generic

-- | Default deriving options
--
-- @
-- defaultDeriveOptions = 'DeriveOptions'
--   { fieldNameBuilder  = 'mkPrefixedFieldName'
--   , fieldStrictness   = 'mkLazyField'
--   , namespaceBehavior = 'IgnoreNamespaces'
--   }
-- @
defaultDeriveOptions :: DeriveOptions
defaultDeriveOptions = DeriveOptions :: (Text -> Field -> Text)
-> (TypeName -> Field -> (FieldStrictness, FieldUnpackedness))
-> NamespaceBehavior
-> DeriveOptions
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 -> T.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
T.toLower Text
prefix Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (Text -> Text) -> Text -> Text
updateFirst Text -> Text
T.toUpper (Field -> Text
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
S.fldType Field
field of
        Schema
S.Null    -> FieldUnpackedness
NonUnpackedField
        Schema
S.Boolean -> FieldUnpackedness
NonUnpackedField
        Schema
_         -> FieldUnpackedness
UnpackedField

    shouldStricten :: Bool
shouldStricten =
      case Field -> Schema
S.fldType Field
field of
        Schema
S.Null    -> Bool
True
        Schema
S.Boolean -> Bool
True
        S.Int Maybe LogicalTypeInt
_   -> Bool
True
        S.Long Maybe LogicalTypeLong
_  -> Bool
True
        Schema
S.Float   -> Bool
True
        Schema
S.Double  -> Bool
True
        Schema
_         -> Bool
False

-- | 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
T.toLower (Text -> Text) -> (Field -> Text) -> Field -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Field -> Text
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 -> FilePath -> Q [Dec]
deriveAvroWithOptions DeriveOptions
o FilePath
p = FilePath -> Q Schema
readSchema FilePath
p Q Schema -> (Schema -> Q [Dec]) -> Q [Dec]
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)
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)
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)
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)
traverse (DeriveOptions -> Schema -> Q [Dec]
genToAvro DeriveOptions
o) [Schema]
schemas
  [Dec] -> Q [Dec]
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 :: FilePath -> Q [Dec]
deriveAvro = DeriveOptions -> FilePath -> 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 :: LBS.ByteString -> Q [Dec]
deriveAvroFromByteString :: ByteString -> Q [Dec]
deriveAvroFromByteString ByteString
bs = case ByteString -> Either FilePath Schema
forall a. FromJSON a => ByteString -> Either FilePath a
eitherDecode ByteString
bs of
    Right Schema
schema -> DeriveOptions -> Schema -> Q [Dec]
deriveAvroWithOptions' DeriveOptions
defaultDeriveOptions Schema
schema
    Left FilePath
err     -> FilePath -> Q [Dec]
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail (FilePath -> Q [Dec]) -> FilePath -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ FilePath
"Unable to generate Avro from bytestring: " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
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 :: FilePath -> Q Exp
makeSchema FilePath
p = FilePath -> Q Schema
readSchema FilePath
p Q Schema -> (Schema -> Q Exp) -> Q Exp
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Schema -> Q Exp
forall t. Lift t => t -> Q Exp
lift

makeSchemaFromByteString :: LBS.ByteString -> Q Exp
makeSchemaFromByteString :: ByteString -> Q Exp
makeSchemaFromByteString ByteString
bs = case ByteString -> Either FilePath Schema
forall a. FromJSON a => ByteString -> Either FilePath a
eitherDecode @Schema ByteString
bs of
  Right Schema
schema -> Schema -> Q Exp
forall t. Lift t => t -> Q Exp
lift Schema
schema
  Left FilePath
err     -> FilePath -> Q Exp
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail (FilePath -> Q Exp) -> FilePath -> Q Exp
forall a b. (a -> b) -> a -> b
$ FilePath
"Unable to generate Avro Schema from bytestring: " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
err

makeSchemaFrom :: FilePath -> Text -> Q Exp
makeSchemaFrom :: FilePath -> Text -> Q Exp
makeSchemaFrom FilePath
p Text
name = do
  Schema
s <- FilePath -> Q Schema
readSchema FilePath
p

  case Schema -> Text -> Maybe Schema
subdefinition Schema
s Text
name of
    Maybe Schema
Nothing -> FilePath -> Q Exp
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail (FilePath -> Q Exp) -> FilePath -> Q Exp
forall a b. (a -> b) -> a -> b
$ FilePath
"No such entity '" FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> Text -> FilePath
T.unpack Text
name FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
"' defined in " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
p
    Just Schema
ss -> Schema -> Q Exp
forall t. Lift t => t -> Q Exp
lift Schema
ss

readSchema :: FilePath -> Q Schema
readSchema :: FilePath -> Q Schema
readSchema FilePath
p = do
  FilePath -> Q ()
forall (m :: * -> *). Quasi m => FilePath -> m ()
qAddDependentFile FilePath
p
  Either FilePath Schema
mbSchema <- IO (Either FilePath Schema) -> Q (Either FilePath Schema)
forall a. IO a -> Q a
runIO (IO (Either FilePath Schema) -> Q (Either FilePath Schema))
-> IO (Either FilePath Schema) -> Q (Either FilePath Schema)
forall a b. (a -> b) -> a -> b
$ FilePath -> IO (Either FilePath Schema)
decodeSchema FilePath
p
  case Either FilePath Schema
mbSchema of
    Left FilePath
err  -> FilePath -> Q Schema
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail (FilePath -> Q Schema) -> FilePath -> Q Schema
forall a b. (a -> b) -> a -> b
$ FilePath
"Unable to generate AVRO for " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
p FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
": " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
err
    Right Schema
sch -> Schema -> Q Schema
forall (f :: * -> *) a. Applicative f => a -> f a
pure Schema
sch

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

badValueNew :: Show v => v -> String -> Either String a
badValueNew :: v -> FilePath -> Either FilePath a
badValueNew v
v FilePath
t = FilePath -> Either FilePath a
forall a b. a -> Either a b
Left (FilePath -> Either FilePath a) -> FilePath -> Either FilePath a
forall a b. (a -> b) -> a -> b
$ FilePath
"Unexpected value for '" FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
t FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
"': " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> v -> FilePath
forall a. Show a => a -> FilePath
show v
v

genFromValue :: NamespaceBehavior -> Schema -> Q [Dec]
genFromValue :: NamespaceBehavior -> Schema -> Q [Dec]
genFromValue NamespaceBehavior
namespaceBehavior (S.Enum TypeName
n [TypeName]
_ Maybe Text
_ Vector Text
_ ) =
  [d| instance AV.FromAvro $(conT $ mkDataTypeName namespaceBehavior n) where
        fromAvro (AV.Enum _ i _) = $([| pure . toEnum|]) i
        fromAvro value           = $( [|\v -> badValueNew v $(mkTextLit $ S.renderFullname n)|] ) value
  |]
genFromValue NamespaceBehavior
namespaceBehavior (S.Record TypeName
n [TypeName]
_ Maybe Text
_ [Field]
fs) =
  [d| instance AV.FromAvro $(conT $ mkDataTypeName namespaceBehavior n) where
        fromAvro (AV.Record _ r) =
           $(genFromAvroNewFieldsExp (mkDataTypeName namespaceBehavior n) fs) r
        fromAvro value           = $( [|\v -> badValueNew v $(mkTextLit $ S.renderFullname n)|] ) value
  |]
genFromValue NamespaceBehavior
namespaceBehavior (S.Fixed TypeName
n [TypeName]
_ Int
s Maybe LogicalTypeFixed
_) =
  [d| instance AV.FromAvro $(conT $ mkDataTypeName namespaceBehavior n) where
        fromAvro (AV.Fixed _ v)
          | BS.length v == s = pure $ $(conE (mkDataTypeName namespaceBehavior n)) v
        fromAvro value = $( [|\v -> badValueNew v $(mkTextLit $ S.renderFullname n)|] ) value
  |]
genFromValue NamespaceBehavior
_ Schema
_                             = [Dec] -> Q [Dec]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []

genFromAvroNewFieldsExp :: Name -> [Field] -> Q Exp
genFromAvroNewFieldsExp :: Name -> [Field] -> Q Exp
genFromAvroNewFieldsExp Name
n [Field]
xs =
  [| \r ->
    $(let ctor = [| pure $(conE n) |]
      in foldl (\expr (i, _) -> [| $expr <*> AV.fromAvro (r V.! i) |]) ctor (zip [(0 :: Int)..] xs)
    )
  |]

----------------------- 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
name Schema
s)
  [Dec]
sdef <- Name -> Schema -> Q [Dec]
schemaDef Name
sname Schema
s
  [Dec]
idef <- Name -> Q [Dec]
hasAvroSchema Name
sname
  [Dec] -> Q [Dec]
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 -> Q [Dec]
hasAvroSchema Name
sname =
      [d| instance HasAvroSchema $(conT $ mkDataTypeName namespaceBehavior (name s)) where
            schema = pure $(varE sname)
      |]

newNames :: String
            -- ^ base name
         -> Int
            -- ^ count
         -> Q [Name]
newNames :: FilePath -> Int -> Q [Name]
newNames FilePath
base Int
n = [Q Name] -> Q [Name]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [FilePath -> Q Name
newName (FilePath
base FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Int -> FilePath
forall a. Show a => a -> FilePath
show Int
i) | Int
i <- [Int
1..Int
n]]

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

genToAvro :: DeriveOptions -> Schema -> Q [Dec]
genToAvro :: DeriveOptions -> Schema -> Q [Dec]
genToAvro DeriveOptions
opts s :: Schema
s@(S.Enum TypeName
n [TypeName]
_ Maybe Text
_ Vector Text
_) =
  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 $(conT $ mkDataTypeName (namespaceBehavior opts) n) where
            toAvro = $([| \_ x -> putI (fromEnum x) |])
      |]

genToAvro DeriveOptions
opts s :: Schema
s@(S.Record TypeName
n [TypeName]
_ Maybe Text
_ [Field]
fs) =
  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 $(conT $ mkDataTypeName (namespaceBehavior opts) n) where
            toAvro = $(encodeAvroFieldsExp sname)
      |]
    encodeAvroFieldsExp :: p -> Q Exp
encodeAvroFieldsExp p
sname = do
      [Name]
names <- FilePath -> Int -> Q [Name]
newNames FilePath
"p_" ([Field] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Field]
fs)
      PatQ
wn <- Name -> PatQ
varP (Name -> PatQ) -> Q Name -> Q PatQ
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> Q Name
newName FilePath
"_"
      let con :: PatQ
con = Name -> [PatQ] -> PatQ
conP (NamespaceBehavior -> TypeName -> Name
mkDataTypeName (DeriveOptions -> NamespaceBehavior
namespaceBehavior DeriveOptions
opts) TypeName
n) (Name -> PatQ
varP (Name -> PatQ) -> [Name] -> [PatQ]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Name]
names)
      [PatQ] -> Q Exp -> Q Exp
lamE [PatQ
wn, PatQ
con]
            [| mconcat $( let build (fld, n) = [| toAvro (fldType fld) $(varE n) |]
                          in listE $ build <$> zip fs names
                        )
            |]

genToAvro DeriveOptions
opts s :: Schema
s@(S.Fixed TypeName
n [TypeName]
_ Int
_ Maybe LogicalTypeFixed
_) =
  Name -> Q [Dec]
encodeAvroInstance (NamespaceBehavior -> TypeName -> Name
mkSchemaValueName (DeriveOptions -> NamespaceBehavior
namespaceBehavior DeriveOptions
opts) TypeName
n)
  where
    encodeAvroInstance :: Name -> Q [Dec]
encodeAvroInstance Name
sname =
      [d| instance ToAvro $(conT $ mkDataTypeName (namespaceBehavior opts) n) where
            toAvro = $(do
              x <- newName "x"
              wc <- newName "_"
              lamE [varP wc, conP (mkDataTypeName (namespaceBehavior opts) n) [varP x]] [| toAvro $(varE sname) $(varE x) |])
      |]
genToAvro DeriveOptions
_ Schema
_ = [Dec] -> Q [Dec]
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 (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 (S.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)
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)
sequenceA [Name -> [VarStrictType] -> Q Dec
genDataType Name
dname [VarStrictType]
flds]
genType DeriveOptions
opts (S.Enum TypeName
n [TypeName]
_ Maybe Text
_ Vector Text
vs) = do
  let dname :: Name
dname = NamespaceBehavior -> TypeName -> Name
mkDataTypeName (DeriveOptions -> NamespaceBehavior
namespaceBehavior DeriveOptions
opts) TypeName
n
  [Q Dec] -> Q [Dec]
forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
sequenceA [Name -> [Name] -> Q Dec
genEnum Name
dname (NamespaceBehavior -> TypeName -> Text -> Name
mkAdtCtorName (DeriveOptions -> NamespaceBehavior
namespaceBehavior DeriveOptions
opts) TypeName
n (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 (S.Fixed TypeName
n [TypeName]
_ Int
s Maybe LogicalTypeFixed
_) = do
  let dname :: Name
dname = NamespaceBehavior -> TypeName -> Name
mkDataTypeName (DeriveOptions -> NamespaceBehavior
namespaceBehavior DeriveOptions
opts) TypeName
n
  [Q Dec] -> Q [Dec]
forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
sequenceA [Name -> Q Dec
genNewtype Name
dname]
genType DeriveOptions
_ Schema
_ = [Dec] -> Q [Dec]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []

mkFieldTypeName :: NamespaceBehavior -> S.Schema -> Q TH.Type
mkFieldTypeName :: NamespaceBehavior -> Schema -> Q Type
mkFieldTypeName NamespaceBehavior
namespaceBehavior = \case
  Schema
S.Null             -> [t| () |]
  Schema
S.Boolean          -> [t| Bool |]

  S.Long (Just (DecimalL (Decimal Integer
p Integer
s)))
                     -> [t| Decimal $(litT $ numTyLit p) $(litT $ numTyLit s) |]
  S.Long (Just LogicalTypeLong
TimeMicros)
                     -> [t| DiffTime |]
  S.Long (Just LogicalTypeLong
TimestampMicros)
                     -> [t| UTCTime |]
  S.Long (Just LogicalTypeLong
TimestampMillis)
                     -> [t| UTCTime |]
  S.Long (Just LogicalTypeLong
LocalTimestampMillis)
                     -> [t| LocalTime |]
  S.Long (Just LogicalTypeLong
LocalTimestampMicros)
                     -> [t| LocalTime |]
  S.Long Maybe LogicalTypeLong
Nothing     -> [t| Int64 |]

  S.Int (Just LogicalTypeInt
Date)  -> [t| Day |]
  S.Int (Just LogicalTypeInt
TimeMillis)
                     -> [t| DiffTime |]
  S.Int Maybe LogicalTypeInt
_            -> [t| Int32 |]
  Schema
S.Float            -> [t| Float |]
  Schema
S.Double           -> [t| Double |]
  S.Bytes Maybe LogicalTypeBytes
_          -> [t| ByteString |]
  S.String Maybe LogicalTypeString
Nothing   -> [t| Text |]
  S.String (Just LogicalTypeString
UUID) -> [t| UUID |]
  S.Union Vector Schema
branches   -> [Schema] -> Q Type
union (Vector Schema -> [Schema]
forall (t :: * -> *) a. Foldable t => t a -> [a]
Foldable.toList Vector Schema
branches)
  S.Record TypeName
n [TypeName]
_ Maybe Text
_ [Field]
_   -> [t| $(conT $ mkDataTypeName namespaceBehavior n) |]
  S.Map Schema
x            -> [t| Map Text $(go x) |]
  S.Array Schema
x          -> [t| [$(go x)] |]
  S.NamedType TypeName
n      -> [t| $(conT $ mkDataTypeName namespaceBehavior n)|]
  S.Fixed TypeName
n [TypeName]
_ Int
_ Maybe LogicalTypeFixed
_    -> [t| $(conT $ mkDataTypeName namespaceBehavior n)|]
  S.Enum TypeName
n [TypeName]
_ Maybe Text
_ Vector Text
_     -> [t| $(conT $ mkDataTypeName namespaceBehavior n)|]
  where go :: Schema -> Q Type
go = NamespaceBehavior -> Schema -> Q Type
mkFieldTypeName NamespaceBehavior
namespaceBehavior
        union :: [Schema] -> Q Type
union = \case
          []              ->
            FilePath -> Q Type
forall a. HasCallStack => FilePath -> a
error FilePath
"Empty union types are not supported"
          [Schema
x]             -> [t| Identity $(go x) |]
          [Schema
Null, Schema
x]       -> [t| Maybe $(go x) |]
          [Schema
x, Schema
Null]       -> [t| Maybe $(go x) |]
          [Schema
x, Schema
y]          -> [t| Either $(go x) $(go y) |]
          [Schema
a, Schema
b, Schema
c]       -> [t| Either3 $(go a) $(go b) $(go c) |]
          [Schema
a, Schema
b, Schema
c, Schema
d]    -> [t| Either4 $(go a) $(go b) $(go c) $(go d) |]
          [Schema
a, Schema
b, Schema
c, Schema
d, Schema
e] -> [t| Either5 $(go a) $(go b) $(go c) $(go d) $(go e) |]
          [Schema
a, Schema
b, Schema
c, Schema
d, Schema
e, Schema
f] -> [t| Either6 $(go a) $(go b) $(go c) $(go d) $(go e) $(go f) |]
          [Schema
a, Schema
b, Schema
c, Schema
d, Schema
e, Schema
f, Schema
g] -> [t| Either7 $(go a) $(go b) $(go c) $(go d) $(go e) $(go f) $(go g)|]
          [Schema
a, Schema
b, Schema
c, Schema
d, Schema
e, Schema
f, Schema
g, Schema
h] -> [t| Either8 $(go a) $(go b) $(go c) $(go d) $(go e) $(go f) $(go g) $(go h)|]
          [Schema
a, Schema
b, Schema
c, Schema
d, Schema
e, Schema
f, Schema
g, Schema
h, Schema
i] -> [t| Either9 $(go a) $(go b) $(go c) $(go d) $(go e) $(go f) $(go g) $(go h) $(go i)|]
          [Schema
a, Schema
b, Schema
c, Schema
d, Schema
e, Schema
f, Schema
g, Schema
h, Schema
i, Schema
j] -> [t| Either10 $(go a) $(go b) $(go c) $(go d) $(go e) $(go f) $(go g) $(go h) $(go i) $(go j)|]
          [Schema]
ls              ->
            FilePath -> Q Type
forall a. HasCallStack => FilePath -> a
error (FilePath -> Q Type) -> FilePath -> Q Type
forall a b. (a -> b) -> a -> b
$ FilePath
"Unions with more than 10 elements are not yet supported: Union has " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> (Int -> FilePath
forall a. Show a => a -> FilePath
show (Int -> FilePath) -> ([Schema] -> Int) -> [Schema] -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Schema] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length) [Schema]
ls FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
" elements"

updateFirst :: (Text -> Text) -> Text -> Text
updateFirst :: (Text -> Text) -> Text -> Text
updateFirst Text -> Text
f Text
t =
  let (Text
l, Text
ls) = Int -> Text -> (Text, Text)
T.splitAt Int
1 Text
t
  in Text -> Text
f Text
l Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ls

decodeSchema :: FilePath -> IO (Either String Schema)
decodeSchema :: FilePath -> IO (Either FilePath Schema)
decodeSchema FilePath
p = ByteString -> Either FilePath Schema
forall a. FromJSON a => ByteString -> Either FilePath a
eitherDecode (ByteString -> Either FilePath Schema)
-> IO ByteString -> IO (Either FilePath Schema)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> IO ByteString
LBS.readFile FilePath
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 = FilePath -> Name
mkName (FilePath -> Name) -> FilePath -> Name
forall a b. (a -> b) -> a -> b
$ Name -> FilePath
nameBase Name
a FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> Name -> FilePath
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
T.concat ([Text] -> Text) -> (Text -> [Text]) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> Text -> [Text]
T.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 (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
T.toUpper (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> Text -> Text
T.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
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 (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)
sequenceA [[t|Eq|], [t|Show|], [t|Generic|]]
  Type
fldType <- [t|ByteString|]
  let ctor :: Con
ctor = Name -> [VarStrictType] -> Con
RecC Name
dn [(FilePath -> Name
mkName (FilePath
"un" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Name -> FilePath
nameBase Name
dn), Strict
notStrict, Type
fldType)]
  Dec -> Q Dec
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)
sequenceA [[t|Eq|], [t|Show|], [t|Ord|], [t|Enum|], [t|Bounded|], [t|Generic|]]
  Dec -> Q Dec
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)
sequenceA [[t|Eq|], [t|Show|], [t|Generic|]]
  Dec -> Q Dec
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 = FilePath -> Name
mkName (FilePath -> Name) -> (Text -> FilePath) -> Text -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> FilePath
T.unpack

mkLit :: String -> ExpQ
mkLit :: FilePath -> Q Exp
mkLit = Lit -> Q Exp
litE (Lit -> Q Exp) -> (FilePath -> Lit) -> FilePath -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Lit
StringL

mkTextLit :: Text -> ExpQ
mkTextLit :: Text -> Q Exp
mkTextLit = Lit -> Q Exp
litE (Lit -> Q Exp) -> (Text -> Lit) -> Text -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Lit
StringL (FilePath -> Lit) -> (Text -> FilePath) -> Text -> Lit
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> FilePath
T.unpack