{-# 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.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 {forall a. Encoder a -> a -> Object
encode :: a -> Object}

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

-- * ENCODE VALUES

encodeByteString :: Encoder a -> a -> ByteString
encodeByteString :: forall a. Encoder a -> a -> ByteString
encodeByteString (Encoder a -> Object
e) = forall a. MessagePack a => a -> ByteString
pack' 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 :: forall a. (MessagePack a, Typeable a) => Typed (Encoder a)
messagePackEncoder = forall a. Typeable a => a -> Typed a
fun (forall a. MessagePack a => Encoder a
messagePackEncoderOf @a)

messagePackEncoderOf :: MessagePack a => Encoder a
messagePackEncoderOf :: forall a. MessagePack a => Encoder a
messagePackEncoderOf = forall a. (a -> Object) -> Encoder a
Encoder 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 :: forall a.
(Typeable a, Show a) =>
Typed (Encoder String -> Encoder a)
showEncoder = forall a. Typeable a => a -> Typed a
fun forall a. Show a => Encoder String -> Encoder a
showEncoderOf

showEncoderOf :: forall a. (Show a) => Encoder String -> Encoder a
showEncoderOf :: forall a. Show a => Encoder String -> Encoder a
showEncoderOf Encoder String
e = forall a. (a -> Object) -> Encoder a
Encoder forall a b. (a -> b) -> a -> b
$ forall a. Encoder a -> a -> Object
encode Encoder String
e forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Show a, StringConv 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 :: forall a. Typeable a => Typed (Encoder a -> Encoder (Maybe a))
encodeMaybeOf = forall a. Typeable a => a -> Typed a
fun (forall a. Encoder a -> Encoder (Maybe a)
maybeOfEncoder @a)

maybeOfEncoder :: Encoder a -> Encoder (Maybe a)
maybeOfEncoder :: forall a. Encoder a -> Encoder (Maybe a)
maybeOfEncoder (Encoder a -> Object
e) = forall a. (a -> Object) -> Encoder a
Encoder 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 :: forall a b.
(Typeable a, Typeable b) =>
Typed (Encoder a -> Encoder b -> Encoder (a, b))
encodePairOf = forall a. Typeable a => a -> Typed a
fun (forall a b. Encoder a -> Encoder b -> Encoder (a, b)
pairOfEncoder @a @b)

pairOfEncoder :: Encoder a -> Encoder b -> Encoder (a, b)
pairOfEncoder :: forall a b. Encoder a -> Encoder b -> Encoder (a, b)
pairOfEncoder (Encoder a -> Object
ea) (Encoder b -> Object
eb) =
  forall a. (a -> Object) -> Encoder a
Encoder 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 :: forall a b c.
(Typeable a, Typeable b, Typeable c) =>
Typed (Encoder a -> Encoder b -> Encoder c -> Encoder (a, b, c))
encodeTripleOf = forall a. Typeable a => a -> Typed a
fun (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 :: forall a b c.
Encoder a -> Encoder b -> Encoder c -> Encoder (a, b, c)
tripleOfEncoder (Encoder a -> Object
ea) (Encoder b -> Object
eb) (Encoder c -> Object
ec) =
  forall a. (a -> Object) -> Encoder a
Encoder 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 :: forall a. Typeable a => Typed (Encoder a -> Encoder [a])
encodeListOf = forall a. Typeable a => a -> Typed a
fun (forall a. Encoder a -> Encoder [a]
listOfEncoder @a)

listOfEncoder :: Encoder a -> Encoder [a]
listOfEncoder :: forall a. Encoder a -> Encoder [a]
listOfEncoder (Encoder a -> Object
ea) = forall a. (a -> Object) -> Encoder a
Encoder forall a b. (a -> b) -> a -> b
$ \[a]
as -> forall a. MessagePack a => a -> Object
toObject forall a b. (a -> b) -> a -> b
$ a -> Object
ea 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 :: forall a. Typeable a => Typed (Encoder a -> Encoder (NonEmpty a))
encodeNonEmptyOf = forall a. Typeable a => a -> Typed a
fun (forall a. Encoder a -> Encoder (NonEmpty a)
nonEmptyOfEncoder @a)

nonEmptyOfEncoder :: Encoder a -> Encoder (NonEmpty a)
nonEmptyOfEncoder :: forall a. Encoder a -> Encoder (NonEmpty a)
nonEmptyOfEncoder (Encoder a -> Object
ea) = forall a. (a -> Object) -> Encoder a
Encoder forall a b. (a -> b) -> a -> b
$ \NonEmpty a
as -> forall a. MessagePack a => a -> Object
toObject forall a b. (a -> b) -> a -> b
$ a -> Object
ea 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 = forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (forall (m :: * -> *). Quote m => Name -> m Exp
varE forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
"fun") 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 Type
_kind (RecC Name
constructor [(Name
_, Bang
_, Type
other)]) [DerivClause]
_deriving) -> do
      let cName :: Name
cName = Options -> Name -> Name
makeName Options
options Name
constructor
      forall (m :: * -> *). Quote m => [m Pat] -> m Exp -> m Exp
lamE [forall (m :: * -> *). Quote m => m Pat -> m Type -> m Pat
sigP (forall (m :: * -> *). Quote m => Name -> m Pat
varP forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
"ea") (forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT (forall (m :: * -> *). Quote m => Name -> m Type
conT forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
"Encoder") (forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
other))] (forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (forall (m :: * -> *). Quote m => Name -> m Exp
conE forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
"Encoder") (forall (m :: * -> *). Quote m => [m Pat] -> m Exp -> m Exp
lamE [forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
cName [forall (m :: * -> *). Quote m => Name -> m Pat
varP forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
"a"]] (forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (forall (m :: * -> *). Quote m => Name -> m Exp
varE forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
"encode") (forall (m :: * -> *). Quote m => Name -> m Exp
varE forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
"ea")) (forall (m :: * -> *). Quote m => Name -> m Exp
varE 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 Type
_kind (NormalC Name
constructor [(Bang
_, Type
other)]) [DerivClause]
_deriving) -> do
      let cName :: Name
cName = Options -> Name -> Name
makeName Options
options Name
constructor
      forall (m :: * -> *). Quote m => [m Pat] -> m Exp -> m Exp
lamE [forall (m :: * -> *). Quote m => m Pat -> m Type -> m Pat
sigP (forall (m :: * -> *). Quote m => Name -> m Pat
varP forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
"ea") (forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT (forall (m :: * -> *). Quote m => Name -> m Type
conT forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
"Encoder") (forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
other))] (forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (forall (m :: * -> *). Quote m => Name -> m Exp
conE forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
"Encoder") (forall (m :: * -> *). Quote m => [m Pat] -> m Exp -> m Exp
lamE [forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
cName [forall (m :: * -> *). Quote m => Name -> m Pat
varP forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
"a"]] (forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (forall (m :: * -> *). Quote m => Name -> m Exp
varE forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
"encode") (forall (m :: * -> *). Quote m => Name -> m Exp
varE forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
"ea")) (forall (m :: * -> *). Quote m => Name -> m Exp
varE forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
"a"))))
    TyConI (DataD Cxt
_context Name
_name [TyVarBndr ()]
_typeVars Maybe Type
_kind [Con]
constructors [DerivClause]
_deriving) -> do
      case [Con]
constructors of
        [] -> do
          forall (m :: * -> *). Quasi m => Bool -> String -> m ()
qReport Bool
True String
"can not make an Encoder for an empty data type"
          forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"encoders creation failed"
        [Item [Con]
c] -> Options -> Con -> ExpQ
makeConstructorEncoder Options
options Item [Con]
c
        [Con]
_ -> Options -> [Con] -> ExpQ
makeConstructorsEncoder Options
options [Con]
constructors
    Info
other -> do
      forall (m :: * -> *). Quasi m => Bool -> String -> m ()
qReport Bool
True (String
"can only create encoders for an ADT, got: " forall a. Semigroup a => a -> a -> a
<> forall a b. (Show a, StringConv String b) => a -> b
show Info
other)
      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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Con -> Q Name
nameOf Con
c
  let encoderParameters :: [Q Pat]
encoderParameters = (\(Type
t, Integer
n) -> forall (m :: * -> *). Quote m => m Pat -> m Type -> m Pat
sigP (forall (m :: * -> *). Quote m => Name -> m Pat
varP (String -> Name
mkName forall a b. (a -> b) -> a -> b
$ String
"e" forall a. Semigroup a => a -> a -> a
<> forall a b. (Show a, StringConv String b) => a -> b
show Integer
n)) (forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT (forall (m :: * -> *). Quote m => Name -> m Type
conT forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
"Encoder") (forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
t))) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a b. [a] -> [b] -> [(a, b)]
zip Cxt
types [Integer
0 ..]
  let params :: Q Pat
params = forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP (String -> Name
mkName forall a b. (a -> b) -> a -> b
$ forall a b. (Show a, StringConv String b) => a -> b
show Name
cName) forall a b. (a -> b) -> a -> b
$ (\(Type
_, Integer
n) -> forall (m :: * -> *). Quote m => Name -> m Pat
varP (String -> Name
mkName forall a b. (a -> b) -> a -> b
$ String
"a" forall a. Semigroup a => a -> a -> a
<> forall a b. (Show a, StringConv String b) => a -> b
show Integer
n)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a b. [a] -> [b] -> [(a, b)]
zip Cxt
types [Integer
0 ..]
  let values :: [ExpQ]
values = (\(Type
_, Integer
n) -> forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (forall (m :: * -> *). Quote m => Name -> m Exp
varE forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
"encode") (forall (m :: * -> *). Quote m => Name -> m Exp
varE (String -> Name
mkName forall a b. (a -> b) -> a -> b
$ String
"e" forall a. Semigroup a => a -> a -> a
<> forall a b. (Show a, StringConv String b) => a -> b
show Integer
n))) (forall (m :: * -> *). Quote m => Name -> m Exp
varE (String -> Name
mkName forall a b. (a -> b) -> a -> b
$ String
"a" forall a. Semigroup a => a -> a -> a
<> forall a b. (Show a, StringConv String b) => a -> b
show Integer
n))) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a b. [a] -> [b] -> [(a, b)]
zip Cxt
types [Integer
0 ..]
  let encoded :: ExpQ
encoded = forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (forall (m :: * -> *). Quote m => Name -> m Exp
conE (String -> Name
mkName String
"ObjectArray")) (forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (forall (m :: * -> *). Quote m => Name -> m Exp
varE (String -> Name
mkName String
"Data.Vector.fromList")) (forall (m :: * -> *). Quote m => [m Exp] -> m Exp
listE [ExpQ]
values))
  forall (m :: * -> *). Quote m => [m Pat] -> m Exp -> m Exp
lamE [Q Pat]
encoderParameters (forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (forall (m :: * -> *). Quote m => Name -> m Exp
conE (String -> Name
mkName String
"Encoder")) (forall (m :: * -> *). Quote m => [m Pat] -> m Exp -> m Exp
lamE [Q Pat
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 <- forall a. Eq a => [a] -> [a]
nub forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. Monad m => m (m a) -> m a
join forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 :: [Q Pat]
encoderParameters = (\(Type
t, Integer
n) -> forall (m :: * -> *). Quote m => m Pat -> m Type -> m Pat
sigP (forall (m :: * -> *). Quote m => Name -> m Pat
varP (String -> Name
mkName forall a b. (a -> b) -> a -> b
$ String
"e" forall a. Semigroup a => a -> a -> a
<> forall a b. (Show a, StringConv String b) => a -> b
show Integer
n)) (forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT (forall (m :: * -> *). Quote m => Name -> m Type
conT forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
"Encoder") (forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
t))) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a b. [a] -> [b] -> [(a, b)]
zip Cxt
types [Integer
0 ..]
  [Match]
matchClauses <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for (forall a b. [a] -> [b] -> [(a, b)]
zip [Con]
cs [Integer
0 ..]) (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall a b. (a -> b) -> a -> b
$ Options -> Cxt -> Con -> Integer -> MatchQ
makeMatchClause Options
options Cxt
types)
  forall (m :: * -> *). Quote m => [m Pat] -> m Exp -> m Exp
lamE [Q Pat]
encoderParameters (forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (forall (m :: * -> *). Quote m => Name -> m Exp
conE (String -> Name
mkName String
"Encoder")) (forall (m :: * -> *). Quote m => [m Match] -> m Exp
lamCaseE (forall (f :: * -> *) a. Applicative f => a -> f a
pure 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 -> MatchQ
makeMatchClause Options
options Cxt
allTypes Con
c Integer
constructorIndex = do
  Cxt
ts <- Con -> Q Cxt
typesOf Con
c
  [(Type, Int)]
constructorTypes <- Cxt -> Cxt -> Q [(Type, Int)]
indexConstructorTypes Cxt
allTypes Cxt
ts
  Name
cName <- Options -> Name -> Name
makeName Options
options forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Con -> Q Name
nameOf Con
c
  let params :: Q Pat
params = forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP (String -> Name
mkName forall a b. (a -> b) -> a -> b
$ forall a b. (Show a, StringConv String b) => a -> b
show Name
cName) forall a b. (a -> b) -> a -> b
$ (\(Type
_, Int
n) -> forall (m :: * -> *). Quote m => Name -> m Pat
varP (String -> Name
mkName forall a b. (a -> b) -> a -> b
$ String
"a" forall a. Semigroup a => a -> a -> a
<> forall a b. (Show a, StringConv String b) => a -> b
show Int
n)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Type, Int)]
constructorTypes
  let values :: [ExpQ]
values = (\(Type
_, Int
n) -> forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (forall (m :: * -> *). Quote m => Name -> m Exp
varE forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
"encode") (forall (m :: * -> *). Quote m => Name -> m Exp
varE (String -> Name
mkName forall a b. (a -> b) -> a -> b
$ String
"e" forall a. Semigroup a => a -> a -> a
<> forall a b. (Show a, StringConv String b) => a -> b
show Int
n))) (forall (m :: * -> *). Quote m => Name -> m Exp
varE (String -> Name
mkName forall a b. (a -> b) -> a -> b
$ String
"a" forall a. Semigroup a => a -> a -> a
<> forall a b. (Show a, StringConv String b) => a -> b
show Int
n))) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Type, Int)]
constructorTypes
  let index :: ExpQ
index = forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (forall (m :: * -> *). Quote m => Name -> m Exp
conE forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
"ObjectInt") (forall (m :: * -> *). Quote m => Lit -> m Exp
litE (Integer -> Lit
integerL Integer
constructorIndex))
  let encoded :: ExpQ
encoded = forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (forall (m :: * -> *). Quote m => Name -> m Exp
conE (String -> Name
mkName String
"ObjectArray")) (forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (forall (m :: * -> *). Quote m => Name -> m Exp
varE (String -> Name
mkName String
"Data.Vector.fromList")) (forall (m :: * -> *). Quote m => [m Exp] -> m Exp
listE forall a b. (a -> b) -> a -> b
$ ExpQ
index forall a. a -> [a] -> [a]
: [ExpQ]
values))
  forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Match
match Q Pat
params (forall (m :: * -> *). Quote m => m Exp -> m Body
normalB ExpQ
encoded) []