module Database.Relational.Query.Effect (
Restriction, restriction, restriction',
UpdateTarget, updateTarget, updateTarget',
liftTargetAllColumn, liftTargetAllColumn',
updateTargetAllColumn, updateTargetAllColumn',
InsertTarget, insertTarget, insertTarget', piRegister,
sqlWhereFromRestriction,
sqlFromUpdateTarget,
sqlChunkFromInsertTarget,
sqlFromInsertTarget,
) where
import Data.Monoid ((<>))
import Language.SQL.Keyword (Keyword(..))
import Database.Record.Persistable (PersistableWidth)
import Database.Relational.Query.Internal.Config (Config (chunksInsertSize), defaultConfig)
import Database.Relational.Query.Internal.SQL (StringSQL, stringSQL, showStringSQL)
import Database.Relational.Query.Internal.BaseSQL (composeSets, composeChunkValuesWithColumns)
import Database.Relational.Query.Pi (Pi, id')
import qualified Database.Relational.Query.Pi.Unsafe as Pi
import Database.Relational.Query.Table (Table, TableDerivable, derivedTable)
import qualified Database.Relational.Query.Table as Table
import Database.Relational.Query.Sub (composeWhere)
import qualified Database.Relational.Query.Projection as Projection
import Database.Relational.Query.Projectable
(PlaceHolders, unitPlaceHolder, unsafeAddPlaceHolders,
pwPlaceholder, placeholder, (><), rightId)
import Database.Relational.Query.Monad.Trans.Assigning (assignings, (<-#))
import Database.Relational.Query.Monad.Restrict (RestrictedStatement)
import qualified Database.Relational.Query.Monad.Restrict as Restrict
import Database.Relational.Query.Monad.Assign (AssignStatement)
import qualified Database.Relational.Query.Monad.Assign as Assign
import Database.Relational.Query.Monad.Register (Register)
import qualified Database.Relational.Query.Monad.Register as Register
newtype Restriction p r = Restriction (RestrictedStatement r (PlaceHolders p))
restriction :: RestrictedStatement r () -> Restriction () r
restriction = Restriction . ((>> return unitPlaceHolder) .)
restriction' :: RestrictedStatement r (PlaceHolders p) -> Restriction p r
restriction' = Restriction
runRestriction :: Restriction p r
-> RestrictedStatement r (PlaceHolders p)
runRestriction (Restriction qf) =
fmap fst . unsafeAddPlaceHolders . qf
sqlWhereFromRestriction :: Config -> Table r -> Restriction p r -> StringSQL
sqlWhereFromRestriction config tbl (Restriction q) = composeWhere rs
where (_ph, rs) = Restrict.extract (q $ Projection.unsafeFromTable tbl) config
instance TableDerivable r => Show (Restriction p r) where
show = showStringSQL . sqlWhereFromRestriction defaultConfig derivedTable
newtype UpdateTarget p r = UpdateTarget (AssignStatement r (PlaceHolders p))
updateTarget :: AssignStatement r ()
-> UpdateTarget () r
updateTarget = UpdateTarget . ((>> return unitPlaceHolder) .)
updateTarget' :: AssignStatement r (PlaceHolders p)
-> UpdateTarget p r
updateTarget' = UpdateTarget
_runUpdateTarget :: UpdateTarget p r
-> AssignStatement r (PlaceHolders p)
_runUpdateTarget (UpdateTarget qf) =
fmap fst . unsafeAddPlaceHolders . qf
updateAllColumn :: PersistableWidth r
=> Restriction p r
-> AssignStatement r (PlaceHolders (r, p))
updateAllColumn rs proj = do
(ph0, ()) <- placeholder (\ph -> id' <-# ph)
ph1 <- assignings $ runRestriction rs proj
return $ ph0 >< ph1
liftTargetAllColumn :: PersistableWidth r
=> Restriction () r
-> UpdateTarget r r
liftTargetAllColumn rs = updateTarget' $ \proj -> fmap rightId $ updateAllColumn rs proj
liftTargetAllColumn' :: PersistableWidth r
=> Restriction p r
-> UpdateTarget (r, p) r
liftTargetAllColumn' rs = updateTarget' $ updateAllColumn rs
updateTargetAllColumn :: PersistableWidth r
=> RestrictedStatement r ()
-> UpdateTarget r r
updateTargetAllColumn = liftTargetAllColumn . restriction
updateTargetAllColumn' :: PersistableWidth r
=> RestrictedStatement r (PlaceHolders p)
-> UpdateTarget (r, p) r
updateTargetAllColumn' = liftTargetAllColumn' . restriction'
sqlFromUpdateTarget :: Config -> Table r -> UpdateTarget p r -> StringSQL
sqlFromUpdateTarget config tbl (UpdateTarget q) = composeSets (asR tbl) <> composeWhere rs
where ((_ph, asR), rs) = Assign.extract (q (Projection.unsafeFromTable tbl)) config
instance TableDerivable r => Show (UpdateTarget p r) where
show = showStringSQL . sqlFromUpdateTarget defaultConfig derivedTable
newtype InsertTarget p r = InsertTarget (Register r (PlaceHolders p))
insertTarget :: Register r ()
-> InsertTarget () r
insertTarget = InsertTarget . (>> return unitPlaceHolder)
insertTarget' :: Register r (PlaceHolders p)
-> InsertTarget p r
insertTarget' = InsertTarget
piRegister :: PersistableWidth r
=> Pi r r'
-> Register r (PlaceHolders r')
piRegister pi' = do
let (ph', ma) = pwPlaceholder (Pi.width' pi') (\ph -> pi' <-# ph)
() <- ma
return ph'
sqlChunkFromInsertTarget' :: Config
-> Int
-> Table r
-> InsertTarget p r
-> StringSQL
sqlChunkFromInsertTarget' config sz tbl (InsertTarget q) =
INSERT <> INTO <> stringSQL (Table.name tbl) <> composeChunkValuesWithColumns sz (asR tbl)
where
(_ph, asR) = Register.extract q config
sqlChunkFromInsertTarget :: Config
-> Table r
-> InsertTarget p r
-> (StringSQL, Int)
sqlChunkFromInsertTarget config tbl it =
(sqlChunkFromInsertTarget' config n tbl it, n)
where
th = chunksInsertSize config
n = (th + w 1) `quot` w
w = Table.width tbl
sqlFromInsertTarget :: Config -> Table r -> InsertTarget p r -> StringSQL
sqlFromInsertTarget config = sqlChunkFromInsertTarget' config 1