{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
module Opaleye.Internal.Manipulation where
import qualified Control.Applicative as A
import Opaleye.Internal.Column (Column(Column))
import qualified Opaleye.Internal.HaskellDB.Sql as HSql
import qualified Opaleye.Internal.HaskellDB.Sql.Default as SD
import qualified Opaleye.Internal.HaskellDB.Sql.Generate as SG
import qualified Opaleye.Internal.HaskellDB.Sql.Print as HPrint
import Opaleye.Internal.Helpers ((.:), (.:.), (.::.), (.::))
import qualified Opaleye.Internal.PrimQuery as PQ
import qualified Opaleye.Internal.Print as Print
import qualified Opaleye.Internal.RunQuery as IRQ
import qualified Opaleye.RunSelect as RS
import qualified Opaleye.Internal.Sql as Sql
import qualified Opaleye.Internal.Table as TI
import qualified Opaleye.Internal.Unpackspec as U
import qualified Opaleye.Table as T
import Opaleye.SqlTypes (SqlBool)
import Data.Int (Int64)
import qualified Data.List.NonEmpty as NEL
import Data.Profunctor (Profunctor, dimap)
import qualified Data.Profunctor.Product as PP
import qualified Data.Profunctor.Product.Default as D
import Data.String (fromString)
import qualified Database.PostgreSQL.Simple as PGS
data Returning a b where
Count
:: Returning a Int64
ReturningExplicit
:: RS.FromFields b c -> (a -> b) -> Returning a [c]
arrangeInsertMany :: T.Table columns a
-> NEL.NonEmpty columns
-> Maybe HSql.OnConflict
-> HSql.SqlInsert
arrangeInsertMany table columns onConflict = insert
where writer = TI.tableColumnsWriter (TI.tableColumns table)
(columnExprs, columnNames) = TI.runWriter' writer columns
insert = SG.sqlInsert SD.defaultSqlGenerator
(PQ.tiToSqlTable (TI.tableIdentifier table))
columnNames columnExprs
onConflict
arrangeInsertManyReturning :: U.Unpackspec columnsReturned ignored
-> T.Table columnsW columnsR
-> NEL.NonEmpty columnsW
-> (columnsR -> columnsReturned)
-> Maybe HSql.OnConflict
-> Sql.Returning HSql.SqlInsert
arrangeInsertManyReturning unpackspec table columns returningf onConflict =
Sql.Returning insert returningSEs
where insert = arrangeInsertMany table columns onConflict
TI.View columnsR = TI.tableColumnsView (TI.tableColumns table)
returningPEs = U.collectPEs unpackspec (returningf columnsR)
returningSEs = Sql.ensureColumnsGen id (map Sql.sqlExpr returningPEs)
arrangeInsertManyReturningSql :: U.Unpackspec columnsReturned ignored
-> T.Table columnsW columnsR
-> NEL.NonEmpty columnsW
-> (columnsR -> columnsReturned)
-> Maybe HSql.OnConflict
-> String
arrangeInsertManyReturningSql =
show . Print.ppInsertReturning .::. arrangeInsertManyReturning
arrangeInsertManySql :: T.Table columnsW columnsR
-> NEL.NonEmpty columnsW
-> Maybe HSql.OnConflict
-> String
arrangeInsertManySql =
show . HPrint.ppInsert .:. arrangeInsertMany
runInsertManyReturningExplicit
:: RS.FromFields columnsReturned haskells
-> PGS.Connection
-> T.Table columnsW columnsR
-> [columnsW]
-> (columnsR -> columnsReturned)
-> Maybe HSql.OnConflict
-> IO [haskells]
runInsertManyReturningExplicit
qr conn t columns r onConflict =
case NEL.nonEmpty columns of
Nothing -> return []
Just columns' -> PGS.queryWith_ parser conn
(fromString
(arrangeInsertManyReturningSql u t columns' r
onConflict))
where IRQ.QueryRunner u _ _ = qr
parser = IRQ.prepareRowParser qr (r v)
TI.View v = TI.tableColumnsView (TI.tableColumns t)
newtype Updater a b = Updater (a -> b)
instance Functor (Updater a) where
fmap f (Updater g) = Updater (fmap f g)
instance A.Applicative (Updater a) where
pure = Updater . A.pure
Updater f <*> Updater x = Updater (f A.<*> x)
instance Profunctor Updater where
dimap f g (Updater h) = Updater (dimap f g h)
instance PP.ProductProfunctor Updater where
purePP = pure
(****) = (<*>)
instance D.Default Updater (Column a) (Column a) where
def = Updater id
instance D.Default Updater (Column a) (Maybe (Column a)) where
def = Updater Just
arrangeDeleteReturning :: U.Unpackspec columnsReturned ignored
-> T.Table columnsW columnsR
-> (columnsR -> Column SqlBool)
-> (columnsR -> columnsReturned)
-> Sql.Returning HSql.SqlDelete
arrangeDeleteReturning unpackspec t cond returningf =
Sql.Returning delete returningSEs
where delete = arrangeDelete t cond
TI.View columnsR = TI.tableColumnsView (TI.tableColumns t)
returningPEs = U.collectPEs unpackspec (returningf columnsR)
returningSEs = Sql.ensureColumnsGen id (map Sql.sqlExpr returningPEs)
arrangeDeleteReturningSql :: U.Unpackspec columnsReturned ignored
-> T.Table columnsW columnsR
-> (columnsR -> Column SqlBool)
-> (columnsR -> columnsReturned)
-> String
arrangeDeleteReturningSql =
show . Print.ppDeleteReturning .:: arrangeDeleteReturning
runDeleteReturning :: (D.Default RS.FromFields columnsReturned haskells)
=> PGS.Connection
-> T.Table a columnsR
-> (columnsR -> Column SqlBool)
-> (columnsR -> columnsReturned)
-> IO [haskells]
runDeleteReturning = runDeleteReturningExplicit D.def
runDeleteReturningExplicit :: RS.FromFields columnsReturned haskells
-> PGS.Connection
-> T.Table a columnsR
-> (columnsR -> Column SqlBool)
-> (columnsR -> columnsReturned)
-> IO [haskells]
runDeleteReturningExplicit qr conn t cond r =
PGS.queryWith_ parser conn
(fromString (arrangeDeleteReturningSql u t cond r))
where IRQ.QueryRunner u _ _ = qr
parser = IRQ.prepareRowParser qr (r v)
TI.View v = TI.tableColumnsView (TI.tableColumns t)
arrangeDelete :: T.Table a columnsR -> (columnsR -> Column SqlBool) -> HSql.SqlDelete
arrangeDelete t cond =
SG.sqlDelete SD.defaultSqlGenerator (PQ.tiToSqlTable (TI.tableIdentifier t)) [condExpr]
where Column condExpr = cond tableCols
TI.View tableCols = TI.tableColumnsView (TI.tableColumns t)
runInsert :: PGS.Connection -> T.Table fields fields' -> fields -> IO Int64
runInsert conn = PGS.execute_ conn . fromString .: arrangeInsertSql
runInsertReturning :: (D.Default RS.FromFields fieldsReturned haskells)
=> PGS.Connection
-> T.Table fieldsW fieldsR
-> fieldsW
-> (fieldsR -> fieldsReturned)
-> IO [haskells]
runInsertReturning = runInsertReturningExplicit D.def
runInsertReturningExplicit :: RS.FromFields columnsReturned haskells
-> PGS.Connection
-> T.Table columnsW columnsR
-> columnsW
-> (columnsR -> columnsReturned)
-> IO [haskells]
runInsertReturningExplicit qr conn t =
runInsertManyReturningExplicitI qr conn t . return
runInsertManyReturningExplicitI :: RS.FromFields columnsReturned haskells
-> PGS.Connection
-> T.Table columnsW columnsR
-> [columnsW]
-> (columnsR -> columnsReturned)
-> IO [haskells]
runInsertManyReturningExplicitI qr conn t columns f =
runInsertManyReturningExplicit qr conn t columns f Nothing
arrangeInsert :: T.Table columns a -> columns -> HSql.SqlInsert
arrangeInsert t c = arrangeInsertManyI t (return c)
arrangeInsertSql :: T.Table columns a -> columns -> String
arrangeInsertSql = show . HPrint.ppInsert .: arrangeInsert
arrangeInsertManyI :: T.Table columns a -> NEL.NonEmpty columns -> HSql.SqlInsert
arrangeInsertManyI t columns = arrangeInsertMany t columns Nothing
arrangeInsertManySqlI :: T.Table columns a -> NEL.NonEmpty columns -> String
arrangeInsertManySqlI t c = arrangeInsertManySql t c Nothing
arrangeUpdate :: T.Table columnsW columnsR
-> (columnsR -> columnsW) -> (columnsR -> Column SqlBool)
-> HSql.SqlUpdate
arrangeUpdate t update cond =
SG.sqlUpdate SD.defaultSqlGenerator
(PQ.tiToSqlTable (TI.tableIdentifier t))
[condExpr] (update' tableCols)
where TI.TableFields writer (TI.View tableCols) = TI.tableColumns t
update' = map (\(x, y) -> (y, x)) . TI.runWriter writer . update
Column condExpr = cond tableCols
arrangeUpdateSql :: T.Table columnsW columnsR
-> (columnsR -> columnsW) -> (columnsR -> Column SqlBool)
-> String
arrangeUpdateSql = show . HPrint.ppUpdate .:. arrangeUpdate
arrangeDeleteSql :: T.Table a columnsR -> (columnsR -> Column SqlBool) -> String
arrangeDeleteSql = show . HPrint.ppDelete .: arrangeDelete
arrangeInsertManyReturningI :: U.Unpackspec columnsReturned ignored
-> T.Table columnsW columnsR
-> NEL.NonEmpty columnsW
-> (columnsR -> columnsReturned)
-> Sql.Returning HSql.SqlInsert
arrangeInsertManyReturningI unpackspec t columns returningf =
arrangeInsertManyReturning unpackspec t columns returningf Nothing
arrangeInsertManyReturningSqlI :: U.Unpackspec columnsReturned ignored
-> T.Table columnsW columnsR
-> NEL.NonEmpty columnsW
-> (columnsR -> columnsReturned)
-> String
arrangeInsertManyReturningSqlI u t c r =
arrangeInsertManyReturningSql u t c r Nothing
arrangeUpdateReturning :: U.Unpackspec columnsReturned ignored
-> T.Table columnsW columnsR
-> (columnsR -> columnsW)
-> (columnsR -> Column SqlBool)
-> (columnsR -> columnsReturned)
-> Sql.Returning HSql.SqlUpdate
arrangeUpdateReturning unpackspec t updatef cond returningf =
Sql.Returning update returningSEs
where update = arrangeUpdate t updatef cond
TI.View columnsR = TI.tableColumnsView (TI.tableColumns t)
returningPEs = U.collectPEs unpackspec (returningf columnsR)
returningSEs = Sql.ensureColumnsGen id (map Sql.sqlExpr returningPEs)
arrangeUpdateReturningSql :: U.Unpackspec columnsReturned ignored
-> T.Table columnsW columnsR
-> (columnsR -> columnsW)
-> (columnsR -> Column SqlBool)
-> (columnsR -> columnsReturned)
-> String
arrangeUpdateReturningSql =
show . Print.ppUpdateReturning .::. arrangeUpdateReturning