module Database.Relational.Query.Effect (
Restriction, restriction, restriction',
UpdateTarget, updateTarget, updateTarget',
liftTargetAllColumn, liftTargetAllColumn',
updateTargetAllColumn, updateTargetAllColumn',
InsertTarget, insertTarget, insertTarget',
sqlWhereFromRestriction,
sqlFromUpdateTarget,
sqlFromInsertTarget
) where
import Data.Monoid ((<>))
import Database.Record (PersistableWidth)
import Database.Relational.Query.Internal.SQL (StringSQL, stringSQL, showStringSQL)
import Database.Relational.Query.Pi (id')
import Database.Relational.Query.Table (Table, TableDerivable, derivedTable)
import qualified Database.Relational.Query.Table as Table
import Database.Relational.Query.Component (Config, defaultConfig, composeSets, composeValues)
import Database.Relational.Query.Sub (composeWhere)
import qualified Database.Relational.Query.Projection as Projection
import Database.Relational.Query.Projectable
(PlaceHolders, placeholder, unitPlaceHolder, unsafeAddPlaceHolders, (><), 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
import Language.SQL.Keyword (Keyword(..))
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
sqlFromInsertTarget :: Config -> Table r -> InsertTarget p r -> StringSQL
sqlFromInsertTarget config tbl (InsertTarget q) = INSERT <> INTO <> stringSQL (Table.name tbl) <> composeValues (asR tbl)
where (_ph, asR) = Register.extract q config