module Database.PostgreSQL.Simple.SOP (gfromRow, gtoRow, gselectFrom, ginsertInto, ginsertManyInto, HasFieldNames, fieldNames) where
import Generics.SOP
import Control.Applicative
import Data.Monoid ((<>))
import Data.List (intercalate)
import Data.String (fromString)
import Database.PostgreSQL.Simple
import Database.PostgreSQL.Simple.FromRow
import Database.PostgreSQL.Simple.FromField
import Database.PostgreSQL.Simple.ToField
gfromRow
:: (All FromField xs, Code a ~ '[xs], SingI xs, Generic a)
=> RowParser a
gfromRow = to . SOP . Z <$> hsequence (hcpure fromFieldp field)
where fromFieldp = Proxy :: Proxy FromField
gtoRow :: (Generic a, Code a ~ '[xs], All ToField xs, SingI xs) => a -> [Action]
gtoRow a =
case from a of
SOP (Z xs) -> hcollapse (hcliftA toFieldP (K . toField . unI) xs)
where toFieldP = Proxy :: Proxy ToField
fNms :: NP ConstructorInfo a -> [String]
fNms ((Record _ fs) :* _) = fNmsRec fs
fNmsRec :: NP FieldInfo a -> [String]
fNmsRec Nil = []
fNmsRec (FieldInfo nm :* rest) = nm : fNmsRec rest
class HasFieldNames a where
fieldNames :: Proxy a -> [String]
default fieldNames :: (Generic a, HasDatatypeInfo a) => Proxy a -> [String]
fieldNames p = case datatypeInfo p of
ADT _ _ cs -> fNms cs
Newtype _ _ c -> fNms $ c :* Nil
gselectFrom :: forall r q. (ToRow q, FromRow r, Generic r, HasFieldNames r) => Connection -> Query -> q -> IO [r]
gselectFrom conn q1 args = do
let fullq = "select " <> (fromString $ intercalate "," $ fieldNames $ (Proxy :: Proxy r) ) <> " from " <> q1
query conn fullq args
ginsertInto :: forall r. (ToRow r, Generic r, HasFieldNames r) => Connection -> Query -> r -> IO ()
ginsertInto conn tbl val = do
let fnms = fieldNames $ (Proxy :: Proxy r)
_ <- execute conn ("INSERT INTO " <> tbl <> " (" <>
(fromString $ intercalate "," fnms ) <>
") VALUES (" <>
(fromString $ intercalate "," $ map (const "?") fnms) <> ")")
val
return ()
ginsertManyInto :: forall r. (ToRow r, Generic r, HasFieldNames r) => Connection -> Query -> [r] -> IO ()
ginsertManyInto conn tbl vals = do
let fnms = fieldNames $ (Proxy :: Proxy r)
_ <- executeMany conn ("INSERT INTO " <> tbl <> " (" <>
(fromString $ intercalate "," fnms ) <>
") VALUES (" <>
(fromString $ intercalate "," $ map (const "?") fnms) <> ")")
vals
return ()