module Database.PostgreSQL.Query.TH.Row
  ( deriveFromRow
  , deriveToRow
  ) where

import Database.PostgreSQL.Query.TH.Common
import Database.PostgreSQL.Simple.FromRow ( FromRow(..), field )
import Database.PostgreSQL.Simple.ToRow ( ToRow(..) )
import Language.Haskell.TH

{-| Derive 'FromRow' instance. i.e. you have type like that

@
data Entity = Entity
              { eField :: Text
              , eField2 :: Int
              , efield3 :: Bool }
@

then 'deriveFromRow' will generate this instance:
instance FromRow Entity where

@
instance FromRow Entity where
    fromRow = Entity
              \<$> field
              \<*> field
              \<*> field
@

Datatype must have just one constructor with arbitrary count of fields
-}

deriveFromRow :: Name -> Q [Dec]
deriveFromRow :: Name -> Q [Dec]
deriveFromRow Name
t = do
    Con
con <- Info -> [Con]
dataConstructors (Info -> [Con]) -> Q Info -> Q [Con]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> Q Info
reify Name
t Q [Con] -> ([Con] -> Q Con) -> Q Con
forall a b. Q a -> (a -> Q b) -> Q b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      [Con
a] -> Con -> Q Con
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Con
a
      [Con]
x -> [Char] -> Q Con
forall a. [Char] -> Q a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char] -> Q Con) -> [Char] -> Q Con
forall a b. (a -> b) -> a -> b
$ [Char]
"expected exactly 1 data constructor, but " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show ([Con] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Con]
x) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" got"
    Name
cname <- Con -> Q Name
forall (m :: * -> *). Monad m => Con -> m Name
cName Con
con
    Int
cargs <- Con -> Q Int
forall (m :: * -> *). Monad m => Con -> m Int
cArgs Con
con
    [d|instance FromRow $(Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> Q Type) -> Type -> Q Type
forall a b. (a -> b) -> a -> b
$ Name -> Type
ConT Name
t) where
           fromRow = $(Name -> Int -> Q Exp
forall {m :: * -> *} {t}.
(Quote m, Eq t, Num t) =>
Name -> t -> m Exp
fieldsQ Name
cname Int
cargs)|]
  where
    fieldsQ :: Name -> t -> m Exp
fieldsQ Name
cname t
cargs = do
        Exp
fld <- [| field |]
        Exp
fmp <- [| (<$>) |]
        Exp
fap <- [| (<*>) |]
        Exp -> m Exp
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> m Exp) -> Exp -> m Exp
forall a b. (a -> b) -> a -> b
$ Exp -> Exp -> Exp -> Exp
UInfixE (Name -> Exp
ConE Name
cname) Exp
fmp (t -> Exp -> Exp -> Exp
forall {t}. (Eq t, Num t) => t -> Exp -> Exp -> Exp
fapChain t
cargs Exp
fld Exp
fap)

    fapChain :: t -> Exp -> Exp -> Exp
fapChain t
0 Exp
_ Exp
_ = [Char] -> Exp
forall a. HasCallStack => [Char] -> a
error [Char]
"there must be at least 1 field in constructor"
    fapChain t
1 Exp
fld Exp
_ = Exp
fld
    fapChain t
n Exp
fld Exp
fap = Exp -> Exp -> Exp -> Exp
UInfixE Exp
fld Exp
fap (t -> Exp -> Exp -> Exp
fapChain (t
nt -> t -> t
forall a. Num a => a -> a -> a
-t
1) Exp
fld Exp
fap)

{-| derives 'ToRow' instance for datatype like

@
data Entity = Entity
              { eField :: Text
              , eField2 :: Int
              , efield3 :: Bool }
@

it will derive instance like that:

@
instance ToRow Entity where
     toRow (Entity e1 e2 e3) =
         [ toField e1
         , toField e2
         , toField e3 ]
@
-}

deriveToRow :: Name -> Q [Dec]
deriveToRow :: Name -> Q [Dec]
deriveToRow Name
t = do
    Con
con <- Info -> [Con]
dataConstructors (Info -> [Con]) -> Q Info -> Q [Con]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> Q Info
reify Name
t Q [Con] -> ([Con] -> Q Con) -> Q Con
forall a b. Q a -> (a -> Q b) -> Q b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      [Con
a] -> Con -> Q Con
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Con
a
      [Con]
x -> [Char] -> Q Con
forall a. [Char] -> Q a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char] -> Q Con) -> [Char] -> Q Con
forall a b. (a -> b) -> a -> b
$ [Char]
"expected exactly 1 data constructor, but " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show ([Con] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Con]
x) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" got"
    Name
cname <- Con -> Q Name
forall (m :: * -> *). Monad m => Con -> m Name
cName Con
con
    Int
cargs <- Con -> Q Int
forall (m :: * -> *). Monad m => Con -> m Int
cArgs Con
con
    [Name]
cvars <- [Q Name] -> Q [Name]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence
             ([Q Name] -> Q [Name]) -> [Q Name] -> Q [Name]
forall a b. (a -> b) -> a -> b
$ Int -> Q Name -> [Q Name]
forall a. Int -> a -> [a]
replicate Int
cargs
             (Q Name -> [Q Name]) -> Q Name -> [Q Name]
forall a b. (a -> b) -> a -> b
$ [Char] -> Q Name
forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"a"
    [d|instance ToRow $(Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> Q Type) -> Type -> Q Type
forall a b. (a -> b) -> a -> b
$ Name -> Type
ConT Name
t) where
#if MIN_VERSION_template_haskell(2,18,0)
           toRow $(Pat -> Q Pat
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Pat -> Q Pat) -> Pat -> Q Pat
forall a b. (a -> b) -> a -> b
$ Name -> [Type] -> [Pat] -> Pat
ConP Name
cname [] ([Pat] -> Pat) -> [Pat] -> Pat
forall a b. (a -> b) -> a -> b
$ (Name -> Pat) -> [Name] -> [Pat]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Pat
VarP [Name]
cvars) = $([Name] -> Q Exp
toFields [Name]
cvars)|]
#else
           toRow $(return $ ConP cname $ map VarP cvars) = $(toFields cvars)|]
#endif
  where
    toFields :: [Name] -> Q Exp
toFields [Name]
v = do
        Name
tof <- [Char] -> Q Name
lookupVNameErr [Char]
"toField"
        Exp -> Q Exp
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> Q Exp) -> Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ [Exp] -> Exp
ListE ([Exp] -> Exp) -> [Exp] -> Exp
forall a b. (a -> b) -> a -> b
$ (Name -> Exp) -> [Name] -> [Exp]
forall a b. (a -> b) -> [a] -> [b]
map (\Name
e -> Exp -> Exp -> Exp
AppE (Name -> Exp
VarE Name
tof) (Name -> Exp
VarE Name
e)) [Name]
v