{-# 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 forall a. Ord a => a -> a -> Bool
< Int
2 = 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 <- forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
tupSize (forall (m :: * -> *). Quote m => String -> m Name
newName String
"x")
    [Type]
context <- 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 (forall a. Int -> a -> [a]
replicate Int
tupSize forall a. Maybe a
Nothing)
        go :: m Exp -> p -> m Exp
go m Exp
b p
_a = do
          [e|$(b) <*> column decodeField|]

    Exp
instanceBodyExp <- forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' forall {m :: * -> *} {p}. Quote m => m Exp -> p -> m Exp
go [e|$(pure tupSection) <$> column decodeField|] (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) []]
    forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Overlap -> [Type] -> Type -> [Dec] -> Dec
InstanceD forall a. Maybe a
Nothing [Type]
context Type
instanceHead [Dec
instanceBody])