module Database.Relational.Query.Relation (
Relation,
table, derivedRelation, tableOf,
relation, relation',
aggregateRelation, aggregateRelation',
UniqueRelation,
unsafeUnique, unUnique,
uniqueRelation', aggregatedUnique,
dump,
sqlFromRelationWith, sqlFromRelation,
query, query', queryMaybe, queryMaybe', queryList, queryList', queryScalar, queryScalar',
uniqueQuery', uniqueQueryMaybe',
JoinRestriction,
rightPh, leftPh,
inner', left', right', full',
inner, left, right, full,
on',
union, except, intersect,
unionAll, exceptAll, intersectAll,
union', except', intersect',
unionAll', exceptAll', intersectAll',
) where
import Control.Applicative ((<$>))
import Database.Relational.Query.Context (Flat, Aggregated)
import Database.Relational.Query.Monad.Type (ConfigureQuery, configureQuery, qualifyQuery)
import Database.Relational.Query.Monad.Class
(MonadQualify (liftQualify), MonadQualifyUnique (liftQualifyUnique), MonadQuery (unsafeSubQuery), on)
import Database.Relational.Query.Monad.Simple (QuerySimple, SimpleQuery)
import qualified Database.Relational.Query.Monad.Simple as Simple
import Database.Relational.Query.Monad.Aggregate (QueryAggregate, AggregatedQuery)
import qualified Database.Relational.Query.Monad.Aggregate as Aggregate
import Database.Relational.Query.Monad.Unique (QueryUnique)
import qualified Database.Relational.Query.Monad.Unique as Unique
import Database.Relational.Query.Component (Config, defaultConfig, Duplication (Distinct, All))
import Database.Relational.Query.Table (Table, TableDerivable, derivedTable)
import Database.Relational.Query.Internal.SQL (StringSQL, showStringSQL)
import Database.Relational.Query.Internal.Product (NodeAttr(Just', Maybe))
import Database.Relational.Query.Sub (SubQuery)
import qualified Database.Relational.Query.Sub as SubQuery
import Database.Relational.Query.Scalar (ScalarDegree)
import Database.Relational.Query.Pi (Pi)
import Database.Relational.Query.Projection
(Projection, ListProjection, unsafeListProjectionFromSubQuery)
import qualified Database.Relational.Query.Projection as Projection
import Database.Relational.Query.Projectable
(PlaceHolders, unitPlaceHolder, addPlaceHolders, unsafePlaceHolders, projectZip)
import Database.Relational.Query.ProjectableExtended ((!))
newtype Relation p r = SubQuery (ConfigureQuery SubQuery)
table :: Table r -> Relation () r
table = SubQuery . return . SubQuery.fromTable
derivedRelation :: TableDerivable r => Relation () r
derivedRelation = table derivedTable
tableOf :: TableDerivable r => Relation () r -> Table r
tableOf = const derivedTable
placeHoldersFromRelation :: Relation p r -> PlaceHolders p
placeHoldersFromRelation = const unsafePlaceHolders
subQueryQualifyFromRelation :: Relation p r -> ConfigureQuery SubQuery
subQueryQualifyFromRelation = d where
d (SubQuery qsub) = qsub
queryWithAttr :: MonadQualify ConfigureQuery m
=> NodeAttr -> Relation p r -> m (PlaceHolders p, Projection Flat r)
queryWithAttr attr = addPlaceHolders . run where
run rel = do
q <- liftQualify $ do
sq <- subQueryQualifyFromRelation rel
qualifyQuery sq
unsafeSubQuery attr q
query' :: MonadQualify ConfigureQuery m => Relation p r -> m (PlaceHolders p, Projection Flat r)
query' = queryWithAttr Just'
query :: MonadQualify ConfigureQuery m => Relation () r -> m (Projection Flat r)
query = fmap snd . query'
queryMaybe' :: MonadQualify ConfigureQuery m => Relation p r -> m (PlaceHolders p, Projection Flat (Maybe r))
queryMaybe' pr = do
(ph, pj) <- queryWithAttr Maybe pr
return (ph, Projection.just pj)
queryMaybe :: MonadQualify ConfigureQuery m => Relation () r -> m (Projection Flat (Maybe r))
queryMaybe = fmap snd . queryMaybe'
queryList0 :: MonadQualify ConfigureQuery m => Relation p r -> m (ListProjection (Projection c) r)
queryList0 = liftQualify
. fmap unsafeListProjectionFromSubQuery
. subQueryQualifyFromRelation
queryList' :: MonadQualify ConfigureQuery m
=> Relation p r
-> m (PlaceHolders p, ListProjection (Projection c) r)
queryList' rel = do
ql <- queryList0 rel
return (placeHoldersFromRelation rel, ql)
queryList :: MonadQualify ConfigureQuery m
=> Relation () r
-> m (ListProjection (Projection c) r)
queryList = queryList0
addUnitPH :: Functor f => f t -> f (PlaceHolders (), t)
addUnitPH = ((,) unitPlaceHolder <$>)
relation' :: SimpleQuery p r -> Relation p r
relation' = SubQuery . Simple.toSubQuery
relation :: QuerySimple (Projection Flat r) -> Relation () r
relation = relation' . addUnitPH
aggregateRelation' :: AggregatedQuery p r -> Relation p r
aggregateRelation' = SubQuery . Aggregate.toSubQuery
aggregateRelation :: QueryAggregate (Projection Aggregated r) -> Relation () r
aggregateRelation = aggregateRelation' . addUnitPH
type JoinRestriction a b = Projection Flat a -> Projection Flat b -> Projection Flat (Maybe Bool)
unsafeCastPlaceHolder :: Relation a r -> Relation b r
unsafeCastPlaceHolder = d where
d (SubQuery q) = SubQuery q
rightPh :: Relation ((), p) r -> Relation p r
rightPh = unsafeCastPlaceHolder
leftPh :: Relation (p, ()) r -> Relation p r
leftPh = unsafeCastPlaceHolder
join' :: (qa -> QuerySimple (PlaceHolders pa, Projection Flat a))
-> (qb -> QuerySimple (PlaceHolders pb, Projection Flat b))
-> qa
-> qb
-> [JoinRestriction a b]
-> Relation (pa, pb) (a, b)
join' qL qR r0 r1 rs = relation' $ do
(ph0, pj0) <- qL r0
(ph1, pj1) <- qR r1
sequence_ [ on $ f pj0 pj1 | f <- rs ]
return (ph0 `projectZip` ph1, pj0 `projectZip` pj1)
inner' :: Relation pa a
-> Relation pb b
-> [JoinRestriction a b]
-> Relation (pa, pb) (a, b)
inner' = join' query' query'
left' :: Relation pa a
-> Relation pb b
-> [JoinRestriction a (Maybe b)]
-> Relation (pa, pb) (a, Maybe b)
left' = join' query' queryMaybe'
right' :: Relation pa a
-> Relation pb b
-> [JoinRestriction (Maybe a) b]
-> Relation (pa, pb)(Maybe a, b)
right' = join' queryMaybe' query'
full' :: Relation pa a
-> Relation pb b
-> [JoinRestriction (Maybe a) (Maybe b)]
-> Relation (pa, pb) (Maybe a, Maybe b)
full' = join' queryMaybe' queryMaybe'
join :: (qa -> QuerySimple (Projection Flat a))
-> (qb -> QuerySimple (Projection Flat b))
-> qa
-> qb
-> [JoinRestriction a b]
-> Relation () (a, b)
join qL qR r0 r1 rs = relation $ do
pj0 <- qL r0
pj1 <- qR r1
sequence_ [ on $ f pj0 pj1 | f <- rs ]
return $ pj0 `projectZip` pj1
inner :: Relation () a
-> Relation () b
-> [JoinRestriction a b]
-> Relation () (a, b)
inner = join query query
left :: Relation () a
-> Relation () b
-> [JoinRestriction a (Maybe b)]
-> Relation () (a, Maybe b)
left = join query queryMaybe
right :: Relation () a
-> Relation () b
-> [JoinRestriction (Maybe a) b]
-> Relation () (Maybe a, b)
right = join queryMaybe query
full :: Relation () a
-> Relation () b
-> [JoinRestriction (Maybe a) (Maybe b)]
-> Relation () (Maybe a, Maybe b)
full = join queryMaybe queryMaybe
on' :: ([JoinRestriction a b] -> Relation pc (a, b))
-> [JoinRestriction a b]
-> Relation pc (a, b)
on' = ($)
infixl 8 `inner'`, `left'`, `right'`, `full'`, `inner`, `left`, `right`, `full`, `on'`
unsafeLiftAppend :: (SubQuery -> SubQuery -> SubQuery)
-> Relation p a
-> Relation q a
-> Relation r a
unsafeLiftAppend op a0 a1 = SubQuery $ do
s0 <- subQueryQualifyFromRelation a0
s1 <- subQueryQualifyFromRelation a1
return $ s0 `op` s1
liftAppend :: (SubQuery -> SubQuery -> SubQuery)
-> Relation () a
-> Relation () a
-> Relation () a
liftAppend = unsafeLiftAppend
union :: Relation () a -> Relation () a -> Relation () a
union = liftAppend $ SubQuery.union Distinct
unionAll :: Relation () a -> Relation () a -> Relation () a
unionAll = liftAppend $ SubQuery.union All
except :: Relation () a -> Relation () a -> Relation () a
except = liftAppend $ SubQuery.except Distinct
exceptAll :: Relation () a -> Relation () a -> Relation () a
exceptAll = liftAppend $ SubQuery.except All
intersect :: Relation () a -> Relation () a -> Relation () a
intersect = liftAppend $ SubQuery.intersect Distinct
intersectAll :: Relation () a -> Relation () a -> Relation () a
intersectAll = liftAppend $ SubQuery.intersect All
liftAppend' :: (SubQuery -> SubQuery -> SubQuery)
-> Relation p a
-> Relation q a
-> Relation (p, q) a
liftAppend' = unsafeLiftAppend
union' :: Relation p a -> Relation q a -> Relation (p, q) a
union' = liftAppend' $ SubQuery.union Distinct
unionAll' :: Relation p a -> Relation q a -> Relation (p, q) a
unionAll' = liftAppend' $ SubQuery.union All
except' :: Relation p a -> Relation q a -> Relation (p, q) a
except' = liftAppend' $ SubQuery.except Distinct
exceptAll' :: Relation p a -> Relation q a -> Relation (p, q) a
exceptAll' = liftAppend' $ SubQuery.except All
intersect' :: Relation p a -> Relation q a -> Relation (p, q) a
intersect' = liftAppend' $ SubQuery.intersect Distinct
intersectAll' :: Relation p a -> Relation q a -> Relation (p, q) a
intersectAll' = liftAppend' $ SubQuery.intersect All
infixl 7 `union`, `except`, `unionAll`, `exceptAll`
infixl 8 `intersect`, `intersectAll`
infixl 7 `union'`, `except'`, `unionAll'`, `exceptAll'`
infixl 8 `intersect'`, `intersectAll'`
sqlFromRelationWith :: Relation p r -> Config -> StringSQL
sqlFromRelationWith (SubQuery qsub) = configureQuery $ SubQuery.showSQL <$> qsub
sqlFromRelation :: Relation p r -> StringSQL
sqlFromRelation = (`sqlFromRelationWith` defaultConfig)
dump :: Relation p r -> String
dump = show . (`configureQuery` defaultConfig) . subQueryQualifyFromRelation
instance Show (Relation p r) where
show = showStringSQL . sqlFromRelation
newtype UniqueRelation p c r = Unique (Relation p r)
unsafeUnique :: Relation p r -> UniqueRelation p c r
unsafeUnique = Unique
unUnique :: UniqueRelation p c r -> Relation p r
unUnique (Unique r) = r
uniqueQueryWithAttr :: MonadQualifyUnique ConfigureQuery m
=> NodeAttr
-> UniqueRelation p c r
-> m (PlaceHolders p, Projection c r)
uniqueQueryWithAttr attr = addPlaceHolders . run where
run rel = do
q <- liftQualifyUnique $ do
sq <- subQueryQualifyFromRelation (unUnique rel)
qualifyQuery sq
Projection.unsafeChangeContext <$> unsafeSubQuery attr q
uniqueQuery' :: MonadQualifyUnique ConfigureQuery m
=> UniqueRelation p c r
-> m (PlaceHolders p, Projection c r)
uniqueQuery' = uniqueQueryWithAttr Just'
uniqueQueryMaybe' :: MonadQualifyUnique ConfigureQuery m
=> UniqueRelation p c r
-> m (PlaceHolders p, Projection c (Maybe r))
uniqueQueryMaybe' pr = do
(ph, pj) <- uniqueQueryWithAttr Maybe pr
return (ph, Projection.just pj)
uniqueRelation' :: QueryUnique (PlaceHolders p, Projection c r) -> UniqueRelation p c r
uniqueRelation' = unsafeUnique . SubQuery . Unique.toSubQuery
aggregatedUnique :: Relation ph r
-> Pi r a
-> (Projection Flat a -> Projection Aggregated b)
-> UniqueRelation ph Flat b
aggregatedUnique rel k ag = unsafeUnique . aggregateRelation' $ do
(ph, a) <- query' rel
return (ph, ag $ a ! k)
queryScalar' :: (MonadQualify ConfigureQuery m, ScalarDegree r)
=> UniqueRelation p c r
-> m (PlaceHolders p, Projection c (Maybe r))
queryScalar' ur =
addPlaceHolders . liftQualify $
Projection.unsafeFromScalarSubQuery <$> subQueryQualifyFromRelation (unUnique ur)
queryScalar :: (MonadQualify ConfigureQuery m, ScalarDegree r)
=> UniqueRelation () c r
-> m (Projection c (Maybe r))
queryScalar = fmap snd . queryScalar'