mirror of
https://github.com/khibino/haskell-relational-record.git
synced 2024-12-26 21:42:15 +03:00
relational-query: rename low-level interfaces of Effects.
This commit is contained in:
Kei Hibino
parent
881c5c276a
commit
988a90cbe6
@ -25,11 +25,11 @@ module Database.Relational.Effect (
|
||||
InsertTarget, piRegister,
|
||||
|
||||
-- * Generate SQL from restriction.
|
||||
deleteFromRestriction,
|
||||
updateFromUpdateTarget,
|
||||
sqlChunkFromInsertTarget,
|
||||
sqlFromInsertTarget,
|
||||
sqlChunksFromRecordList,
|
||||
deleteFromRestrict,
|
||||
updateFromAssign,
|
||||
chunkInsertFromRegister,
|
||||
insertFromRegister,
|
||||
chunkInsertFromRecords,
|
||||
|
||||
-- * Deprecated
|
||||
restriction, restriction',
|
||||
@ -37,8 +37,9 @@ module Database.Relational.Effect (
|
||||
liftTargetAllColumn,
|
||||
updateTargetAllColumn, updateTargetAllColumn',
|
||||
insertTarget', insertTarget,
|
||||
sqlWhereFromRestriction,
|
||||
sqlFromUpdateTarget,
|
||||
sqlWhereFromRestriction, deleteFromRestriction,
|
||||
sqlFromUpdateTarget, updateFromUpdateTarget,
|
||||
sqlChunkFromInsertTarget, sqlFromInsertTarget, sqlChunksFromRecordList,
|
||||
) where
|
||||
|
||||
import Control.Applicative ((<$>))
|
||||
@ -103,24 +104,29 @@ restriction' :: (Record Flat r -> Restrict (PlaceHolders p)) -> Restriction p r
|
||||
restriction' = id
|
||||
{-# DEPRECATED restriction' "same as id" #-}
|
||||
|
||||
fromRestriction :: Config -> Table r -> (Record Flat r -> Restrict (PlaceHolders p)) -> (StringSQL, StringSQL)
|
||||
fromRestriction config tbl q = (qt, composeWhere $ map untypeRecord rs)
|
||||
fromRestrict :: Config -> Table r -> (Record Flat r -> Restrict (PlaceHolders p)) -> (StringSQL, StringSQL)
|
||||
fromRestrict config tbl q = (qt, composeWhere $ map untypeRecord rs)
|
||||
where (qt, rs) = Restrict.extract (withQualified tbl q) config
|
||||
|
||||
-- | SQL WHERE clause 'StringSQL' string from 'Restrict' computation.
|
||||
-- | Deprecated.
|
||||
sqlWhereFromRestriction :: Config -> Table r -> (Record Flat r -> Restrict (PlaceHolders p)) -> StringSQL
|
||||
sqlWhereFromRestriction config tbl q =
|
||||
composeWhere . map untypeRecord . snd $ Restrict.extract (withQualified tbl q) config
|
||||
{-# DEPRECATED sqlWhereFromRestriction "low-level API, this API will be expired." #-}
|
||||
|
||||
-- | DELETE statement with WHERE clause 'StringSQL' string from 'Restrict' computation.
|
||||
deleteFromRestrict :: Config -> Table r -> (Record Flat r -> Restrict (PlaceHolders p)) -> StringSQL
|
||||
deleteFromRestrict config tbl r =
|
||||
DELETE <> FROM <> uncurry (<>) (fromRestrict config tbl r)
|
||||
|
||||
-- | Deprecated.
|
||||
deleteFromRestriction :: Config -> Table r -> (Record Flat r -> Restrict (PlaceHolders p)) -> StringSQL
|
||||
deleteFromRestriction config tbl r =
|
||||
DELETE <> FROM <> uncurry (<>) (fromRestriction config tbl r)
|
||||
deleteFromRestriction = deleteFromRestrict
|
||||
{-# DEPRECATED deleteFromRestriction "low-level API, this API will be expired." #-}
|
||||
|
||||
-- | Show WHERE clause.
|
||||
instance TableDerivable r => Show (Record Flat r -> Restrict (PlaceHolders p)) where
|
||||
show = showStringSQL . snd . fromRestriction defaultConfig derivedTable
|
||||
show = showStringSQL . snd . fromRestrict defaultConfig derivedTable
|
||||
|
||||
|
||||
-- | UpdateTarget type with place-holder parameter 'p' and projected record type 'r'.
|
||||
@ -174,24 +180,29 @@ updateTargetAllColumn' = liftTargetAllColumn'
|
||||
{-# DEPRECATED updateTargetAllColumn' "Use Database.Relational.updateAllColumn instead of this." #-}
|
||||
|
||||
|
||||
fromUpdateTarget :: Config -> Table r -> (Record Flat r -> Assign r (PlaceHolders p)) -> (StringSQL, StringSQL)
|
||||
fromUpdateTarget config tbl q = (qt, composeSets (asR tbl) <> (composeWhere $ map untypeRecord rs))
|
||||
fromAssign :: Config -> Table r -> (Record Flat r -> Assign r (PlaceHolders p)) -> (StringSQL, StringSQL)
|
||||
fromAssign config tbl q = (qt, composeSets (asR tbl) <> (composeWhere $ map untypeRecord rs))
|
||||
where ((qt, asR), rs) = Assign.extract (withQualified tbl q) config
|
||||
|
||||
-- | SQL SET clause and WHERE clause 'StringSQL' string from 'Assign' computation.
|
||||
-- | Deprecated.
|
||||
sqlFromUpdateTarget :: Config -> Table r -> (Record Flat r -> Assign r (PlaceHolders p)) -> StringSQL
|
||||
sqlFromUpdateTarget config tbl q = composeSets (asR tbl) <> (composeWhere $ map untypeRecord rs)
|
||||
where ((_, asR), rs) = Assign.extract (withQualified tbl q) config
|
||||
{-# DEPRECATED sqlFromUpdateTarget "low-level API, this API will be expired." #-}
|
||||
|
||||
-- | UPDATE statement with SET clause and WHERE clause 'StringSQL' string from 'Assign' computation.
|
||||
updateFromAssign :: Config -> Table r -> (Record Flat r -> Assign r (PlaceHolders p)) -> StringSQL
|
||||
updateFromAssign config tbl ut =
|
||||
UPDATE <> uncurry (<>) (fromAssign config tbl ut)
|
||||
|
||||
-- | Deprecated.
|
||||
updateFromUpdateTarget :: Config -> Table r -> (Record Flat r -> Assign r (PlaceHolders p)) -> StringSQL
|
||||
updateFromUpdateTarget config tbl ut =
|
||||
UPDATE <> uncurry (<>) (fromUpdateTarget config tbl ut)
|
||||
updateFromUpdateTarget = updateFromAssign
|
||||
{-# DEPRECATED updateFromUpdateTarget "low-level API, this API will be expired." #-}
|
||||
|
||||
-- | Show Set clause and WHERE clause.
|
||||
instance TableDerivable r => Show (Record Flat r -> Assign r (PlaceHolders p)) where
|
||||
show = showStringSQL . snd . fromUpdateTarget defaultConfig derivedTable
|
||||
show = showStringSQL . snd . fromAssign defaultConfig derivedTable
|
||||
|
||||
|
||||
-- | InsertTarget type with place-holder parameter 'p' and projected record type 'r'.
|
||||
@ -218,12 +229,12 @@ piRegister pi' = do
|
||||
() <- ma
|
||||
return ph'
|
||||
|
||||
sqlChunkFromInsertTarget' :: Config
|
||||
-> Int
|
||||
-> Table r
|
||||
-> InsertTarget p r
|
||||
-> StringSQL
|
||||
sqlChunkFromInsertTarget' config sz tbl q =
|
||||
fromRegister :: Config
|
||||
-> Int
|
||||
-> Table r
|
||||
-> InsertTarget p r
|
||||
-> StringSQL
|
||||
fromRegister config sz tbl q =
|
||||
INSERT <> INTO <> stringSQL (tableName tbl) <> composeChunkValuesWithColumns sz (asR tbl)
|
||||
where
|
||||
(_ph, asR) = Register.extract q config
|
||||
@ -238,27 +249,40 @@ countChunks config tbl =
|
||||
w = Table.width tbl
|
||||
|
||||
-- | Make 'StringSQL' string of SQL INSERT record chunk statement from 'InsertTarget'
|
||||
chunkInsertFromRegister :: Config
|
||||
-> Table r
|
||||
-> InsertTarget p r
|
||||
-> (StringSQL, Int)
|
||||
chunkInsertFromRegister config tbl it =
|
||||
(fromRegister config n tbl it, n)
|
||||
where
|
||||
n = countChunks config tbl
|
||||
|
||||
-- | Deprecated.
|
||||
sqlChunkFromInsertTarget :: Config
|
||||
-> Table r
|
||||
-> InsertTarget p r
|
||||
-> (StringSQL, Int)
|
||||
sqlChunkFromInsertTarget config tbl it =
|
||||
(sqlChunkFromInsertTarget' config n tbl it, n)
|
||||
where
|
||||
n = countChunks config tbl
|
||||
sqlChunkFromInsertTarget = chunkInsertFromRegister
|
||||
{-# DEPRECATED sqlChunkFromInsertTarget "low-level API, this API will be expired." #-}
|
||||
|
||||
-- | Make 'StringSQL' string of SQL INSERT statement from 'InsertTarget'
|
||||
insertFromRegister :: Config -> Table r -> InsertTarget p r -> StringSQL
|
||||
insertFromRegister config = fromRegister config 1
|
||||
|
||||
-- | Deprecated.
|
||||
sqlFromInsertTarget :: Config -> Table r -> InsertTarget p r -> StringSQL
|
||||
sqlFromInsertTarget config = sqlChunkFromInsertTarget' config 1
|
||||
sqlFromInsertTarget = insertFromRegister
|
||||
{-# DEPRECATED sqlFromInsertTarget "low-level API, this API will be expired." #-}
|
||||
|
||||
-- | Make 'StringSQL' strings of SQL INSERT strings from records list
|
||||
sqlChunksFromRecordList :: LiteralSQL r'
|
||||
=> Config
|
||||
-> Table r
|
||||
-> Pi r r'
|
||||
-> [r']
|
||||
-> [StringSQL]
|
||||
sqlChunksFromRecordList config tbl pi' xs =
|
||||
chunkInsertFromRecords :: LiteralSQL r'
|
||||
=> Config
|
||||
-> Table r
|
||||
-> Pi r r'
|
||||
-> [r']
|
||||
-> [StringSQL]
|
||||
chunkInsertFromRecords config tbl pi' xs =
|
||||
[ INSERT <> INTO <> stringSQL (tableName tbl) <>
|
||||
composeValuesListWithColumns
|
||||
[ tf tbl
|
||||
@ -272,3 +296,13 @@ sqlChunksFromRecordList config tbl pi' xs =
|
||||
step ys
|
||||
| null ys = Nothing
|
||||
| otherwise = Just $ splitAt n ys
|
||||
|
||||
-- | Deprecated.
|
||||
sqlChunksFromRecordList :: LiteralSQL r'
|
||||
=> Config
|
||||
-> Table r
|
||||
-> Pi r r'
|
||||
-> [r']
|
||||
-> [StringSQL]
|
||||
sqlChunksFromRecordList = chunkInsertFromRecords
|
||||
{-# DEPRECATED sqlChunksFromRecordList "low-level API, this API will be expired." #-}
|
||||
|
||||
@ -78,8 +78,8 @@ import Database.Relational.Monad.Register (Register)
|
||||
import Database.Relational.Relation (tableFromRelation)
|
||||
import Database.Relational.Effect
|
||||
(liftTargetAllColumn',
|
||||
deleteFromRestriction, updateFromUpdateTarget, piRegister,
|
||||
sqlChunkFromInsertTarget, sqlFromInsertTarget, sqlChunksFromRecordList)
|
||||
deleteFromRestrict, updateFromAssign, piRegister,
|
||||
chunkInsertFromRegister, insertFromRegister, chunkInsertFromRecords,)
|
||||
import Database.Relational.Pi (Pi)
|
||||
import Database.Relational.ProjectableClass (LiteralSQL)
|
||||
import Database.Relational.Projectable (PlaceHolders, unitPH)
|
||||
@ -169,7 +169,7 @@ unsafeTypedUpdate = Update
|
||||
|
||||
-- | Make untyped update SQL string from 'Table' and 'Assign' computation.
|
||||
updateSQL :: Config -> Table r -> (Record Flat r -> Assign r (PlaceHolders p)) -> String
|
||||
updateSQL config tbl ut = showStringSQL $ updateFromUpdateTarget config tbl ut
|
||||
updateSQL config tbl ut = showStringSQL $ updateFromAssign config tbl ut
|
||||
|
||||
-- | Make typed 'Update' from 'Config', 'Table' and 'Assign' computation.
|
||||
typedUpdate' :: Config -> Table r -> (Record Flat r -> Assign r (PlaceHolders p)) -> Update p
|
||||
@ -313,10 +313,10 @@ derivedInsert = insert
|
||||
typedInsertValue' :: Config -> Table r -> Register r (PlaceHolders p) -> Insert p
|
||||
typedInsertValue' config tbl it =
|
||||
unsafeTypedInsert'
|
||||
(showStringSQL $ sqlFromInsertTarget config tbl it)
|
||||
(showStringSQL $ insertFromRegister config tbl it)
|
||||
(showStringSQL ci) n
|
||||
where
|
||||
(ci, n) = sqlChunkFromInsertTarget config tbl it
|
||||
(ci, n) = chunkInsertFromRegister config tbl it
|
||||
|
||||
{-# DEPRECATED typedInsertValue "use `typedInsertValue' defaultConfig` instead of this." #-}
|
||||
-- | Make typed 'Insert' from 'Table' and monadic builded 'Register' object.
|
||||
@ -356,7 +356,7 @@ insertValueList' :: (TableDerivable r, LiteralSQL r')
|
||||
-> [Insert ()]
|
||||
insertValueList' config pi' =
|
||||
map (unsafeTypedInsert . showStringSQL)
|
||||
. sqlChunksFromRecordList config derivedTable pi'
|
||||
. chunkInsertFromRecords config derivedTable pi'
|
||||
|
||||
-- | Make typed 'Insert' list from records list.
|
||||
insertValueList :: (TableDerivable r, LiteralSQL r')
|
||||
@ -416,7 +416,7 @@ unsafeTypedDelete = Delete
|
||||
|
||||
-- | Make untyped delete SQL string from 'Table' and 'Restrict' computation.
|
||||
deleteSQL :: Config -> Table r -> (Record Flat r -> Restrict (PlaceHolders p)) -> String
|
||||
deleteSQL config tbl r = showStringSQL $ deleteFromRestriction config tbl r
|
||||
deleteSQL config tbl r = showStringSQL $ deleteFromRestrict config tbl r
|
||||
|
||||
-- | Make typed 'Delete' from 'Config', 'Table' and 'Restrict' computation.
|
||||
typedDelete' :: Config -> Table r -> (Record Flat r -> Restrict (PlaceHolders p)) -> Delete p
|
||||
|
||||
Loading…
Reference in New Issue
Block a user