{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE PartialTypeSignatures #-}
{-# OPTIONS_GHC -Wno-type-defaults #-}
{-# OPTIONS_GHC -fno-warn-partial-type-signatures #-}

{-
  An Encoder is used to encode a specific data type into a MessagePack Object
  This module provides several functions to create encoders and assemble them into a registry of encoders.
-}

module Data.Registry.MessagePack.Encoder where

import Control.Monad.Fail
import Data.Functor.Contravariant
import Data.List (nub)
import Data.MessagePack
import Data.Registry
import Data.Registry.Internal.Types
import Data.Registry.MessagePack.Options
import Data.Registry.MessagePack.TH
import Language.Haskell.TH
import Language.Haskell.TH.Syntax
import Protolude hiding (Type)
import Prelude (String)

-- * ENCODER DATA TYPE

newtype Encoder a = Encoder {Encoder a -> a -> Object
encode :: a -> Object}

instance Contravariant Encoder where
  contramap :: (a -> b) -> Encoder b -> Encoder a
contramap a -> b
f (Encoder b -> Object
a) = (a -> Object) -> Encoder a
forall a. (a -> Object) -> Encoder a
Encoder (b -> Object
a (b -> Object) -> (a -> b) -> a -> Object
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
f)

-- * ENCODE VALUES

encodeByteString :: Encoder a -> a -> ByteString
encodeByteString :: Encoder a -> a -> ByteString
encodeByteString (Encoder a -> Object
e) = Object -> ByteString
forall a. MessagePack a => a -> ByteString
pack' (Object -> ByteString) -> (a -> Object) -> a -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Object
e

-- * CREATE ENCODERS

-- | Create an encoder from a MessagePack instance
messagePackEncoder :: forall a. (MessagePack a, Typeable a) => Typed (Encoder a)
messagePackEncoder :: Typed (Encoder a)
messagePackEncoder = Encoder a -> Typed (Encoder a)
forall a. Typeable a => a -> Typed a
fun (MessagePack a => Encoder a
forall a. MessagePack a => Encoder a
messagePackEncoderOf @a)

messagePackEncoderOf :: MessagePack a => Encoder a
messagePackEncoderOf :: Encoder a
messagePackEncoderOf = (a -> Object) -> Encoder a
forall a. (a -> Object) -> Encoder a
Encoder a -> Object
forall a. MessagePack a => a -> Object
toObject

-- | Create an encoder from a MessagePack instance
showEncoder :: forall a. (Typeable a, Show a) => Typed (Encoder String -> Encoder a)
showEncoder :: Typed (Encoder String -> Encoder a)
showEncoder = (Encoder String -> Encoder a)
-> Typed (Encoder String -> Encoder a)
forall a. Typeable a => a -> Typed a
fun Encoder String -> Encoder a
forall a. Show a => Encoder String -> Encoder a
showEncoderOf

showEncoderOf :: forall a. (Show a) => Encoder String -> Encoder a
showEncoderOf :: Encoder String -> Encoder a
showEncoderOf Encoder String
e = (a -> Object) -> Encoder a
forall a. (a -> Object) -> Encoder a
Encoder ((a -> Object) -> Encoder a) -> (a -> Object) -> Encoder a
forall a b. (a -> b) -> a -> b
$ Encoder String -> String -> Object
forall a. Encoder a -> a -> Object
encode Encoder String
e (String -> Object) -> (a -> String) -> a -> Object
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> String
forall a b. (Show a, ConvertText String b) => a -> b
show

-- * COMBINATORS

-- | Create an Encoder for a (Maybe a)
encodeMaybeOf :: forall a. (Typeable a) => Typed (Encoder a -> Encoder (Maybe a))
encodeMaybeOf :: Typed (Encoder a -> Encoder (Maybe a))
encodeMaybeOf = (Encoder a -> Encoder (Maybe a))
-> Typed (Encoder a -> Encoder (Maybe a))
forall a. Typeable a => a -> Typed a
fun (Encoder a -> Encoder (Maybe a)
forall a. Encoder a -> Encoder (Maybe a)
maybeOfEncoder @a)

maybeOfEncoder :: Encoder a -> Encoder (Maybe a)
maybeOfEncoder :: Encoder a -> Encoder (Maybe a)
maybeOfEncoder (Encoder a -> Object
e) = (Maybe a -> Object) -> Encoder (Maybe a)
forall a. (a -> Object) -> Encoder a
Encoder ((Maybe a -> Object) -> Encoder (Maybe a))
-> (Maybe a -> Object) -> Encoder (Maybe a)
forall a b. (a -> b) -> a -> b
$ \case
  Maybe a
Nothing -> Object
ObjectNil
  Just a
a -> a -> Object
e a
a

-- | Create an Encoder for a pair (a, b)
encodePairOf :: forall a b. (Typeable a, Typeable b) => Typed (Encoder a -> Encoder b -> Encoder (a, b))
encodePairOf :: Typed (Encoder a -> Encoder b -> Encoder (a, b))
encodePairOf = (Encoder a -> Encoder b -> Encoder (a, b))
-> Typed (Encoder a -> Encoder b -> Encoder (a, b))
forall a. Typeable a => a -> Typed a
fun (Encoder a -> Encoder b -> Encoder (a, b)
forall a b. Encoder a -> Encoder b -> Encoder (a, b)
pairOfEncoder @a @b)

pairOfEncoder :: Encoder a -> Encoder b -> Encoder (a, b)
pairOfEncoder :: Encoder a -> Encoder b -> Encoder (a, b)
pairOfEncoder (Encoder a -> Object
ea) (Encoder b -> Object
eb) =
  ((a, b) -> Object) -> Encoder (a, b)
forall a. (a -> Object) -> Encoder a
Encoder (((a, b) -> Object) -> Encoder (a, b))
-> ((a, b) -> Object) -> Encoder (a, b)
forall a b. (a -> b) -> a -> b
$ \(a
a, b
b) -> Vector Object -> Object
ObjectArray [a -> Object
ea a
a, b -> Object
eb b
b]

-- | Create an Encoder for a tripe (a, b, c)
encodeTripleOf :: forall a b c. (Typeable a, Typeable b, Typeable c) => Typed (Encoder a -> Encoder b -> Encoder c -> Encoder (a, b, c))
encodeTripleOf :: Typed (Encoder a -> Encoder b -> Encoder c -> Encoder (a, b, c))
encodeTripleOf = (Encoder a -> Encoder b -> Encoder c -> Encoder (a, b, c))
-> Typed (Encoder a -> Encoder b -> Encoder c -> Encoder (a, b, c))
forall a. Typeable a => a -> Typed a
fun (Encoder a -> Encoder b -> Encoder c -> Encoder (a, b, c)
forall a b c.
Encoder a -> Encoder b -> Encoder c -> Encoder (a, b, c)
tripleOfEncoder @a @b @c)

tripleOfEncoder :: Encoder a -> Encoder b -> Encoder c -> Encoder (a, b, c)
tripleOfEncoder :: Encoder a -> Encoder b -> Encoder c -> Encoder (a, b, c)
tripleOfEncoder (Encoder a -> Object
ea) (Encoder b -> Object
eb) (Encoder c -> Object
ec) =
  ((a, b, c) -> Object) -> Encoder (a, b, c)
forall a. (a -> Object) -> Encoder a
Encoder (((a, b, c) -> Object) -> Encoder (a, b, c))
-> ((a, b, c) -> Object) -> Encoder (a, b, c)
forall a b. (a -> b) -> a -> b
$ \(a
a, b
b, c
c) -> Vector Object -> Object
ObjectArray [a -> Object
ea a
a, b -> Object
eb b
b, c -> Object
ec c
c]

-- | Create an Encoder for a list [a]
encodeListOf :: forall a. (Typeable a) => Typed (Encoder a -> Encoder [a])
encodeListOf :: Typed (Encoder a -> Encoder [a])
encodeListOf = (Encoder a -> Encoder [a]) -> Typed (Encoder a -> Encoder [a])
forall a. Typeable a => a -> Typed a
fun (Encoder a -> Encoder [a]
forall a. Encoder a -> Encoder [a]
listOfEncoder @a)

listOfEncoder :: Encoder a -> Encoder [a]
listOfEncoder :: Encoder a -> Encoder [a]
listOfEncoder (Encoder a -> Object
ea) = ([a] -> Object) -> Encoder [a]
forall a. (a -> Object) -> Encoder a
Encoder (([a] -> Object) -> Encoder [a]) -> ([a] -> Object) -> Encoder [a]
forall a b. (a -> b) -> a -> b
$ \[a]
as -> [Object] -> Object
forall a. MessagePack a => a -> Object
toObject ([Object] -> Object) -> [Object] -> Object
forall a b. (a -> b) -> a -> b
$ a -> Object
ea (a -> Object) -> [a] -> [Object]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [a]
as

-- | Create an Encoder for a non-empty list (NonEmpty a)
encodeNonEmptyOf :: forall a. (Typeable a) => Typed (Encoder a -> Encoder (NonEmpty a))
encodeNonEmptyOf :: Typed (Encoder a -> Encoder (NonEmpty a))
encodeNonEmptyOf = (Encoder a -> Encoder (NonEmpty a))
-> Typed (Encoder a -> Encoder (NonEmpty a))
forall a. Typeable a => a -> Typed a
fun (Encoder a -> Encoder (NonEmpty a)
forall a. Encoder a -> Encoder (NonEmpty a)
nonEmptyOfEncoder @a)

nonEmptyOfEncoder :: Encoder a -> Encoder (NonEmpty a)
nonEmptyOfEncoder :: Encoder a -> Encoder (NonEmpty a)
nonEmptyOfEncoder (Encoder a -> Object
ea) = (NonEmpty a -> Object) -> Encoder (NonEmpty a)
forall a. (a -> Object) -> Encoder a
Encoder ((NonEmpty a -> Object) -> Encoder (NonEmpty a))
-> (NonEmpty a -> Object) -> Encoder (NonEmpty a)
forall a b. (a -> b) -> a -> b
$ \NonEmpty a
as -> NonEmpty Object -> Object
forall a. MessagePack a => a -> Object
toObject (NonEmpty Object -> Object) -> NonEmpty Object -> Object
forall a b. (a -> b) -> a -> b
$ a -> Object
ea (a -> Object) -> NonEmpty a -> NonEmpty Object
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NonEmpty a
as

-- * TEMPLATE HASKELL

-- | Make an Encoder for a given data type
--   Usage: $(makeEncoder ''MyDataType <: otherEncoders)
makeEncoder :: Name -> ExpQ
makeEncoder :: Name -> ExpQ
makeEncoder = Options -> Name -> ExpQ
makeEncoderWith Options
defaultOptions

-- | Make an Encoder for a given data type, where all types names are qualified
--   Usage: $(makeEncoderQualified ''MyDataType <: otherEncoders)
makeEncoderQualified :: Name -> ExpQ
makeEncoderQualified :: Name -> ExpQ
makeEncoderQualified = Options -> Name -> ExpQ
makeEncoderWith ((Text -> Text) -> Options
Options Text -> Text
qualified)

-- | Make an Encoder for a given data type, where all types names are qualified
--   Usage: $(makeEncoderQualifiedLast ''MyDataType <: otherEncoders)
makeEncoderQualifiedLast :: Name -> ExpQ
makeEncoderQualifiedLast :: Name -> ExpQ
makeEncoderQualifiedLast = Options -> Name -> ExpQ
makeEncoderWith ((Text -> Text) -> Options
Options Text -> Text
qualifyWithLastName)

-- | Make an Encoder for a given data type with a specific set of options
--   Usage: $(makeEncoderWith (Options qualify) ''MyDataType <: otherEncoders)
makeEncoderWith :: Options -> Name -> ExpQ
makeEncoderWith :: Options -> Name -> ExpQ
makeEncoderWith Options
options Name
encodedType = ExpQ -> ExpQ -> ExpQ
appE (Name -> ExpQ
varE (Name -> ExpQ) -> Name -> ExpQ
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
"fun") (ExpQ -> ExpQ) -> ExpQ -> ExpQ
forall a b. (a -> b) -> a -> b
$ do
  Info
info <- Name -> Q Info
reify Name
encodedType
  case Info
info of
    -- \(ea::Encoder OldType) -> Encoder (\(NewType a) -> encode ea a)
    TyConI (NewtypeD Cxt
_context Name
_name [TyVarBndr]
_typeVars Maybe Kind
_kind (RecC Name
constructor [(_, _, other)]) [DerivClause]
_deriving) -> do
      let cName :: Name
cName = Options -> Name -> Name
makeName Options
options Name
constructor
      [PatQ] -> ExpQ -> ExpQ
lamE [PatQ -> TypeQ -> PatQ
sigP (Name -> PatQ
varP (Name -> PatQ) -> Name -> PatQ
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
"ea") (TypeQ -> TypeQ -> TypeQ
appT (Name -> TypeQ
conT (Name -> TypeQ) -> Name -> TypeQ
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
"Encoder") (Kind -> TypeQ
forall (f :: * -> *) a. Applicative f => a -> f a
pure Kind
other))] (ExpQ -> ExpQ -> ExpQ
appE (Name -> ExpQ
conE (Name -> ExpQ) -> Name -> ExpQ
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
"Encoder") ([PatQ] -> ExpQ -> ExpQ
lamE [Name -> [PatQ] -> PatQ
conP Name
cName [Name -> PatQ
varP (Name -> PatQ) -> Name -> PatQ
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
"a"]] (ExpQ -> ExpQ -> ExpQ
appE (ExpQ -> ExpQ -> ExpQ
appE (Name -> ExpQ
varE (Name -> ExpQ) -> Name -> ExpQ
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
"encode") (Name -> ExpQ
varE (Name -> ExpQ) -> Name -> ExpQ
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
"ea")) (Name -> ExpQ
varE (Name -> ExpQ) -> Name -> ExpQ
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
"a"))))
    -- \(e::Encoder OldType) -> Encoder (\(NewType a) -> encode e a)
    TyConI (NewtypeD Cxt
_context Name
_name [TyVarBndr]
_typeVars Maybe Kind
_kind (NormalC Name
constructor [(_, other)]) [DerivClause]
_deriving) -> do
      let cName :: Name
cName = Options -> Name -> Name
makeName Options
options Name
constructor
      [PatQ] -> ExpQ -> ExpQ
lamE [PatQ -> TypeQ -> PatQ
sigP (Name -> PatQ
varP (Name -> PatQ) -> Name -> PatQ
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
"ea") (TypeQ -> TypeQ -> TypeQ
appT (Name -> TypeQ
conT (Name -> TypeQ) -> Name -> TypeQ
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
"Encoder") (Kind -> TypeQ
forall (f :: * -> *) a. Applicative f => a -> f a
pure Kind
other))] (ExpQ -> ExpQ -> ExpQ
appE (Name -> ExpQ
conE (Name -> ExpQ) -> Name -> ExpQ
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
"Encoder") ([PatQ] -> ExpQ -> ExpQ
lamE [Name -> [PatQ] -> PatQ
conP Name
cName [Name -> PatQ
varP (Name -> PatQ) -> Name -> PatQ
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
"a"]] (ExpQ -> ExpQ -> ExpQ
appE (ExpQ -> ExpQ -> ExpQ
appE (Name -> ExpQ
varE (Name -> ExpQ) -> Name -> ExpQ
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
"encode") (Name -> ExpQ
varE (Name -> ExpQ) -> Name -> ExpQ
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
"ea")) (Name -> ExpQ
varE (Name -> ExpQ) -> Name -> ExpQ
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
"a"))))
    TyConI (DataD Cxt
_context Name
_name [TyVarBndr]
_typeVars Maybe Kind
_kind [Con]
constructors [DerivClause]
_deriving) -> do
      case [Con]
constructors of
        [] -> do
          Bool -> String -> Q ()
forall (m :: * -> *). Quasi m => Bool -> String -> m ()
qReport Bool
True String
"can not make an Encoder for an empty data type"
          String -> ExpQ
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"encoders creation failed"
        [Item [Con]
c] -> Options -> Con -> ExpQ
makeConstructorEncoder Options
options Item [Con]
Con
c
        [Con]
_ -> Options -> [Con] -> ExpQ
makeConstructorsEncoder Options
options [Con]
constructors
    Info
other -> do
      Bool -> String -> Q ()
forall (m :: * -> *). Quasi m => Bool -> String -> m ()
qReport Bool
True (String
"can only create encoders for an ADT, got: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Info -> String
forall a b. (Show a, ConvertText String b) => a -> b
show Info
other)
      String -> ExpQ
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"encoders creation failed"

-- | Make an Encoder for a data type with a single constructor
-- \(e0::Encoder A0) (e1::Encoder A1) ... -> Encoder $ \(T a0 a1 ...) -> ObjectArray [encode e0 a0, encode e1 a1, ...]
makeConstructorEncoder :: Options -> Con -> ExpQ
makeConstructorEncoder :: Options -> Con -> ExpQ
makeConstructorEncoder Options
options Con
c = do
  Cxt
types <- Con -> Q Cxt
typesOf Con
c
  Name
cName <- Options -> Name -> Name
makeName Options
options (Name -> Name) -> Q Name -> Q Name
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Con -> Q Name
nameOf Con
c
  let encoderParameters :: [PatQ]
encoderParameters = (\(Kind
t, Integer
n) -> PatQ -> TypeQ -> PatQ
sigP (Name -> PatQ
varP (String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ String
"e" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Integer -> String
forall a b. (Show a, ConvertText String b) => a -> b
show Integer
n)) (TypeQ -> TypeQ -> TypeQ
appT (Name -> TypeQ
conT (Name -> TypeQ) -> Name -> TypeQ
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
"Encoder") (Kind -> TypeQ
forall (f :: * -> *) a. Applicative f => a -> f a
pure Kind
t))) ((Kind, Integer) -> PatQ) -> [(Kind, Integer)] -> [PatQ]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Cxt -> [Integer] -> [(Kind, Integer)]
forall a b. [a] -> [b] -> [(a, b)]
zip Cxt
types [Item [Integer]
0 ..]
  let params :: PatQ
params = Name -> [PatQ] -> PatQ
conP (String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ Name -> String
forall a b. (Show a, ConvertText String b) => a -> b
show Name
cName) ([PatQ] -> PatQ) -> [PatQ] -> PatQ
forall a b. (a -> b) -> a -> b
$ (\(Kind
_, Integer
n) -> Name -> PatQ
varP (String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ String
"a" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Integer -> String
forall a b. (Show a, ConvertText String b) => a -> b
show Integer
n)) ((Kind, Integer) -> PatQ) -> [(Kind, Integer)] -> [PatQ]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Cxt -> [Integer] -> [(Kind, Integer)]
forall a b. [a] -> [b] -> [(a, b)]
zip Cxt
types [Item [Integer]
0 ..]
  let values :: [ExpQ]
values = (\(Kind
_, Integer
n) -> ExpQ -> ExpQ -> ExpQ
appE (ExpQ -> ExpQ -> ExpQ
appE (Name -> ExpQ
varE (Name -> ExpQ) -> Name -> ExpQ
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
"encode") (Name -> ExpQ
varE (String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ String
"e" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Integer -> String
forall a b. (Show a, ConvertText String b) => a -> b
show Integer
n))) (Name -> ExpQ
varE (String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ String
"a" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Integer -> String
forall a b. (Show a, ConvertText String b) => a -> b
show Integer
n))) ((Kind, Integer) -> ExpQ) -> [(Kind, Integer)] -> [ExpQ]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Cxt -> [Integer] -> [(Kind, Integer)]
forall a b. [a] -> [b] -> [(a, b)]
zip Cxt
types [Item [Integer]
0 ..]
  let encoded :: ExpQ
encoded = ExpQ -> ExpQ -> ExpQ
appE (Name -> ExpQ
conE (String -> Name
mkName String
"ObjectArray")) (ExpQ -> ExpQ -> ExpQ
appE (Name -> ExpQ
varE (String -> Name
mkName String
"Data.Vector.fromList")) ([ExpQ] -> ExpQ
listE [ExpQ]
values))
  [PatQ] -> ExpQ -> ExpQ
lamE [PatQ]
encoderParameters (ExpQ -> ExpQ -> ExpQ
appE (Name -> ExpQ
conE (String -> Name
mkName String
"Encoder")) ([PatQ] -> ExpQ -> ExpQ
lamE [PatQ
Item [PatQ]
params] ExpQ
encoded))

-- | Make an Encoder for a data type with several constructors
-- \(e0::Encoder A0) (e1::Encoder A1) (e2::Encoder A2) ... -> Encoder $ \case
--    T0  -> ObjectArray [ObjectInt 0]
--    T1 a0 a1 ... -> ObjectArray [ObjectInt 1, encode e0 a0, encode e1 a1, ...]
--    T2 a2 a0 ... -> ObjectArray [ObjectInt 2, encode e2 a2, encode e0 a0, ...]
makeConstructorsEncoder :: Options -> [Con] -> ExpQ
makeConstructorsEncoder :: Options -> [Con] -> ExpQ
makeConstructorsEncoder Options
options [Con]
cs = do
  -- get the types of all the fields of all the constructors
  Cxt
types <- Cxt -> Cxt
forall a. Eq a => [a] -> [a]
nub (Cxt -> Cxt) -> ([Cxt] -> Cxt) -> [Cxt] -> Cxt
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Cxt] -> Cxt
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join ([Cxt] -> Cxt) -> Q [Cxt] -> Q Cxt
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Con] -> (Con -> Q Cxt) -> Q [Cxt]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [Con]
cs Con -> Q Cxt
typesOf
  let encoderParameters :: [PatQ]
encoderParameters = (\(Kind
t, Integer
n) -> PatQ -> TypeQ -> PatQ
sigP (Name -> PatQ
varP (String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ String
"e" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Integer -> String
forall a b. (Show a, ConvertText String b) => a -> b
show Integer
n)) (TypeQ -> TypeQ -> TypeQ
appT (Name -> TypeQ
conT (Name -> TypeQ) -> Name -> TypeQ
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
"Encoder") (Kind -> TypeQ
forall (f :: * -> *) a. Applicative f => a -> f a
pure Kind
t))) ((Kind, Integer) -> PatQ) -> [(Kind, Integer)] -> [PatQ]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Cxt -> [Integer] -> [(Kind, Integer)]
forall a b. [a] -> [b] -> [(a, b)]
zip Cxt
types [Item [Integer]
0 ..]
  [Match]
matchClauses <- [(Con, Integer)] -> ((Con, Integer) -> Q Match) -> Q [Match]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for ([Con] -> [Integer] -> [(Con, Integer)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Con]
cs [Item [Integer]
0 ..]) ((Con -> Integer -> Q Match) -> (Con, Integer) -> Q Match
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry ((Con -> Integer -> Q Match) -> (Con, Integer) -> Q Match)
-> (Con -> Integer -> Q Match) -> (Con, Integer) -> Q Match
forall a b. (a -> b) -> a -> b
$ Options -> Cxt -> Con -> Integer -> Q Match
makeMatchClause Options
options Cxt
types)
  [PatQ] -> ExpQ -> ExpQ
lamE [PatQ]
encoderParameters (ExpQ -> ExpQ -> ExpQ
appE (Name -> ExpQ
conE (String -> Name
mkName String
"Encoder")) ([Q Match] -> ExpQ
lamCaseE (Match -> Q Match
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Match -> Q Match) -> [Match] -> [Q Match]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Match]
matchClauses)))

-- | Make the match clause for a constructor given
--    - the list of all the encoder types
--    - the constructor name
--    - the constructor index in the list of all the constructors for the encoded data type
makeMatchClause :: Options -> [Type] -> Con -> Integer -> MatchQ
makeMatchClause :: Options -> Cxt -> Con -> Integer -> Q Match
makeMatchClause Options
options Cxt
allTypes Con
c Integer
constructorIndex = do
  Cxt
ts <- Con -> Q Cxt
typesOf Con
c
  [(Kind, Int)]
constructorTypes <- Cxt -> Cxt -> Q [(Kind, Int)]
indexConstructorTypes Cxt
allTypes Cxt
ts
  Name
cName <- Options -> Name -> Name
makeName Options
options (Name -> Name) -> Q Name -> Q Name
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Con -> Q Name
nameOf Con
c
  let params :: PatQ
params = Name -> [PatQ] -> PatQ
conP (String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ Name -> String
forall a b. (Show a, ConvertText String b) => a -> b
show Name
cName) ([PatQ] -> PatQ) -> [PatQ] -> PatQ
forall a b. (a -> b) -> a -> b
$ (\(Kind
_, Int
n) -> Name -> PatQ
varP (String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ String
"a" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a b. (Show a, ConvertText String b) => a -> b
show Int
n)) ((Kind, Int) -> PatQ) -> [(Kind, Int)] -> [PatQ]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Kind, Int)]
constructorTypes
  let values :: [ExpQ]
values = (\(Kind
_, Int
n) -> ExpQ -> ExpQ -> ExpQ
appE (ExpQ -> ExpQ -> ExpQ
appE (Name -> ExpQ
varE (Name -> ExpQ) -> Name -> ExpQ
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
"encode") (Name -> ExpQ
varE (String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ String
"e" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a b. (Show a, ConvertText String b) => a -> b
show Int
n))) (Name -> ExpQ
varE (String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ String
"a" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a b. (Show a, ConvertText String b) => a -> b
show Int
n))) ((Kind, Int) -> ExpQ) -> [(Kind, Int)] -> [ExpQ]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Kind, Int)]
constructorTypes
  let index :: ExpQ
index = ExpQ -> ExpQ -> ExpQ
appE (Name -> ExpQ
conE (Name -> ExpQ) -> Name -> ExpQ
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
"ObjectInt") (Lit -> ExpQ
litE (Integer -> Lit
integerL Integer
constructorIndex))
  let encoded :: ExpQ
encoded = ExpQ -> ExpQ -> ExpQ
appE (Name -> ExpQ
conE (String -> Name
mkName String
"ObjectArray")) (ExpQ -> ExpQ -> ExpQ
appE (Name -> ExpQ
varE (String -> Name
mkName String
"Data.Vector.fromList")) ([ExpQ] -> ExpQ
listE ([ExpQ] -> ExpQ) -> [ExpQ] -> ExpQ
forall a b. (a -> b) -> a -> b
$ ExpQ
index ExpQ -> [ExpQ] -> [ExpQ]
forall a. a -> [a] -> [a]
: [ExpQ]
values))
  PatQ -> BodyQ -> [DecQ] -> Q Match
match PatQ
params (ExpQ -> BodyQ
normalB ExpQ
encoded) []