{-# LANGUAGE TemplateHaskell #-}

module Hasql.Interpolate.Internal.Decoder.TH
  ( genDecodeRowInstance,
  )
where

import Control.Monad
import Data.Foldable (foldl')
import Hasql.Decoders
import Language.Haskell.TH

-- | Generate a single 'Hasql.Interpolate.DecodeRow' instance for a
-- tuple of size @tupSize@
genDecodeRowInstance ::
  -- | tuple size
  Int ->
  Q Dec
genDecodeRowInstance :: Int -> Q Dec
genDecodeRowInstance Int
tupSize
  | Int
tupSize Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
2 = String -> Q Dec
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"this is just for tuples, must specify a tuple size of 2 or greater"
  | Bool
otherwise = do
    [Name]
tyVars <- Int -> Q Name -> Q [Name]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
tupSize (String -> Q Name
newName String
"x")
    [Type]
context <- (Name -> Q Type) -> [Name] -> Q [Type]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (\Name
x -> [t|$(conT (mkName "DecodeField")) $(varT x)|]) [Name]
tyVars
    Type
instanceHead <- [t|$(conT (mkName "DecodeRow")) $(pure $ foldl' AppT (TupleT tupSize) (map VarT tyVars))|]
    let tupSection :: Exp
tupSection = [Maybe Exp] -> Exp
TupE (Int -> Maybe Exp -> [Maybe Exp]
forall a. Int -> a -> [a]
replicate Int
tupSize Maybe Exp
forall a. Maybe a
Nothing)
        go :: ExpQ -> p -> ExpQ
go ExpQ
b p
_a = do
          [e|$(b) <*> column decodeField|]

    Exp
instanceBodyExp <- (ExpQ -> Name -> ExpQ) -> ExpQ -> [Name] -> ExpQ
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' ExpQ -> Name -> ExpQ
forall p. ExpQ -> p -> ExpQ
go [e|$(pure tupSection) <$> column decodeField|] ([Name] -> [Name]
forall a. [a] -> [a]
tail [Name]
tyVars)
    let instanceBody :: Dec
instanceBody = Name -> [Clause] -> Dec
FunD (String -> Name
mkName String
"decodeRow") [[Pat] -> Body -> [Dec] -> Clause
Clause [] (Exp -> Body
NormalB Exp
instanceBodyExp) []]
    Dec -> Q Dec
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Overlap -> [Type] -> Type -> [Dec] -> Dec
InstanceD Maybe Overlap
forall a. Maybe a
Nothing [Type]
context Type
instanceHead [Dec
instanceBody])