{-# LANGUAGE CPP #-}
module Composite.Aeson.Formats.InternalTH
  ( makeTupleDefaults, makeTupleFormats, makeNamedTupleFormats
  ) where

import Composite.Aeson.Base (JsonFormat(JsonFormat), JsonProfunctor(JsonProfunctor))
import Control.Monad.Except (throwError)
import qualified Data.Aeson as Aeson
import qualified Data.Aeson.Key as Aeson.Key
import qualified Data.Aeson.KeyMap as Aeson.KeyMap
import qualified Data.Aeson.BetterErrors as ABE
import Data.List (foldl')
import Data.Text (Text)
import qualified Data.Vector as V
import Language.Haskell.TH
  ( Name, mkName, newName, tupleDataName
  , Q
  , cxt, clause, normalB
  , Dec, funD, instanceD, sigD, valD
  , Exp(AppE, ConE, VarE), appE, doE, lamE, listE, varE
  , conP, varP, wildP
  , bindS, noBindS
  , Type(AppT, ArrowT, ConT, ForallT, TupleT, VarT), appT, conT, varT
  , TyVarBndr(PlainTV)
#if MIN_VERSION_template_haskell(2,17,0)
  , Specificity(SpecifiedSpec)
#endif
  )
import Language.Haskell.TH.Syntax (lift)

djfClassName :: Name
djfClassName :: Name
djfClassName = String -> Name
mkName String
"Composite.Aeson.Formats.Default.DefaultJsonFormat"

djfFunName :: Name
djfFunName :: Name
djfFunName = String -> Name
mkName String
"Composite.Aeson.Formats.Default.defaultJsonFormat"

-- |Splice which inserts the @DefaultJsonFormat@ instances for tuples.
makeTupleDefaults :: Q [Dec]
makeTupleDefaults :: Q [Dec]
makeTupleDefaults = (Int -> Q Dec) -> [Int] -> Q [Dec]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Int -> Q Dec
makeTupleDefault [Int
2..Int
59]
  where
    makeTupleDefault :: Int -> Q Dec
makeTupleDefault Int
arity = do
      [Name]
names <- (Int -> Q Name) -> [Int] -> Q [Name]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (String -> Q Name
newName (String -> Q Name) -> (Int -> String) -> Int -> Q Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
"a" String -> String -> String
forall a. [a] -> [a] -> [a]
++) (String -> String) -> (Int -> String) -> Int -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String
forall a. Show a => a -> String
show) [Int
1..Int
arity]
      let constraints :: [TypeQ]
constraints = (Name -> TypeQ) -> [Name] -> [TypeQ]
forall a b. (a -> b) -> [a] -> [b]
map (\ Name
n -> TypeQ -> TypeQ -> TypeQ
appT (Name -> TypeQ
conT Name
djfClassName) (Name -> TypeQ
varT Name
n)) [Name]
names
          instanceHead :: TypeQ
instanceHead = TypeQ -> TypeQ -> TypeQ
appT (Name -> TypeQ
conT Name
djfClassName) (Type -> TypeQ
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Type -> TypeQ) -> Type -> TypeQ
forall a b. (a -> b) -> a -> b
$ (Type -> Type -> Type) -> Type -> [Type] -> Type
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Type -> Type -> Type
AppT (Int -> Type
TupleT Int
arity) ((Name -> Type) -> [Name] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Type
VarT [Name]
names))
          implName :: Name
implName = String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ String
"Composite.Aeson.Formats.Provided.tuple" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
arity String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"JsonFormat"
      CxtQ -> TypeQ -> [Q Dec] -> Q Dec
instanceD ([TypeQ] -> CxtQ
cxt [TypeQ]
constraints) TypeQ
instanceHead
        [ Name -> [ClauseQ] -> Q Dec
funD (String -> Name
mkName String
"defaultJsonFormat")
          [ [PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause
              []
              (ExpQ -> BodyQ
normalB (Exp -> ExpQ
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp -> ExpQ) -> Exp -> ExpQ
forall a b. (a -> b) -> a -> b
$ (Exp -> Int -> Exp) -> Exp -> [Int] -> Exp
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\ Exp
lhs Int
_ -> Exp -> Exp -> Exp
AppE Exp
lhs (Name -> Exp
VarE Name
djfFunName)) (Name -> Exp
VarE Name
implName) [Int
1..Int
arity]))
              []
          ]
        ]

-- |Splice which inserts the @tupleNJsonFormat@ implementations for tuples.
makeTupleFormats :: Q [Dec]
makeTupleFormats :: Q [Dec]
makeTupleFormats = [[Dec]] -> [Dec]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Dec]] -> [Dec]) -> Q [[Dec]] -> Q [Dec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Int -> Q [Dec]) -> [Int] -> Q [[Dec]]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Int -> Q [Dec]
makeTupleFormat [Int
2..Int
59]
  where
    makeTupleFormat :: Int -> Q [Dec]
makeTupleFormat Int
arity = do
      [Name]
tyNames   <- (Int -> Q Name) -> [Int] -> Q [Name]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (String -> Q Name
newName (String -> Q Name) -> (Int -> String) -> Int -> Q Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
"t" String -> String -> String
forall a. [a] -> [a] -> [a]
++) (String -> String) -> (Int -> String) -> Int -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String
forall a. Show a => a -> String
show) [Int
1..Int
arity]
      [Name]
oNames    <- (Int -> Q Name) -> [Int] -> Q [Name]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (String -> Q Name
newName (String -> Q Name) -> (Int -> String) -> Int -> Q Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
"o" String -> String -> String
forall a. [a] -> [a] -> [a]
++) (String -> String) -> (Int -> String) -> Int -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String
forall a. Show a => a -> String
show) [Int
1..Int
arity]
      [Name]
iNames    <- (Int -> Q Name) -> [Int] -> Q [Name]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (String -> Q Name
newName (String -> Q Name) -> (Int -> String) -> Int -> Q Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
"i" String -> String -> String
forall a. [a] -> [a] -> [a]
++) (String -> String) -> (Int -> String) -> Int -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String
forall a. Show a => a -> String
show) [Int
1..Int
arity]
      Name
oTupName  <- String -> Q Name
newName String
"oTup"
      Name
iTupName  <- String -> Q Name
newName String
"iTup"
      [Name]
valNames  <- (Int -> Q Name) -> [Int] -> Q [Name]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (String -> Q Name
newName (String -> Q Name) -> (Int -> String) -> Int -> Q Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
"v" String -> String -> String
forall a. [a] -> [a] -> [a]
++) (String -> String) -> (Int -> String) -> Int -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String
forall a. Show a => a -> String
show) [Int
1..Int
arity]
      Name
tyErrName <- String -> Q Name
newName String
"e"

      let name :: Name
name = String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ String
"tuple" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
arity String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"JsonFormat"
          tupleType :: Type
tupleType = (Type -> Type -> Type) -> Type -> [Type] -> Type
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Type -> Type -> Type
AppT (Int -> Type
TupleT Int
arity) ((Name -> Type) -> [Name] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Type
VarT [Name]
tyNames)
          funType :: Type
funType =
            [TyVarBndr] -> [Type] -> Type -> Type
ForallT
#if MIN_VERSION_template_haskell(2,17,0)
              (PlainTV tyErrName SpecifiedSpec : map (flip PlainTV SpecifiedSpec) tyNames)
#else
              (Name -> TyVarBndr
PlainTV Name
tyErrName TyVarBndr -> [TyVarBndr] -> [TyVarBndr]
forall a. a -> [a] -> [a]
: (Name -> TyVarBndr) -> [Name] -> [TyVarBndr]
forall a b. (a -> b) -> [a] -> [b]
map Name -> TyVarBndr
PlainTV [Name]
tyNames)
#endif
              []
              ((Type -> Type -> Type) -> Type -> [Type] -> Type
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\ Type
tyName Type
rest -> Type
ArrowT Type -> Type -> Type
`AppT` (Name -> Type
ConT ''JsonFormat Type -> Type -> Type
`AppT` Name -> Type
VarT Name
tyErrName Type -> Type -> Type
`AppT` Type
tyName) Type -> Type -> Type
`AppT` Type
rest)
                     (Name -> Type
ConT ''JsonFormat Type -> Type -> Type
`AppT` Name -> Type
VarT Name
tyErrName Type -> Type -> Type
`AppT` Type
tupleType)
                     ((Name -> Type) -> [Name] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Type
VarT [Name]
tyNames))
          oTupImpl :: ExpQ
oTupImpl =
            [PatQ] -> ExpQ -> ExpQ
lamE
              [Name -> [PatQ] -> PatQ
conP (Int -> Name
tupleDataName Int
arity) ((Name -> PatQ) -> [Name] -> [PatQ]
forall a b. (a -> b) -> [a] -> [b]
map Name -> PatQ
varP [Name]
valNames)]
              [| (Aeson.Array . V.fromList) $(listE $ map (\ (varName, oName) -> appE (varE oName) (varE varName)) (zip valNames oNames)) |]
          iTupImpl :: ExpQ
iTupImpl =
            [StmtQ] -> ExpQ
doE
              ([StmtQ] -> ExpQ) -> [StmtQ] -> ExpQ
forall a b. (a -> b) -> a -> b
$  [ PatQ -> ExpQ -> StmtQ
bindS PatQ
wildP [|
                     ABE.withArray Right >>= \ a ->
                       if V.length a == $(lift arity)
                         then pure ()
                         else throwError $ ABE.InvalidJSON $  $(lift $ "expected an array of exactly " <> show arity <> " elements")
                     |]
                 ]
              [StmtQ] -> [StmtQ] -> [StmtQ]
forall a. [a] -> [a] -> [a]
++ ((Int, Name, Name) -> StmtQ) -> [(Int, Name, Name)] -> [StmtQ]
forall a b. (a -> b) -> [a] -> [b]
map ( \ (Int
n, Name
valName, Name
iName) ->
                       PatQ -> ExpQ -> StmtQ
bindS (Name -> PatQ
varP Name
valName) [| ABE.nth $(lift (n :: Int)) $(varE iName) |] )
                     ([Int] -> [Name] -> [Name] -> [(Int, Name, Name)]
forall a b c. [a] -> [b] -> [c] -> [(a, b, c)]
zip3 [Int
0..] [Name]
valNames [Name]
iNames)
              [StmtQ] -> [StmtQ] -> [StmtQ]
forall a. [a] -> [a] -> [a]
++ [ ExpQ -> StmtQ
noBindS (ExpQ -> ExpQ -> ExpQ
appE (Name -> ExpQ
varE 'pure) (Exp -> ExpQ
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp -> ExpQ) -> Exp -> ExpQ
forall a b. (a -> b) -> a -> b
$ (Exp -> Exp -> Exp) -> Exp -> [Exp] -> Exp
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Exp -> Exp -> Exp
AppE (Name -> Exp
ConE (Int -> Name
tupleDataName Int
arity)) ((Name -> Exp) -> [Name] -> [Exp]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Exp
VarE [Name]
valNames))) ]
      [Q Dec] -> Q [Dec]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence
        [ Name -> TypeQ -> Q Dec
sigD Name
name (Type -> TypeQ
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
funType)
        , Name -> [ClauseQ] -> Q Dec
funD Name
name
          [ [PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause
              (((Name, Name) -> PatQ) -> [(Name, Name)] -> [PatQ]
forall a b. (a -> b) -> [a] -> [b]
map (\ (Name
oName, Name
iName) -> Name -> [PatQ] -> PatQ
conP 'JsonFormat [Name -> [PatQ] -> PatQ
conP 'JsonProfunctor [Name -> PatQ
varP Name
oName, Name -> PatQ
varP Name
iName]]) ([Name] -> [Name] -> [(Name, Name)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Name]
oNames [Name]
iNames))
              (ExpQ -> BodyQ
normalB [| JsonFormat (JsonProfunctor $(varE oTupName) $(varE iTupName)) |])
              [ PatQ -> BodyQ -> [Q Dec] -> Q Dec
valD (Name -> PatQ
varP Name
oTupName) (ExpQ -> BodyQ
normalB ExpQ
oTupImpl) []
              , PatQ -> BodyQ -> [Q Dec] -> Q Dec
valD (Name -> PatQ
varP Name
iTupName) (ExpQ -> BodyQ
normalB ExpQ
iTupImpl) []
              ]
          ]
        ]

-- |Splice which inserts the @namedTupleNJsonFormat@ implementations for tuples.
makeNamedTupleFormats :: Q [Dec]
makeNamedTupleFormats :: Q [Dec]
makeNamedTupleFormats = [[Dec]] -> [Dec]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Dec]] -> [Dec]) -> Q [[Dec]] -> Q [Dec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Int -> Q [Dec]) -> [Int] -> Q [[Dec]]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Int -> Q [Dec]
makeNamedTupleFormat [Int
2..Int
59]
  where
    makeNamedTupleFormat :: Int -> Q [Dec]
makeNamedTupleFormat Int
arity = do
      [Name]
tyNames   <- (Int -> Q Name) -> [Int] -> Q [Name]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (String -> Q Name
newName (String -> Q Name) -> (Int -> String) -> Int -> Q Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
"t" String -> String -> String
forall a. [a] -> [a] -> [a]
++) (String -> String) -> (Int -> String) -> Int -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String
forall a. Show a => a -> String
show) [Int
1..Int
arity]
      [Name]
fNames    <- (Int -> Q Name) -> [Int] -> Q [Name]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (String -> Q Name
newName (String -> Q Name) -> (Int -> String) -> Int -> Q Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
"f" String -> String -> String
forall a. [a] -> [a] -> [a]
++) (String -> String) -> (Int -> String) -> Int -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String
forall a. Show a => a -> String
show) [Int
1..Int
arity]
      [Name]
oNames    <- (Int -> Q Name) -> [Int] -> Q [Name]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (String -> Q Name
newName (String -> Q Name) -> (Int -> String) -> Int -> Q Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
"o" String -> String -> String
forall a. [a] -> [a] -> [a]
++) (String -> String) -> (Int -> String) -> Int -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String
forall a. Show a => a -> String
show) [Int
1..Int
arity]
      [Name]
iNames    <- (Int -> Q Name) -> [Int] -> Q [Name]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (String -> Q Name
newName (String -> Q Name) -> (Int -> String) -> Int -> Q Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
"i" String -> String -> String
forall a. [a] -> [a] -> [a]
++) (String -> String) -> (Int -> String) -> Int -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String
forall a. Show a => a -> String
show) [Int
1..Int
arity]
      Name
oTupName  <- String -> Q Name
newName String
"oTup"
      Name
iTupName  <- String -> Q Name
newName String
"iTup"
      [Name]
valNames  <- (Int -> Q Name) -> [Int] -> Q [Name]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (String -> Q Name
newName (String -> Q Name) -> (Int -> String) -> Int -> Q Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
"v" String -> String -> String
forall a. [a] -> [a] -> [a]
++) (String -> String) -> (Int -> String) -> Int -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String
forall a. Show a => a -> String
show) [Int
1..Int
arity]
      Name
tyErrName <- String -> Q Name
newName String
"e"

      let name :: Name
name = String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ String
"namedTuple" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
arity String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"JsonFormat"
          tupleType :: Type
tupleType = (Type -> Type -> Type) -> Type -> [Type] -> Type
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Type -> Type -> Type
AppT (Int -> Type
TupleT Int
arity) ((Name -> Type) -> [Name] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Type
VarT [Name]
tyNames)
          funType :: Type
funType =
            [TyVarBndr] -> [Type] -> Type -> Type
ForallT
#if MIN_VERSION_template_haskell(2,17,0)
              (PlainTV tyErrName SpecifiedSpec : map (flip PlainTV SpecifiedSpec) tyNames)
#else
              (Name -> TyVarBndr
PlainTV Name
tyErrName TyVarBndr -> [TyVarBndr] -> [TyVarBndr]
forall a. a -> [a] -> [a]
: (Name -> TyVarBndr) -> [Name] -> [TyVarBndr]
forall a b. (a -> b) -> [a] -> [b]
map Name -> TyVarBndr
PlainTV [Name]
tyNames)
#endif
              []
              ((Type -> Type -> Type) -> Type -> [Type] -> Type
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\ Type
tyName Type
rest -> Type
ArrowT Type -> Type -> Type
`AppT` Name -> Type
ConT ''Text Type -> Type -> Type
`AppT` (Type
ArrowT Type -> Type -> Type
`AppT` (Name -> Type
ConT ''JsonFormat Type -> Type -> Type
`AppT` Name -> Type
VarT Name
tyErrName Type -> Type -> Type
`AppT` Type
tyName) Type -> Type -> Type
`AppT` Type
rest))
                     (Name -> Type
ConT ''JsonFormat Type -> Type -> Type
`AppT` Name -> Type
VarT Name
tyErrName Type -> Type -> Type
`AppT` Type
tupleType)
                     ((Name -> Type) -> [Name] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Type
VarT [Name]
tyNames))
          oTupImpl :: ExpQ
oTupImpl =
            [PatQ] -> ExpQ -> ExpQ
lamE
              [Name -> [PatQ] -> PatQ
conP (Int -> Name
tupleDataName Int
arity) ((Name -> PatQ) -> [Name] -> [PatQ]
forall a b. (a -> b) -> [a] -> [b]
map Name -> PatQ
varP [Name]
valNames)]
              [| (Aeson.Object . Aeson.KeyMap.fromList)
                 $(listE $ map (\ (fName, varName, oName) -> [| (Aeson.Key.fromText $(varE fName), $(varE oName) $(varE varName)) |])
                               (zip3 fNames valNames oNames)) |]
          iTupImpl :: ExpQ
iTupImpl =
            [StmtQ] -> ExpQ
doE
              ([StmtQ] -> ExpQ) -> [StmtQ] -> ExpQ
forall a b. (a -> b) -> a -> b
$  ((Name, Name, Name) -> StmtQ) -> [(Name, Name, Name)] -> [StmtQ]
forall a b. (a -> b) -> [a] -> [b]
map ( \ (Name
fName, Name
valName, Name
iName) ->
                       PatQ -> ExpQ -> StmtQ
bindS (Name -> PatQ
varP Name
valName) [| ABE.key $(varE fName) $(varE iName) |] )
                     ([Name] -> [Name] -> [Name] -> [(Name, Name, Name)]
forall a b c. [a] -> [b] -> [c] -> [(a, b, c)]
zip3 [Name]
fNames [Name]
valNames [Name]
iNames)
              [StmtQ] -> [StmtQ] -> [StmtQ]
forall a. [a] -> [a] -> [a]
++ [ ExpQ -> StmtQ
noBindS (ExpQ -> ExpQ -> ExpQ
appE (Name -> ExpQ
varE 'pure) (Exp -> ExpQ
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp -> ExpQ) -> Exp -> ExpQ
forall a b. (a -> b) -> a -> b
$ (Exp -> Exp -> Exp) -> Exp -> [Exp] -> Exp
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Exp -> Exp -> Exp
AppE (Name -> Exp
ConE (Int -> Name
tupleDataName Int
arity)) ((Name -> Exp) -> [Name] -> [Exp]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Exp
VarE [Name]
valNames))) ]
      [Q Dec] -> Q [Dec]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence
        [ Name -> TypeQ -> Q Dec
sigD Name
name (Type -> TypeQ
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
funType)
        , Name -> [ClauseQ] -> Q Dec
funD Name
name
          [ [PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause
              (((Name, Name, Name) -> [PatQ] -> [PatQ])
-> [PatQ] -> [(Name, Name, Name)] -> [PatQ]
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\ (Name
fName, Name
oName, Name
iName) [PatQ]
rest -> Name -> PatQ
varP Name
fName PatQ -> [PatQ] -> [PatQ]
forall a. a -> [a] -> [a]
: Name -> [PatQ] -> PatQ
conP 'JsonFormat [Name -> [PatQ] -> PatQ
conP 'JsonProfunctor [Name -> PatQ
varP Name
oName, Name -> PatQ
varP Name
iName]] PatQ -> [PatQ] -> [PatQ]
forall a. a -> [a] -> [a]
: [PatQ]
rest)
                     []
                     ([Name] -> [Name] -> [Name] -> [(Name, Name, Name)]
forall a b c. [a] -> [b] -> [c] -> [(a, b, c)]
zip3 [Name]
fNames [Name]
oNames [Name]
iNames))
              (ExpQ -> BodyQ
normalB [| JsonFormat (JsonProfunctor $(varE oTupName) $(varE iTupName)) |])
              [ PatQ -> BodyQ -> [Q Dec] -> Q Dec
valD (Name -> PatQ
varP Name
oTupName) (ExpQ -> BodyQ
normalB ExpQ
oTupImpl) []
              , PatQ -> BodyQ -> [Q Dec] -> Q Dec
valD (Name -> PatQ
varP Name
iTupName) (ExpQ -> BodyQ
normalB ExpQ
iTupImpl) []
              ]
          ]
        ]