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
deriveFromRow :: Name -> Q [Dec]
deriveFromRow t = do
con <- dataConstructors <$> reify t >>= \case
[a] -> return a
x -> fail $ "expected exactly 1 data constructor, but " ++ show (length x) ++ " got"
cname <- cName con
cargs <- cArgs con
[d|instance FromRow $(return $ ConT t) where
fromRow = $(fieldsQ cname cargs)|]
where
fieldsQ cname cargs = do
fld <- [| field |]
fmp <- [| (<$>) |]
fap <- [| (<*>) |]
return $ UInfixE (ConE cname) fmp (fapChain cargs fld fap)
fapChain 0 _ _ = error "there must be at least 1 field in constructor"
fapChain 1 fld _ = fld
fapChain n fld fap = UInfixE fld fap (fapChain (n-1) fld fap)
deriveToRow :: Name -> Q [Dec]
deriveToRow t = do
con <- dataConstructors <$> reify t >>= \case
[a] -> return a
x -> fail $ "expected exactly 1 data constructor, but " ++ show (length x) ++ " got"
cname <- cName con
cargs <- cArgs con
cvars <- sequence
$ replicate cargs
$ newName "a"
[d|instance ToRow $(return $ ConT t) where
toRow $(return $ ConP cname $ map VarP cvars) = $(toFields cvars)|]
where
toFields v = do
tof <- lookupVNameErr "toField"
return $ ListE $ map (\e -> AppE (VarE tof) (VarE e)) v