module Database.Relational.Effect (
Restriction, restriction, restriction',
UpdateTarget, updateTarget, updateTarget',
liftTargetAllColumn, liftTargetAllColumn',
updateTargetAllColumn, updateTargetAllColumn',
InsertTarget, insertTarget, insertTarget', piRegister,
sqlWhereFromRestriction,
sqlFromUpdateTarget,
sqlChunkFromInsertTarget,
sqlFromInsertTarget,
sqlChunksFromRecordList,
) where
import Data.Monoid ((<>))
import Data.List (unfoldr)
import Data.Functor.ProductIsomorphic (peRight)
import Language.SQL.Keyword (Keyword(..))
import Database.Record.Persistable (PersistableWidth)
import Database.Relational.Internal.Config (Config (chunksInsertSize), defaultConfig)
import Database.Relational.Internal.String (StringSQL, stringSQL, showStringSQL)
import Database.Relational.SqlSyntax
(composeWhere, composeSets, composeChunkValuesWithColumns, composeValuesListWithColumns)
import Database.Relational.Pi (Pi, id')
import qualified Database.Relational.Pi.Unsafe as Pi
import Database.Relational.Table (Table, TableDerivable, derivedTable)
import qualified Database.Relational.Table as Table
import qualified Database.Relational.Record as Record
import Database.Relational.ProjectableClass (ShowConstantTermsSQL)
import Database.Relational.Projectable
(PlaceHolders, unitPH, pwPlaceholder, placeholder, (><), value, )
import Database.Relational.Monad.Trans.Assigning (assignings, (<-#))
import Database.Relational.Monad.Restrict (RestrictedStatement)
import qualified Database.Relational.Monad.Restrict as Restrict
import Database.Relational.Monad.Assign (AssignStatement)
import qualified Database.Relational.Monad.Assign as Assign
import Database.Relational.Monad.Register (Register)
import qualified Database.Relational.Monad.Register as Register
newtype Restriction p r = Restriction (RestrictedStatement r (PlaceHolders p))
restriction :: RestrictedStatement r () -> Restriction () r
restriction = Restriction . ((>> return unitPH) .)
restriction' :: RestrictedStatement r (PlaceHolders p) -> Restriction p r
restriction' = Restriction
runRestriction :: Restriction p r
-> RestrictedStatement r (PlaceHolders p)
runRestriction (Restriction qf) = qf
sqlWhereFromRestriction :: Config -> Table r -> Restriction p r -> StringSQL
sqlWhereFromRestriction config tbl (Restriction q) = composeWhere rs
where (_ph, rs) = Restrict.extract (q $ Record.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 unitPH) .)
updateTarget' :: AssignStatement r (PlaceHolders p)
-> UpdateTarget p r
updateTarget' = UpdateTarget
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 peRight $ 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 (Record.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 unitPH)
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
countChunks :: Config
-> Table r
-> Int
countChunks config tbl =
(th + w - 1) `quot` w
where
th = chunksInsertSize config
w = Table.width tbl
sqlChunkFromInsertTarget :: Config
-> Table r
-> InsertTarget p r
-> (StringSQL, Int)
sqlChunkFromInsertTarget config tbl it =
(sqlChunkFromInsertTarget' config n tbl it, n)
where
n = countChunks config tbl
sqlFromInsertTarget :: Config -> Table r -> InsertTarget p r -> StringSQL
sqlFromInsertTarget config = sqlChunkFromInsertTarget' config 1
sqlChunksFromRecordList :: ShowConstantTermsSQL r'
=> Config
-> Table r
-> Pi r r'
-> [r']
-> [StringSQL]
sqlChunksFromRecordList config tbl pi' xs =
[ INSERT <> INTO <> stringSQL (Table.name tbl) <>
composeValuesListWithColumns
[ tf tbl
| r <- rs
, let ((), tf) = Register.extract (pi' <-# value r) config
]
| rs <- unfoldr step xs
]
where
n = countChunks config tbl
step ys
| null ys = Nothing
| otherwise = Just $ splitAt n ys