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 (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      [Con
a] -> Con -> Q Con
forall (m :: * -> *) a. Monad m => a -> m a
return Con
a
      [Con]
x -> String -> Q Con
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q Con) -> String -> Q Con
forall a b. (a -> b) -> a -> b
$ String
"expected exactly 1 data constructor, but " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show ([Con] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Con]
x) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" 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 $(return $ ConT t) where
           fromRow = $(fieldsQ cname cargs)|]
  where
    fieldsQ :: Name -> t -> Q Exp
fieldsQ Name
cname t
cargs = do
        Exp
fld <- [| field |]
        Exp
fmp <- [| (<$>) |]
        Exp
fap <- [| (<*>) |]
        Exp -> Q Exp
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> Q Exp) -> Exp -> Q 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
_ = String -> Exp
forall a. HasCallStack => String -> a
error String
"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 (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      [Con
a] -> Con -> Q Con
forall (m :: * -> *) a. Monad m => a -> m a
return Con
a
      [Con]
x -> String -> Q Con
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q Con) -> String -> Q Con
forall a b. (a -> b) -> a -> b
$ String
"expected exactly 1 data constructor, but " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show ([Con] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Con]
x) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" 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)
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
$ String -> Q Name
newName String
"a"
    [d|instance ToRow $(return $ ConT t) where
#if MIN_VERSION_template_haskell(2,18,0)
           toRow $(return $ ConP cname [] $ map VarP cvars) = $(toFields cvars)|]
#else
           toRow $(return $ ConP cname $ map VarP cvars) = $(toFields cvars)|]
#endif
  where
    toFields :: [Name] -> Q Exp
toFields [Name]
v = do
        Name
tof <- String -> Q Name
lookupVNameErr String
"toField"
        Exp -> Q Exp
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