{-# 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
#if MIN_VERSION_aeson(2,0,0)
import qualified Data.Aeson.Key as Aeson.Key
import qualified Data.Aeson.KeyMap as Aeson.KeyMap
#else
import qualified Data.HashMap.Lazy as HM
#endif
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)]
#if MIN_VERSION_aeson(2,0,0)
              [| (Aeson.Object . Aeson.KeyMap.fromList)
                 $(listE $ map (\ (fName, varName, oName) -> [| (Aeson.Key.fromText $(varE fName), $(varE oName) $(varE varName)) |])
#else
              [| (Aeson.Object . HM.fromList)
                 $(listE $ map (\ (fName, varName, oName) -> [| ($(varE fName), $(varE oName) $(varE varName)) |])
#endif
                               (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) []
              ]
          ]
        ]