module Database.Relational.Type (
Query (..), unsafeTypedQuery,
relationalQuery', relationalQuery,
relationalQuerySQL,
KeyUpdate (..), unsafeTypedKeyUpdate, typedKeyUpdate, typedKeyUpdateTable, keyUpdate,
Update (..), unsafeTypedUpdate, typedUpdate', update', update, updateNoPH,
typedUpdateAllColumn, updateAllColumn', updateAllColumn, updateAllColumnNoPH,
updateSQL,
Insert (..), untypeChunkInsert, chunkSizeOfInsert,
unsafeTypedInsert', unsafeTypedInsert, typedInsert', insert,
typedInsertValue', insertValue', insertValue, insertValueNoPH,
insertValueList', insertValueList,
InsertQuery (..), unsafeTypedInsertQuery, typedInsertQuery', insertQuery,
insertQuerySQL,
Delete (..), unsafeTypedDelete, typedDelete', delete', delete, deleteNoPH,
deleteSQL,
UntypeableNoFetch (..),
typedUpdate,
typedInsert, typedInsertValue, typedInsertQuery,
typedDelete,
derivedKeyUpdate,
derivedUpdate', derivedUpdate,
derivedUpdateAllColumn', derivedUpdateAllColumn,
derivedInsert,
derivedInsertValue', derivedInsertValue,
derivedInsertQuery,
derivedDelete', derivedDelete,
) where
import Control.Applicative ((<*))
import Data.Monoid ((<>))
import Database.Record (PersistableWidth)
import Database.Relational.Internal.Config (Config, defaultConfig)
import Database.Relational.Internal.String (showStringSQL)
import Database.Relational.Monad.BaseType (Relation, sqlFromRelationWith)
import Database.Relational.Monad.Restrict (RestrictedStatement)
import Database.Relational.Monad.Assign (AssignStatement)
import Database.Relational.Monad.Register (Register)
import Database.Relational.Relation (tableOf)
import Database.Relational.Effect
(Restriction, restriction, restriction', UpdateTarget, updateTarget',
liftTargetAllColumn, liftTargetAllColumn',
InsertTarget, insertTarget',
sqlWhereFromRestriction, sqlFromUpdateTarget, piRegister,
sqlChunkFromInsertTarget, sqlFromInsertTarget, sqlChunksFromRecordList)
import Database.Relational.Pi (Pi)
import Database.Relational.Table (Table, TableDerivable, derivedTable)
import Database.Relational.ProjectableClass (LiteralSQL)
import Database.Relational.Projectable (PlaceHolders, unitPH)
import Database.Relational.SimpleSql
(QuerySuffix, showsQuerySuffix, insertPrefixSQL,
updateOtherThanKeySQL, updatePrefixSQL, deletePrefixSQL)
newtype Query p a = Query { untypeQuery :: String }
unsafeTypedQuery :: String
-> Query p a
unsafeTypedQuery = Query
instance Show (Query p a) where
show = untypeQuery
relationalQuerySQL :: Config -> Relation p r -> QuerySuffix -> String
relationalQuerySQL config rel qsuf = showStringSQL $ sqlFromRelationWith rel config <> showsQuerySuffix qsuf
relationalQuery' :: Relation p r -> QuerySuffix -> Query p r
relationalQuery' rel qsuf = unsafeTypedQuery $ relationalQuerySQL defaultConfig rel qsuf
relationalQuery :: Relation p r -> Query p r
relationalQuery = (`relationalQuery'` [])
data KeyUpdate p a = KeyUpdate { updateKey :: Pi a p
, untypeKeyUpdate :: String
}
unsafeTypedKeyUpdate :: Pi a p -> String -> KeyUpdate p a
unsafeTypedKeyUpdate = KeyUpdate
typedKeyUpdate :: Table a -> Pi a p -> KeyUpdate p a
typedKeyUpdate tbl key = unsafeTypedKeyUpdate key $ updateOtherThanKeySQL tbl key
typedKeyUpdateTable :: TableDerivable r => Relation () r -> Pi r p -> KeyUpdate p r
typedKeyUpdateTable = typedKeyUpdate . tableOf
keyUpdate :: TableDerivable r => Pi r p -> KeyUpdate p r
keyUpdate = typedKeyUpdate derivedTable
{-# DEPRECATED derivedKeyUpdate "use keyUpdate instead of this." #-}
derivedKeyUpdate :: TableDerivable r => Pi r p -> KeyUpdate p r
derivedKeyUpdate = keyUpdate
instance Show (KeyUpdate p a) where
show = untypeKeyUpdate
newtype Update p = Update { untypeUpdate :: String }
unsafeTypedUpdate :: String -> Update p
unsafeTypedUpdate = Update
updateSQL :: Config -> Table r -> UpdateTarget p r -> String
updateSQL config tbl ut = showStringSQL $ updatePrefixSQL tbl <> sqlFromUpdateTarget config tbl ut
typedUpdate' :: Config -> Table r -> UpdateTarget p r -> Update p
typedUpdate' config tbl ut = unsafeTypedUpdate $ updateSQL config tbl ut
{-# DEPRECATED typedUpdate "use `typedUpdate' defaultConfig` instead of this." #-}
typedUpdate :: Table r -> UpdateTarget p r -> Update p
typedUpdate = typedUpdate' defaultConfig
targetTable :: TableDerivable r => UpdateTarget p r -> Table r
targetTable = const derivedTable
update' :: TableDerivable r => Config -> AssignStatement r (PlaceHolders p) -> Update p
update' config utc = typedUpdate' config (targetTable ut) ut where
ut = updateTarget' utc
{-# DEPRECATED derivedUpdate' "use `update'` instead of this." #-}
derivedUpdate' :: TableDerivable r => Config -> AssignStatement r (PlaceHolders p) -> Update p
derivedUpdate' = update'
update :: TableDerivable r => AssignStatement r (PlaceHolders p) -> Update p
update = update' defaultConfig
updateNoPH :: TableDerivable r => AssignStatement r () -> Update ()
updateNoPH af = update $ (return unitPH <*) . af
{-# DEPRECATED derivedUpdate "use `update` instead of this." #-}
derivedUpdate :: TableDerivable r => AssignStatement r (PlaceHolders p) -> Update p
derivedUpdate = update
typedUpdateAllColumn' :: PersistableWidth r
=> Config
-> Table r
-> Restriction p r
-> Update (r, p)
typedUpdateAllColumn' config tbl r = typedUpdate' config tbl $ liftTargetAllColumn' r
typedUpdateAllColumn :: PersistableWidth r
=> Table r
-> Restriction p r
-> Update (r, p)
typedUpdateAllColumn = typedUpdateAllColumn' defaultConfig
updateAllColumn' :: (PersistableWidth r, TableDerivable r)
=> Config
-> RestrictedStatement r (PlaceHolders p)
-> Update (r, p)
updateAllColumn' config = typedUpdateAllColumn' config derivedTable .restriction'
{-# DEPRECATED derivedUpdateAllColumn' "use `updateAllColumn'` instead of this." #-}
derivedUpdateAllColumn' :: (PersistableWidth r, TableDerivable r)
=> Config
-> RestrictedStatement r (PlaceHolders p)
-> Update (r, p)
derivedUpdateAllColumn' = updateAllColumn'
updateAllColumn :: (PersistableWidth r, TableDerivable r)
=> RestrictedStatement r (PlaceHolders p)
-> Update (r, p)
updateAllColumn = updateAllColumn' defaultConfig
updateAllColumnNoPH :: (PersistableWidth r, TableDerivable r)
=> RestrictedStatement r ()
-> Update r
updateAllColumnNoPH =
typedUpdate' defaultConfig derivedTable . liftTargetAllColumn . restriction
{-# DEPRECATED derivedUpdateAllColumn "use `updateAllColumn` instead of this." #-}
derivedUpdateAllColumn :: (PersistableWidth r, TableDerivable r)
=> RestrictedStatement r (PlaceHolders p)
-> Update (r, p)
derivedUpdateAllColumn = updateAllColumn
instance Show (Update p) where
show = untypeUpdate
data Insert a =
Insert
{ untypeInsert :: String
, chunkedInsert :: Maybe (String, Int)
}
untypeChunkInsert :: Insert a -> String
untypeChunkInsert ins = maybe (untypeInsert ins) fst $ chunkedInsert ins
chunkSizeOfInsert :: Insert a -> Int
chunkSizeOfInsert = maybe 1 snd . chunkedInsert
unsafeTypedInsert' :: String -> String -> Int -> Insert a
unsafeTypedInsert' s = curry (Insert s . Just)
unsafeTypedInsert :: String -> Insert a
unsafeTypedInsert s = Insert s Nothing
typedInsert' :: PersistableWidth r => Config -> Table r -> Pi r r' -> Insert r'
typedInsert' config tbl =
typedInsertValue' config tbl . insertTarget' . piRegister
{-# DEPRECATED typedInsert "use `typedInsert' defaultConfig` instead of this." #-}
typedInsert :: PersistableWidth r => Table r -> Pi r r' -> Insert r'
typedInsert = typedInsert' defaultConfig
insert :: (PersistableWidth r, TableDerivable r) => Pi r r' -> Insert r'
insert = typedInsert' defaultConfig derivedTable
{-# DEPRECATED derivedInsert "use `insert` instead of this." #-}
derivedInsert :: (PersistableWidth r, TableDerivable r) => Pi r r' -> Insert r'
derivedInsert = insert
typedInsertValue' :: Config -> Table r -> InsertTarget p r -> Insert p
typedInsertValue' config tbl it =
unsafeTypedInsert'
(showStringSQL $ sqlFromInsertTarget config tbl it)
(showStringSQL ci) n
where
(ci, n) = sqlChunkFromInsertTarget config tbl it
{-# DEPRECATED typedInsertValue "use `typedInsertValue' defaultConfig` instead of this." #-}
typedInsertValue :: Table r -> InsertTarget p r -> Insert p
typedInsertValue = typedInsertValue' defaultConfig
insertValue' :: TableDerivable r => Config -> Register r (PlaceHolders p) -> Insert p
insertValue' config rs = typedInsertValue' config (rt rs) $ insertTarget' rs
where
rt :: TableDerivable r => Register r (PlaceHolders p) -> Table r
rt = const derivedTable
{-# DEPRECATED derivedInsertValue' "use `insertValue'` instead of this." #-}
derivedInsertValue' :: TableDerivable r => Config -> Register r (PlaceHolders p) -> Insert p
derivedInsertValue' = insertValue'
insertValue :: TableDerivable r => Register r (PlaceHolders p) -> Insert p
insertValue = insertValue' defaultConfig
insertValueNoPH :: TableDerivable r => Register r () -> Insert ()
insertValueNoPH = insertValue . (return unitPH <*)
{-# DEPRECATED derivedInsertValue "use `insertValue` instead of this." #-}
derivedInsertValue :: TableDerivable r => Register r (PlaceHolders p) -> Insert p
derivedInsertValue = insertValue
insertValueList' :: (TableDerivable r, LiteralSQL r')
=> Config
-> Pi r r'
-> [r']
-> [Insert ()]
insertValueList' config pi' =
map (unsafeTypedInsert . showStringSQL)
. sqlChunksFromRecordList config derivedTable pi'
insertValueList :: (TableDerivable r, LiteralSQL r')
=> Pi r r'
-> [r']
-> [Insert ()]
insertValueList = insertValueList' defaultConfig
instance Show (Insert a) where
show = untypeInsert
newtype InsertQuery p = InsertQuery { untypeInsertQuery :: String }
unsafeTypedInsertQuery :: String -> InsertQuery p
unsafeTypedInsertQuery = InsertQuery
insertQuerySQL :: Config -> Table r -> Pi r r' -> Relation p r' -> String
insertQuerySQL config tbl pi' rel = showStringSQL $ insertPrefixSQL pi' tbl <> sqlFromRelationWith rel config
typedInsertQuery' :: Config -> Table r -> Pi r r' -> Relation p r' -> InsertQuery p
typedInsertQuery' config tbl pi' rel = unsafeTypedInsertQuery $ insertQuerySQL config tbl pi' rel
{-# DEPRECATED typedInsertQuery "use `typedInsertQuery' defaultConfig` instead of this." #-}
typedInsertQuery :: Table r -> Pi r r' -> Relation p r' -> InsertQuery p
typedInsertQuery = typedInsertQuery' defaultConfig
insertQuery :: TableDerivable r => Pi r r' -> Relation p r' -> InsertQuery p
insertQuery = typedInsertQuery' defaultConfig derivedTable
{-# DEPRECATED derivedInsertQuery "use `insertQuery` instead of this." #-}
derivedInsertQuery :: TableDerivable r => Pi r r' -> Relation p r' -> InsertQuery p
derivedInsertQuery = insertQuery
instance Show (InsertQuery p) where
show = untypeInsertQuery
newtype Delete p = Delete { untypeDelete :: String }
unsafeTypedDelete :: String -> Delete p
unsafeTypedDelete = Delete
deleteSQL :: Config -> Table r -> Restriction p r -> String
deleteSQL config tbl r = showStringSQL $ deletePrefixSQL tbl <> sqlWhereFromRestriction config tbl r
typedDelete' :: Config -> Table r -> Restriction p r -> Delete p
typedDelete' config tbl r = unsafeTypedDelete $ deleteSQL config tbl r
{-# DEPRECATED typedDelete "use `typedDelete' defaultConfig` instead of this." #-}
typedDelete :: Table r -> Restriction p r -> Delete p
typedDelete = typedDelete' defaultConfig
restrictedTable :: TableDerivable r => Restriction p r -> Table r
restrictedTable = const derivedTable
delete' :: TableDerivable r => Config -> RestrictedStatement r (PlaceHolders p) -> Delete p
delete' config rc = typedDelete' config (restrictedTable rs) rs where
rs = restriction' rc
{-# DEPRECATED derivedDelete' "use `delete'` instead of this." #-}
derivedDelete' :: TableDerivable r => Config -> RestrictedStatement r (PlaceHolders p) -> Delete p
derivedDelete' = delete'
delete :: TableDerivable r => RestrictedStatement r (PlaceHolders p) -> Delete p
delete = delete' defaultConfig
deleteNoPH :: TableDerivable r => RestrictedStatement r () -> Delete ()
deleteNoPH rf = delete $ (return unitPH <*) . rf
{-# DEPRECATED derivedDelete "use `delete` instead of this." #-}
derivedDelete :: TableDerivable r => RestrictedStatement r (PlaceHolders p) -> Delete p
derivedDelete = delete
instance Show (Delete p) where
show = untypeDelete
class UntypeableNoFetch s where
untypeNoFetch :: s p -> String
instance UntypeableNoFetch Insert where
untypeNoFetch = untypeInsert
instance UntypeableNoFetch InsertQuery where
untypeNoFetch = untypeInsertQuery
instance UntypeableNoFetch Update where
untypeNoFetch = untypeUpdate
instance UntypeableNoFetch Delete where
untypeNoFetch = untypeDelete