module Database.Relational.Query.Effect (
Restriction, RestrictionContext, restriction, restriction',
UpdateTarget, UpdateTargetContext, updateTarget, updateTarget',
liftTargetAllColumn, liftTargetAllColumn',
updateTargetAllColumn, updateTargetAllColumn',
sqlWhereFromRestriction,
sqlFromUpdateTarget
) where
import Data.Monoid ((<>))
import Control.Monad (void)
import Database.Record (PersistableWidth)
import Database.Relational.Query.Internal.SQL (StringSQL, showStringSQL)
import Database.Relational.Query.Context (Flat)
import Database.Relational.Query.Pi (id')
import Database.Relational.Query.Table (Table, TableDerivable, derivedTable)
import Database.Relational.Query.Component (Config, defaultConfig, composeWhere, composeSets)
import Database.Relational.Query.Projection (Projection)
import qualified Database.Relational.Query.Projection as Projection
import Database.Relational.Query.Projectable
(PlaceHolders, placeholder, unsafeAddPlaceHolders, (><), rightId)
import Database.Relational.Query.Monad.Trans.Assigning (assignings, (<-#))
import Database.Relational.Query.Monad.Restrict (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
newtype Restriction p r = Restriction (Projection Flat r -> Restrict ())
type RestrictionContext p r = RestrictedStatement r (PlaceHolders p)
restriction :: RestrictedStatement r () -> Restriction () r
restriction = Restriction
restriction' :: RestrictedStatement r (PlaceHolders p) -> Restriction p r
restriction' = Restriction . (void .)
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 ())
type UpdateTargetContext p r = AssignStatement r (PlaceHolders p)
updateTarget :: AssignStatement r ()
-> UpdateTarget () r
updateTarget = UpdateTarget
updateTarget' :: AssignStatement r (PlaceHolders p)
-> UpdateTarget p r
updateTarget' qf = UpdateTarget $ void . qf
_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