module Database.Relational.Type (
Query (..), unsafeTypedQuery,
relationalQuery_,
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', 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 Data.Monoid ((<>))
import Data.Functor.ProductIsomorphic (peRight)
import Database.Record (PersistableWidth)
import Database.Relational.Internal.Config (Config, defaultConfig)
import Database.Relational.Internal.ContextType (Flat)
import Database.Relational.Internal.String (showStringSQL)
import Database.Relational.SqlSyntax (Record)
import Database.Relational.Monad.BaseType (Relation, sqlFromRelationWith)
import Database.Relational.Monad.Restrict (Restrict)
import Database.Relational.Monad.Assign (Assign)
import Database.Relational.Monad.Register (Register)
import Database.Relational.Relation (tableOf)
import Database.Relational.Effect
(liftTargetAllColumn', InsertTarget, insertTarget',
deleteFromRestriction, updateFromUpdateTarget, 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, )
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_ :: Config -> Relation p r -> QuerySuffix -> Query p r
relationalQuery_ config rel qsuf =
unsafeTypedQuery $ relationalQuerySQL config rel qsuf
relationalQuery' :: Relation p r -> QuerySuffix -> Query p r
relationalQuery' = relationalQuery_ defaultConfig
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 -> (Record Flat r -> Assign r (PlaceHolders p)) -> String
updateSQL config tbl ut = showStringSQL $ updateFromUpdateTarget config tbl ut
typedUpdate' :: Config -> Table r -> (Record Flat r -> Assign r (PlaceHolders p)) -> Update p
typedUpdate' config tbl ut = unsafeTypedUpdate $ updateSQL config tbl ut
{-# DEPRECATED typedUpdate "use `typedUpdate' defaultConfig` instead of this." #-}
typedUpdate :: Table r -> (Record Flat r -> Assign r (PlaceHolders p)) -> Update p
typedUpdate = typedUpdate' defaultConfig
targetTable :: TableDerivable r => (Record Flat r -> Assign r (PlaceHolders p)) -> Table r
targetTable = const derivedTable
update' :: TableDerivable r => Config -> (Record Flat r -> Assign r (PlaceHolders p)) -> Update p
update' config ac = typedUpdate' config (targetTable ac) ac
{-# DEPRECATED derivedUpdate' "use `update'` instead of this." #-}
derivedUpdate' :: TableDerivable r => Config -> (Record Flat r -> Assign r (PlaceHolders p)) -> Update p
derivedUpdate' = update'
update :: TableDerivable r => (Record Flat r -> Assign r (PlaceHolders p)) -> Update p
update = update' defaultConfig
updateNoPH :: TableDerivable r => (Record Flat r -> Assign r ()) -> Update ()
updateNoPH af = update $ (>> return unitPH) . af
{-# DEPRECATED derivedUpdate "use `update` instead of this." #-}
derivedUpdate :: TableDerivable r => (Record Flat r -> Assign r (PlaceHolders p)) -> Update p
derivedUpdate = update
typedUpdateAllColumn' :: PersistableWidth r
=> Config
-> Table r
-> (Record Flat r -> Restrict (PlaceHolders p))
-> Update (r, p)
typedUpdateAllColumn' config tbl r = typedUpdate' config tbl $ liftTargetAllColumn' r
typedUpdateAllColumn :: PersistableWidth r
=> Table r
-> (Record Flat r -> Restrict (PlaceHolders p))
-> Update (r, p)
typedUpdateAllColumn = typedUpdateAllColumn' defaultConfig
updateAllColumn' :: (PersistableWidth r, TableDerivable r)
=> Config
-> (Record Flat r -> Restrict (PlaceHolders p))
-> Update (r, p)
updateAllColumn' config = typedUpdateAllColumn' config derivedTable
{-# DEPRECATED derivedUpdateAllColumn' "use `updateAllColumn'` instead of this." #-}
derivedUpdateAllColumn' :: (PersistableWidth r, TableDerivable r)
=> Config
-> (Record Flat r -> Restrict (PlaceHolders p))
-> Update (r, p)
derivedUpdateAllColumn' = updateAllColumn'
updateAllColumn :: (PersistableWidth r, TableDerivable r)
=> (Record Flat r -> Restrict (PlaceHolders p))
-> Update (r, p)
updateAllColumn = updateAllColumn' defaultConfig
updateAllColumnNoPH :: (PersistableWidth r, TableDerivable r)
=> (Record Flat r -> Restrict ())
-> Update r
updateAllColumnNoPH =
typedUpdate' defaultConfig derivedTable . (fmap peRight .) . liftTargetAllColumn' . ((>> return unitPH) .)
{-# DEPRECATED derivedUpdateAllColumn "use `updateAllColumn` instead of this." #-}
derivedUpdateAllColumn :: (PersistableWidth r, TableDerivable r)
=> (Record Flat r -> Restrict (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 => Config -> Pi r r' -> Relation p r' -> InsertQuery p
insertQuery' config = typedInsertQuery' config derivedTable
insertQuery :: TableDerivable r => Pi r r' -> Relation p r' -> InsertQuery p
insertQuery = insertQuery' defaultConfig
{-# 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 -> (Record Flat r -> Restrict (PlaceHolders p)) -> String
deleteSQL config tbl r = showStringSQL $ deleteFromRestriction config tbl r
typedDelete' :: Config -> Table r -> (Record Flat r -> Restrict (PlaceHolders p)) -> Delete p
typedDelete' config tbl r = unsafeTypedDelete $ deleteSQL config tbl r
{-# DEPRECATED typedDelete "use `typedDelete' defaultConfig` instead of this." #-}
typedDelete :: Table r -> (Record Flat r -> Restrict (PlaceHolders p)) -> Delete p
typedDelete = typedDelete' defaultConfig
restrictedTable :: TableDerivable r => (Record Flat r -> Restrict (PlaceHolders p)) -> Table r
restrictedTable = const derivedTable
delete' :: TableDerivable r => Config -> (Record Flat r -> Restrict (PlaceHolders p)) -> Delete p
delete' config rc = typedDelete' config (restrictedTable rc) rc
{-# DEPRECATED derivedDelete' "use `delete'` instead of this." #-}
derivedDelete' :: TableDerivable r => Config -> (Record Flat r -> Restrict (PlaceHolders p)) -> Delete p
derivedDelete' = delete'
delete :: TableDerivable r => (Record Flat r -> Restrict (PlaceHolders p)) -> Delete p
delete = delete' defaultConfig
deleteNoPH :: TableDerivable r => (Record Flat r -> Restrict ()) -> Delete ()
deleteNoPH rf = delete $ (>> return unitPH) . rf
{-# DEPRECATED derivedDelete "use `delete` instead of this." #-}
derivedDelete :: TableDerivable r => (Record Flat r -> Restrict (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