{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
module Opaleye.Manipulation (module Opaleye.Manipulation,
U.Unpackspec,
HSql.OnConflict(..)) where
import qualified Opaleye.Field as F
import qualified Opaleye.Internal.Sql as Sql
import qualified Opaleye.Internal.Print as Print
import qualified Opaleye.RunQuery as RQ
import qualified Opaleye.Internal.RunQuery as IRQ
import qualified Opaleye.Table as T
import qualified Opaleye.Internal.Table as TI
import Opaleye.Internal.Column (Column(Column))
import Opaleye.Internal.Helpers ((.:), (.:.), (.::.))
import Opaleye.Internal.Manipulation (Updater(Updater))
import qualified Opaleye.Internal.Manipulation as MI
import qualified Opaleye.Internal.PrimQuery as PQ
import qualified Opaleye.Internal.Unpackspec as U
import Opaleye.SqlTypes (SqlBool)
import qualified Opaleye.Internal.HaskellDB.Sql as HSql
import qualified Opaleye.Internal.HaskellDB.Sql.Print as HPrint
import qualified Opaleye.Internal.HaskellDB.Sql.Default as SD
import qualified Opaleye.Internal.HaskellDB.Sql.Generate as SG
import qualified Database.PostgreSQL.Simple as PGS
import qualified Data.Profunctor.Product.Default as D
import Data.Int (Int64)
import Data.String (fromString)
import qualified Data.List.NonEmpty as NEL
runInsert_ :: PGS.Connection
-> Insert haskells
-> IO haskells
runInsert_ conn i = case i of
Insert table_ rows_ returning_ onConflict_ ->
let insert = case (returning_, onConflict_) of
(MI.Count, Nothing) ->
runInsertMany
(MI.Count, Just HSql.DoNothing) ->
runInsertManyOnConflictDoNothing
(MI.ReturningExplicit qr f, oc) ->
\c t r -> MI.runInsertManyReturningExplicit qr c t r f oc
in insert conn table_ rows_
runUpdate_ :: PGS.Connection
-> Update haskells
-> IO haskells
runUpdate_ conn i = case i of
Update table_ updateWith_ where_ returning_ ->
let update = case returning_ of
MI.Count ->
runUpdate
MI.ReturningExplicit qr f ->
\c t u w -> runUpdateReturningExplicit qr c t u w f
in update conn table_ updateWith_ where_
runDelete_ :: PGS.Connection
-> Delete haskells
-> IO haskells
runDelete_ conn i = case i of
Delete table_ where_ returning_ ->
let delete = case returning_ of
MI.Count ->
runDelete
MI.ReturningExplicit qr f ->
\c t w -> MI.runDeleteReturningExplicit qr c t w f
in delete conn table_ where_
data Insert haskells = forall fieldsW fieldsR. Insert
{ iTable :: T.Table fieldsW fieldsR
, iRows :: [fieldsW]
, iReturning :: MI.Returning fieldsR haskells
, iOnConflict :: Maybe HSql.OnConflict
}
data Update haskells = forall fieldsW fieldsR. Update
{ uTable :: T.Table fieldsW fieldsR
, uUpdateWith :: fieldsR -> fieldsW
, uWhere :: fieldsR -> F.Field SqlBool
, uReturning :: MI.Returning fieldsR haskells
}
updateEasy :: D.Default Updater fieldsR fieldsW
=> (fieldsR -> fieldsR)
-> (fieldsR -> fieldsW)
updateEasy u = u' . u
where Updater u' = D.def
data Delete haskells = forall fieldsW fieldsR. Delete
{ dTable :: T.Table fieldsW fieldsR
, dWhere :: fieldsR -> F.Field SqlBool
, dReturning :: MI.Returning fieldsR haskells
}
rCount :: MI.Returning fieldsR Int64
rCount = MI.Count
rReturning :: D.Default RQ.FromFields fields haskells
=> (fieldsR -> fields)
-> MI.Returning fieldsR [haskells]
rReturning = rReturningExplicit D.def
rReturningExplicit :: RQ.FromFields fields haskells
-> (fieldsR -> fields)
-> MI.Returning fieldsR [haskells]
rReturningExplicit = MI.ReturningExplicit
{-# DEPRECATED runInsert
"'runInsert' will be removed in version 0.7. \
\Use 'runInsertMany' instead." #-}
runInsert :: PGS.Connection -> T.Table fields fields' -> fields -> IO Int64
runInsert conn = PGS.execute_ conn . fromString .: arrangeInsertSql
{-# DEPRECATED runInsertReturning
"'runInsertReturning' will be removed in version 0.7. \
\Use 'runInsertManyReturning' instead." #-}
runInsertReturning :: (D.Default RQ.QueryRunner fieldsReturned haskells)
=> PGS.Connection
-> T.Table fieldsW fieldsR
-> fieldsW
-> (fieldsR -> fieldsReturned)
-> IO [haskells]
runInsertReturning = runInsertReturningExplicit D.def
{-# DEPRECATED arrangeInsert
"You probably want 'runInsertMany' instead. \
\Will be removed in version 0.7." #-}
arrangeInsert :: T.Table columns a -> columns -> HSql.SqlInsert
arrangeInsert t c = arrangeInsertMany t (return c)
{-# DEPRECATED arrangeInsertSql
"You probably want 'runInsertMany' instead. \
\Will be removed in version 0.7." #-}
arrangeInsertSql :: T.Table columns a -> columns -> String
arrangeInsertSql = show . HPrint.ppInsert .: arrangeInsert
{-# DEPRECATED arrangeInsertMany
"You probably want 'runInsertMany' instead. \
\Will be removed in version 0.7." #-}
arrangeInsertMany :: T.Table columns a -> NEL.NonEmpty columns -> HSql.SqlInsert
arrangeInsertMany t columns = MI.arrangeInsertMany t columns Nothing
{-# DEPRECATED arrangeInsertManySql
"You probably want 'runInsertMany' instead. \
\Will be removed in version 0.7." #-}
arrangeInsertManySql :: T.Table columns a -> NEL.NonEmpty columns -> String
arrangeInsertManySql t c = MI.arrangeInsertManySql t c Nothing
{-# DEPRECATED arrangeUpdate
"You probably want 'runUpdate' instead. \
\Will be removed in version 0.7." #-}
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.TableProperties writer (TI.View tableCols) = TI.tableColumns t
update' = map (\(x, y) -> (y, x)) . TI.runWriter writer . update
Column condExpr = cond tableCols
{-# DEPRECATED arrangeUpdateSql
"You probably want 'runUpdate' instead. \
\Will be removed in version 0.7." #-}
arrangeUpdateSql :: T.Table columnsW columnsR
-> (columnsR -> columnsW) -> (columnsR -> Column SqlBool)
-> String
arrangeUpdateSql = show . HPrint.ppUpdate .:. arrangeUpdate
{-# DEPRECATED arrangeDelete
"You probably want 'runDelete' instead. \
\Will be removed in version 0.7." #-}
arrangeDelete :: T.Table a columnsR -> (columnsR -> Column SqlBool) -> HSql.SqlDelete
arrangeDelete = MI.arrangeDelete
{-# DEPRECATED arrangeDeleteSql
"You probably want 'runDelete' instead. \
\Will be removed in version 0.7." #-}
arrangeDeleteSql :: T.Table a columnsR -> (columnsR -> Column SqlBool) -> String
arrangeDeleteSql = show . HPrint.ppDelete .: arrangeDelete
{-# DEPRECATED arrangeInsertManyReturning
"You probably want 'runInsertMany' instead. \
\Will be removed in version 0.7." #-}
arrangeInsertManyReturning :: U.Unpackspec columnsReturned ignored
-> T.Table columnsW columnsR
-> NEL.NonEmpty columnsW
-> (columnsR -> columnsReturned)
-> Sql.Returning HSql.SqlInsert
arrangeInsertManyReturning unpackspec t columns returningf =
MI.arrangeInsertManyReturning unpackspec t columns returningf Nothing
{-# DEPRECATED arrangeInsertManyReturningSql
"You probably want 'runInsertManyReturning' instead. \
\Will be removed in version 0.7." #-}
arrangeInsertManyReturningSql :: U.Unpackspec columnsReturned ignored
-> T.Table columnsW columnsR
-> NEL.NonEmpty columnsW
-> (columnsR -> columnsReturned)
-> String
arrangeInsertManyReturningSql u t c r =
MI.arrangeInsertManyReturningSql u t c r Nothing
{-# DEPRECATED arrangeUpdateReturning
"You probably want 'runUpdateReturning' instead. \
\Will be removed in version 0.7." #-}
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)
{-# DEPRECATED arrangeUpdateReturningSql
"You probably want 'runUpdateReturning' instead. \
\Will be removed in version 0.7." #-}
arrangeUpdateReturningSql :: U.Unpackspec columnsReturned ignored
-> T.Table columnsW columnsR
-> (columnsR -> columnsW)
-> (columnsR -> Column SqlBool)
-> (columnsR -> columnsReturned)
-> String
arrangeUpdateReturningSql =
show . Print.ppUpdateReturning .::. arrangeUpdateReturning
{-# DEPRECATED runInsertManyOnConflictDoNothing "Use 'runInsert_'. Will be removed in version 0.8." #-}
runInsertManyOnConflictDoNothing :: PGS.Connection
-> T.Table columns columns'
-> [columns]
-> IO Int64
runInsertManyOnConflictDoNothing conn table_ columns =
case NEL.nonEmpty columns of
Nothing -> return 0
Just columns' -> (PGS.execute_ conn . fromString .:. MI.arrangeInsertManySql)
table_ columns' (Just HSql.DoNothing)
{-# DEPRECATED runInsertManyReturningOnConflictDoNothing "Use 'runInsert_'. Will be removed in version 0.8." #-}
runInsertManyReturningOnConflictDoNothing
:: (D.Default RQ.QueryRunner columnsReturned haskells)
=> PGS.Connection
-> T.Table columnsW columnsR
-> [columnsW]
-> (columnsR -> columnsReturned)
-> IO [haskells]
runInsertManyReturningOnConflictDoNothing =
runInsertManyReturningOnConflictDoNothingExplicit D.def
runInsertMany :: PGS.Connection
-> T.Table columns columns'
-> [columns]
-> IO Int64
runInsertMany conn t columns = case NEL.nonEmpty columns of
Nothing -> return 0
Just columns' -> (PGS.execute_ conn . fromString .: arrangeInsertManySql) t columns'
runInsertManyReturning :: (D.Default RQ.QueryRunner columnsReturned haskells)
=> PGS.Connection
-> T.Table columnsW columnsR
-> [columnsW]
-> (columnsR -> columnsReturned)
-> IO [haskells]
runInsertManyReturning = runInsertManyReturningExplicit D.def
runInsertReturningExplicit :: RQ.QueryRunner columnsReturned haskells
-> PGS.Connection
-> T.Table columnsW columnsR
-> columnsW
-> (columnsR -> columnsReturned)
-> IO [haskells]
runInsertReturningExplicit qr conn t =
runInsertManyReturningExplicit qr conn t . return
runInsertManyReturningExplicit :: RQ.QueryRunner columnsReturned haskells
-> PGS.Connection
-> T.Table columnsW columnsR
-> [columnsW]
-> (columnsR -> columnsReturned)
-> IO [haskells]
runInsertManyReturningExplicit qr conn t columns f =
MI.runInsertManyReturningExplicit qr conn t columns f Nothing
runInsertManyReturningOnConflictDoNothingExplicit
:: RQ.QueryRunner columnsReturned haskells
-> PGS.Connection
-> T.Table columnsW columnsR
-> [columnsW]
-> (columnsR -> columnsReturned)
-> IO [haskells]
runInsertManyReturningOnConflictDoNothingExplicit qr conn t columns f =
MI.runInsertManyReturningExplicit qr conn t columns f (Just HSql.DoNothing)
runUpdateEasy :: D.Default Updater columnsR columnsW
=> PGS.Connection
-> T.Table columnsW columnsR
-> (columnsR -> columnsR)
-> (columnsR -> Column SqlBool)
-> IO Int64
runUpdateEasy conn table_ u = runUpdate conn table_ (u' . u)
where Updater u' = D.def
runUpdate :: PGS.Connection
-> T.Table columnsW columnsR
-> (columnsR -> columnsW)
-> (columnsR -> Column SqlBool)
-> IO Int64
runUpdate conn = PGS.execute_ conn . fromString .:. arrangeUpdateSql
runUpdateReturning :: (D.Default RQ.QueryRunner columnsReturned haskells)
=> PGS.Connection
-> T.Table columnsW columnsR
-> (columnsR -> columnsW)
-> (columnsR -> Column SqlBool)
-> (columnsR -> columnsReturned)
-> IO [haskells]
runUpdateReturning = runUpdateReturningExplicit D.def
runUpdateReturningExplicit :: RQ.QueryRunner columnsReturned haskells
-> PGS.Connection
-> T.Table columnsW columnsR
-> (columnsR -> columnsW)
-> (columnsR -> Column SqlBool)
-> (columnsR -> columnsReturned)
-> IO [haskells]
runUpdateReturningExplicit qr conn t update cond r =
PGS.queryWith_ parser conn
(fromString (arrangeUpdateReturningSql u t update cond r))
where IRQ.QueryRunner u _ _ = qr
parser = IRQ.prepareRowParser qr (r v)
TI.View v = TI.tableColumnsView (TI.tableColumns t)
runDelete :: PGS.Connection
-> T.Table a columnsR
-> (columnsR -> Column SqlBool)
-> IO Int64
runDelete conn = PGS.execute_ conn . fromString .: arrangeDeleteSql