-- | Template Haskell macros to generate tuple instances for FromSql & ToSql

module Preql.Wire.Tuples where

import Preql.QuasiQuoter.Common (alphabet)

import Language.Haskell.TH

deriveToSqlTuple :: Int -> Q [Dec]
deriveToSqlTuple :: Int -> Q [Dec]
deriveToSqlTuple Int
size = do
    [Name]
names <- (String -> Q Name) -> [String] -> Q [Name]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse String -> Q Name
newName (Int -> [String] -> [String]
forall a. Int -> [a] -> [a]
take Int
size [String]
alphabet)
    Just Name
classN <- String -> Q (Maybe Name)
lookupTypeName String
"ToSql"
    Just Name
fieldN <- String -> Q (Maybe Name)
lookupTypeName String
"ToSqlField"
    Just Name
toSql <- String -> Q (Maybe Name)
lookupValueName String
"toSql"
    Just Name
runFieldEncoder <- String -> Q (Maybe Name)
lookupValueName String
"runFieldEncoder"
    Just Name
toSqlField <- String -> Q (Maybe Name)
lookupValueName String
"toSqlField"
    let
        context :: [Type]
context = [ Name -> Type
ConT Name
fieldN Type -> Type -> Type
`AppT` Name -> Type
VarT Name
n | Name
n <- [Name]
names ]
        instanceHead :: Type
instanceHead = Name -> Type
ConT Name
classN Type -> Type -> Type
`AppT` (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
size) ((Name -> Type) -> [Name] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Type
VarT [Name]
names)
        method :: Dec
method = Name -> [Clause] -> Dec
FunD Name
toSql
            [[Pat] -> Body -> [Dec] -> Clause
Clause
                [[Pat] -> Pat
TupP ((Name -> Pat) -> [Name] -> [Pat]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Pat
VarP [Name]
names)]
                (Exp -> Body
NormalB ([Exp] -> Exp
ListE [ Name -> Exp
VarE Name
runFieldEncoder Exp -> Exp -> Exp
`AppE` Name -> Exp
VarE Name
toSqlField Exp -> Exp -> Exp
`AppE` Name -> Exp
VarE Name
n | Name
n <- [Name]
names ]))
            []] -- no where clause on the toSql definition
    [Dec] -> Q [Dec]
forall (m :: * -> *) a. Monad m => a -> m a
return [Maybe Overlap -> [Type] -> Type -> [Dec] -> Dec
InstanceD Maybe Overlap
forall a. Maybe a
Nothing [Type]
context Type
instanceHead [Dec
method]]