module Database.Relational.Query.Type (
Query (..), unsafeTypedQuery,
relationalQuery', relationalQuery,
relationalQuerySQL,
KeyUpdate (..), unsafeTypedKeyUpdate, typedKeyUpdate, typedKeyUpdateTable, derivedKeyUpdate,
Update (..), unsafeTypedUpdate, typedUpdate', typedUpdate, derivedUpdate', derivedUpdate,
typedUpdateAllColumn, derivedUpdateAllColumn', derivedUpdateAllColumn,
restrictedUpdateAllColumn, restrictedUpdateTableAllColumn,
updateSQL,
Insert (..), untypeChunkInsert, chunkSizeOfInsert,
unsafeTypedInsert', unsafeTypedInsert, typedInsert', typedInsert, derivedInsert,
typedInsertValue', typedInsertValue, derivedInsertValue', derivedInsertValue,
InsertQuery (..), unsafeTypedInsertQuery, typedInsertQuery', typedInsertQuery, derivedInsertQuery,
insertQuerySQL,
Delete (..), unsafeTypedDelete, typedDelete', typedDelete, derivedDelete', derivedDelete,
deleteSQL,
UntypeableNoFetch (..)
) where
import Data.Monoid ((<>))
import Database.Record (PersistableWidth)
import Database.Relational.Query.Internal.Config (Config, defaultConfig)
import Database.Relational.Query.Internal.SQL (showStringSQL)
import Database.Relational.Query.Monad.BaseType (Relation, sqlFromRelationWith)
import Database.Relational.Query.Monad.Restrict (RestrictedStatement)
import Database.Relational.Query.Monad.Assign (AssignStatement)
import Database.Relational.Query.Monad.Register (Register)
import Database.Relational.Query.Relation (tableOf)
import Database.Relational.Query.Effect
(Restriction, restriction', UpdateTarget, updateTarget', liftTargetAllColumn', InsertTarget, insertTarget',
sqlWhereFromRestriction, sqlFromUpdateTarget, piRegister, sqlChunkFromInsertTarget, sqlFromInsertTarget)
import Database.Relational.Query.Pi (Pi)
import Database.Relational.Query.Table (Table, TableDerivable, derivedTable)
import Database.Relational.Query.Projectable (PlaceHolders)
import Database.Relational.Query.SQL
(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
derivedKeyUpdate :: TableDerivable r => Pi r p -> KeyUpdate p r
derivedKeyUpdate = typedKeyUpdate derivedTable
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
typedUpdate :: Table r -> UpdateTarget p r -> Update p
typedUpdate = typedUpdate' defaultConfig
targetTable :: TableDerivable r => UpdateTarget p r -> Table r
targetTable = const derivedTable
derivedUpdate' :: TableDerivable r => Config -> AssignStatement r (PlaceHolders p) -> Update p
derivedUpdate' config utc = typedUpdate' config (targetTable ut) ut where
ut = updateTarget' utc
derivedUpdate :: TableDerivable r => AssignStatement r (PlaceHolders p) -> Update p
derivedUpdate = derivedUpdate' defaultConfig
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 tbl r = typedUpdate tbl $ liftTargetAllColumn' r
derivedUpdateAllColumn' :: (PersistableWidth r, TableDerivable r)
=> Config
-> RestrictedStatement r (PlaceHolders p)
-> Update (r, p)
derivedUpdateAllColumn' config = typedUpdateAllColumn' config derivedTable .restriction'
derivedUpdateAllColumn :: (PersistableWidth r, TableDerivable r)
=> RestrictedStatement r (PlaceHolders p)
-> Update (r, p)
derivedUpdateAllColumn = derivedUpdateAllColumn' defaultConfig
restrictedUpdateAllColumn :: PersistableWidth r
=> Table r
-> RestrictedStatement r (PlaceHolders p)
-> Update (r, p)
restrictedUpdateAllColumn tbl = typedUpdateAllColumn tbl . restriction'
restrictedUpdateTableAllColumn :: (PersistableWidth r, TableDerivable r)
=> Relation () r
-> RestrictedStatement r (PlaceHolders p)
-> Update (r, p)
restrictedUpdateTableAllColumn = restrictedUpdateAllColumn . tableOf
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
typedInsert :: PersistableWidth r => Table r -> Pi r r' -> Insert r'
typedInsert = typedInsert' defaultConfig
derivedInsert :: (PersistableWidth r, TableDerivable r) => Pi r r' -> Insert r'
derivedInsert = typedInsert derivedTable
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
typedInsertValue :: Table r -> InsertTarget p r -> Insert p
typedInsertValue = typedInsertValue' defaultConfig
derivedInsertValue' :: TableDerivable r => Config -> Register r (PlaceHolders p) -> Insert p
derivedInsertValue' config rs = typedInsertValue' config (rt rs) $ insertTarget' rs
where
rt :: TableDerivable r => Register r (PlaceHolders p) -> Table r
rt = const derivedTable
derivedInsertValue :: TableDerivable r => Register r (PlaceHolders p) -> Insert p
derivedInsertValue = derivedInsertValue' 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
typedInsertQuery :: Table r -> Pi r r' -> Relation p r' -> InsertQuery p
typedInsertQuery = typedInsertQuery' defaultConfig
derivedInsertQuery :: TableDerivable r => Pi r r' -> Relation p r' -> InsertQuery p
derivedInsertQuery = typedInsertQuery derivedTable
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
typedDelete :: Table r -> Restriction p r -> Delete p
typedDelete = typedDelete' defaultConfig
restrictedTable :: TableDerivable r => Restriction p r -> Table r
restrictedTable = const derivedTable
derivedDelete' :: TableDerivable r => Config -> RestrictedStatement r (PlaceHolders p) -> Delete p
derivedDelete' config rc = typedDelete' config (restrictedTable rs) rs where
rs = restriction' rc
derivedDelete :: TableDerivable r => RestrictedStatement r (PlaceHolders p) -> Delete p
derivedDelete = derivedDelete' defaultConfig
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