{-# 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 a. String -> Q a
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
forall (m :: * -> *). Quote m => String -> m 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)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (\Name
x -> [t|$(Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT (String -> Name
mkName String
"DecodeField")) $(Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
varT Name
x)|]) [Name]
tyVars
    Type
instanceHead <- [t|$(Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT (String -> Name
mkName String
"DecodeRow")) $(Type -> Q Type
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Type -> Q Type) -> Type -> Q Type
forall a b. (a -> b) -> a -> b
$ (Type -> Type -> Type) -> Type -> [Type] -> Type
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Type -> Type -> Type
AppT (Int -> Type
TupleT Int
tupSize) ((Name -> Type) -> [Name] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Type
VarT [Name]
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 :: m Exp -> p -> m Exp
go m Exp
b p
_a = do
          [e|$(m Exp
b) <*> column decodeField|]

    Exp
instanceBodyExp <- (Q Exp -> Name -> Q Exp) -> Q Exp -> [Name] -> Q Exp
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Q Exp -> Name -> Q Exp
forall {m :: * -> *} {p}. Quote m => m Exp -> p -> m Exp
go [e|$(Exp -> Q Exp
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Exp
tupSection) <$> column decodeField|] (Int -> [Name] -> [Name]
forall a. Int -> [a] -> [a]
drop Int
1 [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 a. a -> Q a
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])