module Database.Relational.Query.Type (
Query (..), unsafeTypedQuery,
relationalQuery', relationalQuery,
relationalQuerySQL,
KeyUpdate (..), unsafeTypedKeyUpdate, typedKeyUpdate, typedKeyUpdateTable,
Update (..), unsafeTypedUpdate, typedUpdate', typedUpdate, derivedUpdate', derivedUpdate,
typedUpdateAllColumn, restrictedUpdateAllColumn, restrictedUpdateTableAllColumn,
updateSQL,
Insert (..), unsafeTypedInsert', unsafeTypedInsert, typedInsert', typedInsert, derivedInsert,
InsertQuery (..), unsafeTypedInsertQuery, typedInsertQuery, derivedInsertQuery,
insertQuerySQL,
Delete (..), unsafeTypedDelete, typedDelete', typedDelete, derivedDelete', derivedDelete,
deleteSQL,
UntypeableNoFetch (..)
) where
import Data.Monoid ((<>))
import Database.Record (PersistableWidth)
import Database.Relational.Query.Internal.SQL (showStringSQL)
import Database.Relational.Query.Relation (Relation, sqlFromRelationWith, tableOf)
import Database.Relational.Query.Effect
(Restriction, RestrictionContext, restriction',
UpdateTarget, UpdateTargetContext, updateTarget', liftTargetAllColumn',
sqlWhereFromRestriction, sqlFromUpdateTarget)
import Database.Relational.Query.Pi (Pi)
import qualified Database.Relational.Query.Pi as Pi
import Database.Relational.Query.Component (Config (chunksInsertSize), defaultConfig)
import Database.Relational.Query.Table (Table, TableDerivable, derivedTable)
import Database.Relational.Query.SQL
(QuerySuffix, showsQuerySuffix, insertPrefixSQL, insertSQL, insertSizedChunkSQL,
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
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 -> UpdateTargetContext p r -> Update p
derivedUpdate' config utc = typedUpdate' config (targetTable ut) ut where
ut = updateTarget' utc
derivedUpdate :: TableDerivable r => UpdateTargetContext p r -> Update p
derivedUpdate = derivedUpdate' defaultConfig
typedUpdateAllColumn :: PersistableWidth r
=> Table r
-> Restriction p r
-> Update (r, p)
typedUpdateAllColumn tbl r = typedUpdate tbl $ liftTargetAllColumn' r
restrictedUpdateAllColumn :: PersistableWidth r
=> Table r
-> RestrictionContext p r
-> Update (r, p)
restrictedUpdateAllColumn tbl = typedUpdateAllColumn tbl . restriction'
restrictedUpdateTableAllColumn :: (PersistableWidth r, TableDerivable r)
=> Relation () r
-> RestrictionContext p r
-> Update (r, p)
restrictedUpdateTableAllColumn = restrictedUpdateAllColumn . tableOf
instance Show (Update p) where
show = untypeUpdate
data Insert a =
Insert
{ untypeInsert :: String
, untypeChunkInsert :: String
, chunkSizeOfInsert :: Int
}
unsafeTypedInsert' :: String -> String -> Int -> Insert a
unsafeTypedInsert' = Insert
unsafeTypedInsert :: String -> Insert a
unsafeTypedInsert q = unsafeTypedInsert' q q 1
typedInsert' :: Config -> Table r -> Pi r r' -> Insert r'
typedInsert' config tbl pi' = unsafeTypedInsert' (insertSQL pi' tbl) ci n where
(ci, n) = insertSizedChunkSQL pi' tbl $ chunksInsertSize config
typedInsert :: Table r -> Pi r r' -> Insert r'
typedInsert = typedInsert' defaultConfig
derivedInsert :: TableDerivable r => Insert r
derivedInsert = typedInsert derivedTable Pi.id'
instance Show (Insert a) where
show = untypeInsert
newtype InsertQuery p = InsertQuery { untypeInsertQuery :: String }
unsafeTypedInsertQuery :: String -> InsertQuery p
unsafeTypedInsertQuery = InsertQuery
insertQuerySQL :: TableDerivable r => Config -> Pi r r' -> Relation p r' -> String
insertQuerySQL config pi' rel = showStringSQL $ insertPrefixSQL pi' derivedTable <> sqlFromRelationWith rel config
typedInsertQuery :: TableDerivable r => Pi r r' -> Relation p r' -> InsertQuery p
typedInsertQuery pi' rel = unsafeTypedInsertQuery $ insertQuerySQL defaultConfig pi' rel
derivedInsertQuery :: TableDerivable r => Relation p r -> InsertQuery p
derivedInsertQuery = typedInsertQuery Pi.id'
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 -> RestrictionContext p r -> Delete p
derivedDelete' config rc = typedDelete' config (restrictedTable rs) rs where
rs = restriction' rc
derivedDelete :: TableDerivable r => RestrictionContext p r -> 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 Update where
untypeNoFetch = untypeUpdate
instance UntypeableNoFetch Delete where
untypeNoFetch = untypeDelete