mirror of
https://github.com/khibino/haskell-relational-record.git
synced 2024-12-15 14:53:28 +03:00
Update placeholder propergation method.
This commit is contained in:
parent
0def28fa95
commit
3f8aa4808b
@ -15,7 +15,7 @@ import qualified Database.Relational.Query.Table as Table
|
||||
import Database.Relational.Query.Projectable (placeholder, (.=.))
|
||||
import Database.Relational.Query.ProjectableExtended ((!))
|
||||
import Database.Relational.Query.Monad.Class (wheres)
|
||||
import Database.Relational.Query.Relation (Relation, relation, query)
|
||||
import Database.Relational.Query.Relation (Relation, relation', query)
|
||||
import Database.Relational.Query.Constraint
|
||||
(Key, Primary, Unique, projectionKey, uniqueKey,
|
||||
HasConstraintKey(constraintKey))
|
||||
@ -26,10 +26,11 @@ unique :: PersistableWidth p
|
||||
=> Key Unique a p
|
||||
-> Relation () a
|
||||
-> Relation p a
|
||||
unique uk rel = relation $ do
|
||||
unique uk rel = relation' $ do
|
||||
q <- query rel
|
||||
wheres $ q ! projectionKey uk .=. placeholder
|
||||
return q
|
||||
let (param, ph) = placeholder
|
||||
wheres $ q ! projectionKey uk .=. ph
|
||||
return (param, q)
|
||||
|
||||
primary' :: PersistableWidth p
|
||||
=> Key Primary a p
|
||||
|
@ -89,9 +89,6 @@ instance SqlProjectable Aggregation where
|
||||
valueNull :: SqlProjectable p => p (Maybe a)
|
||||
valueNull = unsafeProjectSql "NULL"
|
||||
|
||||
placeholder :: SqlProjectable p => p t
|
||||
placeholder = unsafeProjectSql "?"
|
||||
|
||||
value :: (ShowConstantSQL t, SqlProjectable p) => t -> p t
|
||||
value = unsafeProjectSql . showConstantSQL
|
||||
|
||||
@ -220,6 +217,9 @@ addPlaceHolders = fmap ((,) PlaceHolders)
|
||||
unsafeCastPlaceHolders :: PlaceHolders a -> PlaceHolders b
|
||||
unsafeCastPlaceHolders PlaceHolders = PlaceHolders
|
||||
|
||||
placeholder :: SqlProjectable p => (PlaceHolders t, p t)
|
||||
placeholder = (PlaceHolders, unsafeProjectSql "?")
|
||||
|
||||
|
||||
class ProjectableZip p where
|
||||
projectZip :: p a -> p b -> p (a, b)
|
||||
|
@ -14,8 +14,6 @@ module Database.Relational.Query.Relation (
|
||||
|
||||
sqlFromRelation,
|
||||
|
||||
-- subQueryFromRelation,
|
||||
|
||||
nested, width
|
||||
) where
|
||||
|
||||
@ -85,13 +83,13 @@ queryMaybe' pr = do
|
||||
queryMaybe :: MonadQuery m => Relation () r -> m (Projection (Maybe r))
|
||||
queryMaybe = fmap snd . queryMaybe'
|
||||
|
||||
relation :: QuerySimple (Projection r) -> Relation p r
|
||||
relation :: QuerySimple (Projection r) -> Relation () r
|
||||
relation = SimpleRel
|
||||
|
||||
relation' :: QuerySimple (PlaceHolders p, Projection r) -> Relation p r
|
||||
relation' = SimpleRel . fmap snd
|
||||
|
||||
aggregateRelation :: QueryAggregate (Aggregation r) -> Relation p r
|
||||
aggregateRelation :: QueryAggregate (Aggregation r) -> Relation () r
|
||||
aggregateRelation = AggregateRel
|
||||
|
||||
aggregateRelation' :: QueryAggregate (PlaceHolders p, Aggregation r) -> Relation p r
|
||||
|
@ -18,8 +18,8 @@ import Database.Record.Instances ()
|
||||
|
||||
import Database.Relational.Query.Type (fromRelation)
|
||||
import Database.Relational.Query
|
||||
(Query, Relation, query, relation,
|
||||
wheres, (.=.), (!), placeholder, asc, value)
|
||||
(Query, Relation, query, relation',
|
||||
wheres, (.=.), (!), (><), placeholder, asc, value)
|
||||
|
||||
import Control.Applicative ((<|>))
|
||||
|
||||
@ -62,19 +62,21 @@ getType mapFromSql rec = do
|
||||
else [t| Maybe $(typ) |]
|
||||
|
||||
columnsRelationFromTable :: Relation (String, String) Columns
|
||||
columnsRelationFromTable = relation $ do
|
||||
columnsRelationFromTable = relation' $ do
|
||||
c <- query columns
|
||||
wheres $ c ! Columns.tabschema' .=. placeholder
|
||||
wheres $ c ! Columns.tabname' .=. placeholder
|
||||
let (schemaParam, schemaPh) = placeholder
|
||||
(nameParam , namePh) = placeholder
|
||||
wheres $ c ! Columns.tabschema' .=. schemaPh
|
||||
wheres $ c ! Columns.tabname' .=. namePh
|
||||
asc $ c ! Columns.colno'
|
||||
return c
|
||||
return (schemaParam >< nameParam, c)
|
||||
|
||||
columnsQuerySQL :: Query (String, String) Columns
|
||||
columnsQuerySQL = fromRelation columnsRelationFromTable
|
||||
|
||||
|
||||
primaryKeyRelation :: Relation (String, String) String
|
||||
primaryKeyRelation = relation $ do
|
||||
primaryKeyRelation = relation' $ do
|
||||
cons <- query tabconst
|
||||
key <- query keycoluse
|
||||
col <- query columns
|
||||
@ -88,10 +90,13 @@ primaryKeyRelation = relation $ do
|
||||
wheres $ cons ! Tabconst.type' .=. value "P"
|
||||
wheres $ cons ! Tabconst.enforced' .=. value "Y"
|
||||
|
||||
wheres $ cons ! Tabconst.tabschema' .=. placeholder
|
||||
wheres $ cons ! Tabconst.tabname' .=. placeholder
|
||||
let (schemaParam, schemaPh) = placeholder
|
||||
(nameParam , namePh) = placeholder
|
||||
|
||||
return $ key ! Keycoluse.colname'
|
||||
wheres $ cons ! Tabconst.tabschema' .=. schemaPh
|
||||
wheres $ cons ! Tabconst.tabname' .=. namePh
|
||||
|
||||
return (schemaParam >< nameParam, key ! Keycoluse.colname')
|
||||
|
||||
primaryKeyQuerySQL :: Query (String, String) String
|
||||
primaryKeyQuerySQL = fromRelation primaryKeyRelation
|
||||
|
@ -24,7 +24,7 @@ import Database.Record.Instances ()
|
||||
|
||||
import Database.Relational.Query.Type (fromRelation)
|
||||
import Database.Relational.Query
|
||||
(Query, Relation, query, relation, query', relation', expr,
|
||||
(Query, Relation, query, query', relation', expr,
|
||||
wheres, (.=.), (.>.), in', values, (!), just,
|
||||
placeholder, asc, value, unsafeProjectSql, (><))
|
||||
|
||||
@ -96,15 +96,18 @@ getType mapFromSql column@(pgAttr, pgTyp) = do
|
||||
else [t| Maybe $typ |]
|
||||
|
||||
relOidRelation :: Relation (String, String) Int32
|
||||
relOidRelation = relation $ do
|
||||
relOidRelation = relation' $ do
|
||||
nsp <- query pgNamespace
|
||||
cls <- query pgClass
|
||||
|
||||
wheres $ cls ! Class.relnamespace' .=. nsp ! Namespace.oid'
|
||||
wheres $ nsp ! Namespace.nspname' .=. placeholder
|
||||
wheres $ cls ! Class.relname' .=. placeholder
|
||||
let (nspParam, nspPh) = placeholder
|
||||
(relParam, relPh) = placeholder
|
||||
|
||||
return $ cls ! Class.oid'
|
||||
wheres $ cls ! Class.relnamespace' .=. nsp ! Namespace.oid'
|
||||
wheres $ nsp ! Namespace.nspname' .=. nspPh
|
||||
wheres $ cls ! Class.relname' .=. relPh
|
||||
|
||||
return (nspParam >< relParam, cls ! Class.oid')
|
||||
|
||||
attributeRelation :: Relation (String, String) PgAttribute
|
||||
attributeRelation = relation' $ do
|
||||
|
Loading…
Reference in New Issue
Block a user