mirror of
https://github.com/khibino/haskell-relational-record.git
synced 2024-12-15 06:43:04 +03:00
Apply query context tag types.
This commit is contained in:
Kei Hibino
parent
3dc3098378
commit
6885e3bb1a
@ -36,7 +36,6 @@ library
|
||||
Database.Relational.Query.Expr.Unsafe
|
||||
Database.Relational.Query.Sub
|
||||
Database.Relational.Query.Projection
|
||||
Database.Relational.Query.Aggregation
|
||||
Database.Relational.Query.Monad.Class
|
||||
Database.Relational.Query.Monad.Trans.Ordering
|
||||
Database.Relational.Query.Monad.Trans.Aggregating
|
||||
|
||||
@ -16,7 +16,6 @@ module Database.Relational.Query (
|
||||
module Database.Relational.Query.Expr,
|
||||
module Database.Relational.Query.Sub,
|
||||
module Database.Relational.Query.Projection,
|
||||
module Database.Relational.Query.Aggregation,
|
||||
module Database.Relational.Query.Projectable,
|
||||
module Database.Relational.Query.ProjectableExtended,
|
||||
module Database.Relational.Query.Monad.Class,
|
||||
@ -45,7 +44,6 @@ import Database.Relational.Query.Constraint
|
||||
import Database.Relational.Query.Expr hiding (fromJust, just)
|
||||
import Database.Relational.Query.Sub (SubQuery, unitSQL, queryWidth)
|
||||
import Database.Relational.Query.Projection (Projection)
|
||||
import Database.Relational.Query.Aggregation (Aggregation)
|
||||
import Database.Relational.Query.Projectable
|
||||
import Database.Relational.Query.ProjectableExtended
|
||||
import Database.Relational.Query.Monad.Class
|
||||
|
||||
@ -1,85 +0,0 @@
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
|
||||
-- |
|
||||
-- Module : Database.Relational.Query.Aggregation
|
||||
-- Copyright : 2013 Kei Hibino
|
||||
-- License : BSD3
|
||||
--
|
||||
-- Maintainer : ex8k.hibino@gmail.com
|
||||
-- Stability : experimental
|
||||
-- Portability : unknown
|
||||
--
|
||||
-- This module defines aggregated query projection type structure and interfaces.
|
||||
module Database.Relational.Query.Aggregation (
|
||||
-- * Projection definition for Aggregated query
|
||||
Aggregation,
|
||||
unsafeProjection,
|
||||
mapAggregation,
|
||||
|
||||
unsafeFromProjection,
|
||||
|
||||
-- * Aggregated Query Projections
|
||||
compose,
|
||||
|
||||
pi, piMaybe, piMaybe',
|
||||
|
||||
flattenMaybe, just
|
||||
) where
|
||||
|
||||
|
||||
import Prelude hiding (pi)
|
||||
|
||||
import Database.Relational.Query.Projection (Projection)
|
||||
import qualified Database.Relational.Query.Projection as Projection
|
||||
import Database.Relational.Query.Pi (Pi)
|
||||
|
||||
|
||||
-- | Projection for aggregated query.
|
||||
newtype Aggregation r = Aggregation (Projection r)
|
||||
|
||||
-- | Get projection of normal query.
|
||||
unsafeProjection :: Aggregation r -> Projection r
|
||||
unsafeProjection (Aggregation p) = p
|
||||
|
||||
-- | Map from 'Projection' into 'Aggregation'.
|
||||
mapAggregation :: (Projection a -> Projection b) -> Aggregation a -> Aggregation b
|
||||
mapAggregation f = Aggregation . f . unsafeProjection
|
||||
|
||||
-- | Unsafely make 'Aggregation' from 'Projection'.
|
||||
unsafeFromProjection :: Projection r -> Aggregation r
|
||||
unsafeFromProjection = Aggregation
|
||||
|
||||
-- | Concatenate 'Aggregation'.
|
||||
compose :: Aggregation a -> Aggregation b -> Aggregation (c a b)
|
||||
compose (Aggregation a) (Aggregation b) = Aggregation $ a `Projection.compose` b
|
||||
|
||||
-- | Map Projection path into Aggregation.
|
||||
definePi :: (Projection a -> Pi a' b' -> Projection b) -> Aggregation a -> Pi a' b' -> Aggregation b
|
||||
definePi (!!!) p pi' = mapAggregation (!!! pi') p
|
||||
|
||||
-- | Trace projection path to get smaller 'Aggregation'.
|
||||
pi :: Aggregation a -- ^ Source projection. 'Maybe' type
|
||||
-> Pi a b -- ^ Projection path
|
||||
-> Aggregation b -- ^ Narrower projection
|
||||
pi = definePi Projection.pi
|
||||
|
||||
-- | Trace projection path to get smaller 'Aggregation'. From 'Maybe' type to 'Maybe' type.
|
||||
piMaybe :: Aggregation (Maybe a) -- ^ Source projection. 'Maybe' type
|
||||
-> Pi a b -- ^ Projection path
|
||||
-> Aggregation (Maybe b) -- ^ Narrower projection. 'Maybe' type result
|
||||
piMaybe = definePi Projection.piMaybe
|
||||
|
||||
-- | Trace projection path to get smaller 'Aggregation'. From 'Maybe' type to 'Maybe' type.
|
||||
-- Projection path's leaf is 'Maybe' case.
|
||||
piMaybe' :: Aggregation (Maybe a) -- ^ Source projection. 'Maybe' type
|
||||
-> Pi a (Maybe b) -- ^ Projection path. 'Maybe' type leaf
|
||||
-> Aggregation (Maybe b) -- ^ Narrower projection. 'Maybe' type result
|
||||
piMaybe' = definePi Projection.piMaybe'
|
||||
|
||||
-- | Composite nested 'Maybe' on projection phantom type.
|
||||
flattenMaybe :: Aggregation (Maybe (Maybe a)) -> Aggregation (Maybe a)
|
||||
flattenMaybe = mapAggregation Projection.flattenMaybe
|
||||
|
||||
-- | Cast into 'Maybe' on projection phantom type.
|
||||
just :: Aggregation a -> Aggregation (Maybe a)
|
||||
just = mapAggregation Projection.just
|
||||
@ -1,5 +1,3 @@
|
||||
{-# LANGUAGE KindSignatures #-}
|
||||
|
||||
-- |
|
||||
-- Module : Database.Relational.Query.Expr.Unsafe
|
||||
-- Copyright : 2013 Kei Hibino
|
||||
@ -17,7 +15,7 @@ module Database.Relational.Query.Expr.Unsafe (
|
||||
) where
|
||||
|
||||
-- | Phantom typed SQL expression object. Project from projection type 'p'.
|
||||
newtype Expr (p :: * -> *) a = Expr (String)
|
||||
newtype Expr p a = Expr String
|
||||
|
||||
-- | Get SQL expression from typed object.
|
||||
showExpr :: Expr p t -> String
|
||||
|
||||
@ -20,10 +20,10 @@ module Database.Relational.Query.Internal.Product (
|
||||
) where
|
||||
|
||||
import Prelude hiding (and, product)
|
||||
import Database.Relational.Query.Context (Flat)
|
||||
import Database.Relational.Query.Expr (fromTriBool, exprAnd)
|
||||
import qualified Database.Relational.Query.Expr as Expr
|
||||
import Database.Relational.Query.Expr.Unsafe (showExpr)
|
||||
import Database.Relational.Query.Projection (Projection)
|
||||
import Database.Relational.Query.Projectable (valueTrue)
|
||||
import Database.Relational.Query.Sub (SubQuery, Qualified)
|
||||
import qualified Database.Relational.Query.Sub as SubQuery
|
||||
@ -37,7 +37,7 @@ import Data.Monoid ((<>))
|
||||
import Data.Foldable (Foldable (foldMap))
|
||||
|
||||
|
||||
type Expr = Expr.Expr Projection
|
||||
type Expr = Expr.Expr Flat
|
||||
|
||||
-- | node attribute for product.
|
||||
data NodeAttr = Just' | Maybe
|
||||
|
||||
@ -22,10 +22,9 @@ module Database.Relational.Query.Monad.Aggregate (
|
||||
toSubQuery
|
||||
) where
|
||||
|
||||
import Database.Relational.Query.Context (Flat, Aggregated)
|
||||
import Database.Relational.Query.Projection (Projection)
|
||||
import qualified Database.Relational.Query.Projection as Projection
|
||||
import Database.Relational.Query.Aggregation (Aggregation)
|
||||
import qualified Database.Relational.Query.Aggregation as Aggregation
|
||||
import Database.Relational.Query.SQL (selectSeedSQL)
|
||||
import Database.Relational.Query.Sub (SubQuery, subQuery)
|
||||
|
||||
@ -43,28 +42,28 @@ import Database.Relational.Query.Monad.Type (QueryCore)
|
||||
|
||||
|
||||
-- | Aggregated query monad type.
|
||||
type QueryAggregate = Orderings Aggregation (Aggregatings QueryCore)
|
||||
type QueryAggregate = Orderings Aggregated (Aggregatings QueryCore)
|
||||
|
||||
-- | Aggregated query type. AggregatedQuery r == QueryAggregate (Aggregation r).
|
||||
type AggregatedQuery r = OrderedQuery Aggregation (Aggregatings QueryCore) r
|
||||
-- | Aggregated query type. AggregatedQuery r == QueryAggregate (Projection Aggregated r).
|
||||
type AggregatedQuery r = OrderedQuery Aggregated (Aggregatings QueryCore) r
|
||||
|
||||
-- | Lift from qualified table forms into 'QueryAggregate'.
|
||||
aggregatedQuery :: Qualify a -> QueryAggregate a
|
||||
aggregatedQuery = orderings . aggregatings . restrictings . join'
|
||||
|
||||
-- | Instance to lift from qualified table forms into 'QueryAggregate'.
|
||||
instance MonadQualify Qualify (Orderings Aggregation (Aggregatings QueryCore)) where
|
||||
instance MonadQualify Qualify (Orderings Aggregated (Aggregatings QueryCore)) where
|
||||
liftQualify = aggregatedQuery
|
||||
|
||||
expandPrepend :: AggregatedQuery r
|
||||
-> Qualify ((((Aggregation r, OrderByPrepend), GroupBysPrepend), WherePrepend), FromPrepend)
|
||||
-> Qualify ((((Projection Aggregated r, OrderByPrepend), GroupBysPrepend), WherePrepend), FromPrepend)
|
||||
expandPrepend = extractFrom . extractWheres . extractGroupBys . extractOrderBys
|
||||
|
||||
-- | Run 'AggregatedQuery' to get SQL string.
|
||||
expandSQL :: AggregatedQuery r -> Qualify (String, Projection r)
|
||||
expandSQL :: AggregatedQuery r -> Qualify (String, Projection Flat r)
|
||||
expandSQL q = do
|
||||
((((aggr, ao), ag), aw), af) <- expandPrepend q
|
||||
let projection = Aggregation.unsafeProjection aggr
|
||||
let projection = Projection.unsafeToFlat aggr
|
||||
return (selectSeedSQL projection . prependFrom af . prependWhere aw
|
||||
. prependGroupBys ag . prependOrderBy ao $ "",
|
||||
projection)
|
||||
|
||||
@ -20,9 +20,9 @@ module Database.Relational.Query.Monad.Class (
|
||||
groupBy, havingE, having
|
||||
) where
|
||||
|
||||
import Database.Relational.Query.Context (Flat, Aggregated)
|
||||
import Database.Relational.Query.Expr (Expr)
|
||||
import Database.Relational.Query.Projection (Projection)
|
||||
import Database.Relational.Query.Aggregation (Aggregation)
|
||||
import Database.Relational.Query.Projectable (expr)
|
||||
import Database.Relational.Query.Sub (SubQuery, Qualified)
|
||||
|
||||
@ -31,13 +31,13 @@ import Database.Relational.Query.Internal.Product (NodeAttr)
|
||||
-- | Restrict context interface
|
||||
class (Functor m, Monad m) => MonadRestrict m where
|
||||
-- | Add restriction to this context.
|
||||
restrictContext :: Expr Projection (Maybe Bool) -- ^ 'Expr' 'Projection' which represent restriction
|
||||
restrictContext :: Expr Flat (Maybe Bool) -- ^ 'Expr' 'Projection' which represent restriction
|
||||
-> m () -- ^ Restricted query context
|
||||
|
||||
-- | Query building interface.
|
||||
class (Functor m, Monad m) => MonadQuery m where
|
||||
-- | Add restriction to last join.
|
||||
restrictJoin :: Expr Projection (Maybe Bool) -- ^ 'Expr' 'Projection' which represent restriction
|
||||
restrictJoin :: Expr Flat (Maybe Bool) -- ^ 'Expr' 'Projection' which represent restriction
|
||||
-> m () -- ^ Restricted query context
|
||||
-- -- | Add restriction to this query.
|
||||
-- restrictQuery :: Expr Projection (Maybe Bool) -- ^ 'Expr' 'Projection' which represent restriction
|
||||
@ -45,7 +45,7 @@ class (Functor m, Monad m) => MonadQuery m where
|
||||
-- | Unsafely join subquery with this query.
|
||||
unsafeSubQuery :: NodeAttr -- ^ Attribute maybe or just
|
||||
-> Qualified SubQuery -- ^ 'SubQuery' to join
|
||||
-> m (Projection r) -- ^ Result joined context and 'SubQuery' result projection.
|
||||
-> m (Projection Flat r) -- ^ Result joined context and 'SubQuery' result projection.
|
||||
-- unsafeMergeAnotherQuery :: NodeAttr -> m (Projection r) -> m (Projection r)
|
||||
|
||||
-- | Lift interface from base qualify monad.
|
||||
@ -57,38 +57,38 @@ class (Functor q, Monad q, MonadQuery m) => MonadQualify q m where
|
||||
-- | Aggregated query building interface extends 'MonadQuery'.
|
||||
class MonadQuery m => MonadAggregate m where
|
||||
-- | Add /group by/ term into context and get aggregated projection.
|
||||
aggregateKey :: Projection r -- ^ Projection to add into group by
|
||||
-> m (Aggregation r) -- ^ Result context and aggregated projection
|
||||
aggregateKey :: Projection Flat r -- ^ Projection to add into group by
|
||||
-> m (Projection Aggregated r) -- ^ Result context and aggregated projection
|
||||
-- | Add restriction to this aggregated query.
|
||||
restrictAggregatedQuery :: Expr Aggregation (Maybe Bool) -- ^ 'Expr' 'Aggregation' which represent restriction
|
||||
restrictAggregatedQuery :: Expr Aggregated (Maybe Bool) -- ^ 'Expr' 'Aggregated' which represent restriction
|
||||
-> m () -- ^ Restricted query context
|
||||
|
||||
-- | Add restriction to last join.
|
||||
onE :: MonadQuery m => Expr Projection (Maybe Bool) -> m ()
|
||||
onE :: MonadQuery m => Expr Flat (Maybe Bool) -> m ()
|
||||
onE = restrictJoin
|
||||
|
||||
-- | Add restriction to last join. Projection type version.
|
||||
on :: MonadQuery m => Projection (Maybe Bool) -> m ()
|
||||
on :: MonadQuery m => Projection Flat (Maybe Bool) -> m ()
|
||||
on = restrictJoin . expr
|
||||
|
||||
-- | Add restriction to this query.
|
||||
wheresE :: MonadRestrict m => Expr Projection (Maybe Bool) -> m ()
|
||||
wheresE :: MonadRestrict m => Expr Flat (Maybe Bool) -> m ()
|
||||
wheresE = restrictContext
|
||||
|
||||
-- | Add restriction to this query. Projection type version.
|
||||
wheres :: MonadRestrict m => Projection (Maybe Bool) -> m ()
|
||||
wheres :: MonadRestrict m => Projection Flat (Maybe Bool) -> m ()
|
||||
wheres = restrictContext . expr
|
||||
|
||||
-- | Add /group by/ term into context and get aggregated projection.
|
||||
groupBy :: MonadAggregate m
|
||||
=> Projection r -- ^ Projection to add into group by
|
||||
-> m (Aggregation r) -- ^ Result context and aggregated projection
|
||||
=> Projection Flat r -- ^ Projection to add into group by
|
||||
-> m (Projection Aggregated r) -- ^ Result context and aggregated projection
|
||||
groupBy = aggregateKey
|
||||
|
||||
-- | Add restriction to this aggregated query.
|
||||
havingE :: MonadAggregate m => Expr Aggregation (Maybe Bool) -> m ()
|
||||
havingE :: MonadAggregate m => Expr Aggregated (Maybe Bool) -> m ()
|
||||
havingE = restrictAggregatedQuery
|
||||
|
||||
-- | Add restriction to this aggregated query. Aggregation type version.
|
||||
having :: MonadAggregate m => Aggregation (Maybe Bool) -> m ()
|
||||
-- | Add restriction to this aggregated query. Aggregated Projection type version.
|
||||
having :: MonadAggregate m => Projection Aggregated (Maybe Bool) -> m ()
|
||||
having = restrictAggregatedQuery . expr
|
||||
|
||||
@ -18,6 +18,7 @@ module Database.Relational.Query.Monad.Restrict (
|
||||
|
||||
import Data.Functor.Identity (Identity (..), runIdentity)
|
||||
|
||||
import Database.Relational.Query.Context (Flat)
|
||||
import Database.Relational.Query.Projection (Projection)
|
||||
import Database.Relational.Query.Monad.Trans.Restricting
|
||||
(Restrictings, WherePrepend, extractWheres)
|
||||
@ -29,7 +30,7 @@ type Restrict = Restrictings Identity
|
||||
-- | RestrictedStatement type synonym.
|
||||
-- Projection record type 'r' must be
|
||||
-- the same as 'Restrictings' type parameter 'r'.
|
||||
type RestrictedStatement r a = Projection r -> Restrict a
|
||||
type RestrictedStatement r a = Projection Flat r -> Restrict a
|
||||
|
||||
-- -- | 'return' of 'Restrict'
|
||||
-- restricted :: a -> Restrict a
|
||||
|
||||
@ -22,6 +22,7 @@ module Database.Relational.Query.Monad.Simple (
|
||||
toSubQuery
|
||||
) where
|
||||
|
||||
import Database.Relational.Query.Context (Flat)
|
||||
import Database.Relational.Query.Projection (Projection)
|
||||
import qualified Database.Relational.Query.Projection as Projection
|
||||
import Database.Relational.Query.SQL (selectSeedSQL)
|
||||
@ -40,25 +41,25 @@ import Database.Relational.Query.Sub (SubQuery, subQuery)
|
||||
|
||||
|
||||
-- | Simple query (not-aggregated) monad type.
|
||||
type QuerySimple = Orderings Projection QueryCore
|
||||
type QuerySimple = Orderings Flat QueryCore
|
||||
|
||||
-- | Simple query (not-aggregated) query type. 'SimpleQuery' r == 'QuerySimple' ('Projection' r).
|
||||
type SimpleQuery r = OrderedQuery Projection QueryCore r
|
||||
type SimpleQuery r = OrderedQuery Flat QueryCore r
|
||||
|
||||
-- | Lift from qualified table forms into 'QuerySimple'.
|
||||
simple :: Qualify a -> QuerySimple a
|
||||
simple = orderings . restrictings . join'
|
||||
|
||||
-- | Instance to lift from qualified table forms into 'QuerySimple'.
|
||||
instance MonadQualify Qualify (Orderings Projection QueryCore) where
|
||||
instance MonadQualify Qualify (Orderings Flat QueryCore) where
|
||||
liftQualify = simple
|
||||
|
||||
expandPrepend :: SimpleQuery r
|
||||
-> Qualify (((Projection r, OrderByPrepend), WherePrepend), FromPrepend)
|
||||
-> Qualify (((Projection Flat r, OrderByPrepend), WherePrepend), FromPrepend)
|
||||
expandPrepend = extractFrom . extractWheres . extractOrderBys
|
||||
|
||||
-- | Run 'SimpleQuery' to get SQL string.
|
||||
expandSQL :: SimpleQuery r -> Qualify (String, Projection r)
|
||||
expandSQL :: SimpleQuery r -> Qualify (String, Projection Flat r)
|
||||
expandSQL q = do
|
||||
(((pj, ao), aw), af) <- expandPrepend q
|
||||
return (selectSeedSQL pj . prependFrom af . prependWhere aw . prependOrderBy ao $ "", pj)
|
||||
|
||||
@ -15,6 +15,7 @@ module Database.Relational.Query.Monad.Target (
|
||||
expandPrepend
|
||||
) where
|
||||
|
||||
import Database.Relational.Query.Context (Flat)
|
||||
import Database.Relational.Query.Table (Table)
|
||||
import Database.Relational.Query.Projection (Projection)
|
||||
import Database.Relational.Query.Monad.Restrict (Restrict, expandWhere)
|
||||
@ -28,7 +29,7 @@ type Target r = Assignings r Restrict
|
||||
-- | TargetStatement type synonym.
|
||||
-- Table and projection record type must be
|
||||
-- the same as 'Target' type parameter 'r'.
|
||||
type TargetStatement r a = Table r -> Projection r -> Target r a
|
||||
type TargetStatement r a = Table r -> Projection Flat r -> Target r a
|
||||
|
||||
-- -- | 'return' of 'Update'
|
||||
-- updateStatement :: a -> Assignings r (Restrictings Identity) a
|
||||
|
||||
@ -24,6 +24,7 @@ import Control.Monad.Trans.State (StateT, runStateT, modify)
|
||||
import Control.Applicative (Applicative, (<$>))
|
||||
import Control.Arrow (second, (>>>))
|
||||
|
||||
import Database.Relational.Query.Context (Flat, Aggregated)
|
||||
import Database.Relational.Query.Monad.Trans.StatePrepend (Prepend, prepend, liftToString)
|
||||
import Database.Relational.Query.Monad.Trans.AggregatingState
|
||||
(AggregatingContext, primeAggregatingContext, addGroupBy, composeGroupBys)
|
||||
@ -31,8 +32,6 @@ import qualified Database.Relational.Query.Monad.Trans.AggregatingState as State
|
||||
import Database.Relational.Query.Expr (Expr)
|
||||
import Database.Relational.Query.Projection (Projection)
|
||||
import qualified Database.Relational.Query.Projection as Projection
|
||||
import Database.Relational.Query.Aggregation (Aggregation)
|
||||
import qualified Database.Relational.Query.Aggregation as Aggregation
|
||||
|
||||
import Database.Relational.Query.Monad.Class
|
||||
(MonadRestrict(..), MonadQuery(..), MonadAggregate(..))
|
||||
@ -77,17 +76,17 @@ addGroupBys' gbs = updateAggregatingContext . foldr (>>>) id $ map addGroupBy gb
|
||||
|
||||
-- | Add restrictions for aggregated query.
|
||||
addRestriction :: MonadQuery m
|
||||
=> Expr Aggregation (Maybe Bool) -- ^ Restriction to add
|
||||
=> Expr Aggregated (Maybe Bool) -- ^ Restriction to add
|
||||
-> Aggregatings m () -- ^ Result restricted context
|
||||
addRestriction = updateAggregatingContext . State.addRestriction
|
||||
|
||||
-- | Add aggregating terms.
|
||||
addGroupBys :: MonadQuery m
|
||||
=> Projection r -- ^ Group-by term to add
|
||||
-> Aggregatings m (Aggregation r) -- ^ Result aggregated context
|
||||
=> Projection Flat r -- ^ Group-by term to add
|
||||
-> Aggregatings m (Projection Aggregated r) -- ^ Result aggregated context
|
||||
addGroupBys p = do
|
||||
addGroupBys' . Projection.columns $ p
|
||||
return $ Aggregation.unsafeFromProjection p
|
||||
return $ Projection.unsafeToAggregated p
|
||||
|
||||
-- | Aggregated query instance.
|
||||
instance MonadQuery m => MonadAggregate (Aggregatings m) where
|
||||
|
||||
@ -27,9 +27,9 @@ import qualified Data.DList as DList
|
||||
import Data.Monoid ((<>))
|
||||
import Control.Applicative (pure)
|
||||
|
||||
import Database.Relational.Query.Context (Aggregated)
|
||||
import Database.Relational.Query.Expr (Expr, fromTriBool, exprAnd)
|
||||
import Database.Relational.Query.Expr.Unsafe (showExpr)
|
||||
import Database.Relational.Query.Aggregation (Aggregation)
|
||||
|
||||
import Language.SQL.Keyword (Keyword(..), unwordsSQL)
|
||||
import qualified Language.SQL.Keyword as SQL
|
||||
@ -46,7 +46,7 @@ type GroupBys = DList GroupByTerm
|
||||
data AggregatingContext =
|
||||
AggregatingContext
|
||||
{ groupByTerms :: GroupBys
|
||||
, restriction :: Maybe (Expr Aggregation Bool)
|
||||
, restriction :: Maybe (Expr Aggregated Bool)
|
||||
}
|
||||
|
||||
-- | Initial value of 'AggregatingContext'.
|
||||
@ -58,7 +58,7 @@ addGroupBy :: String -> AggregatingContext -> AggregatingContext
|
||||
addGroupBy t c = c { groupByTerms = groupByTerms c <> pure t }
|
||||
|
||||
-- | Add having restriction into 'AggregatingContext'.
|
||||
addRestriction :: Expr Aggregation (Maybe Bool) -> AggregatingContext -> AggregatingContext
|
||||
addRestriction :: Expr Aggregated (Maybe Bool) -> AggregatingContext -> AggregatingContext
|
||||
addRestriction e1 ctx =
|
||||
ctx { restriction = Just . uf . restriction $ ctx }
|
||||
where uf Nothing = fromTriBool e1
|
||||
|
||||
@ -23,6 +23,7 @@ module Database.Relational.Query.Monad.Trans.Assigning (
|
||||
SetPrepend, prependSet
|
||||
) where
|
||||
|
||||
import Database.Relational.Query.Context (Flat)
|
||||
import Control.Monad.Trans.Class (MonadTrans (lift))
|
||||
import Control.Monad.Trans.State (StateT, runStateT, modify)
|
||||
import Control.Applicative (Applicative, (<$>))
|
||||
@ -70,12 +71,12 @@ instance MonadRestrict m => MonadRestrict (Assignings r m) where
|
||||
-- | Target of assignment.
|
||||
newtype AssignTarget r v = AssignTarget (Table r, Pi r v)
|
||||
|
||||
targetProjection :: AssignTarget r v -> Projection v
|
||||
targetProjection :: AssignTarget r v -> Projection Flat v
|
||||
targetProjection (AssignTarget (tbl, pi')) =
|
||||
Projection.pi (Projection.unsafeFromTable tbl) pi'
|
||||
|
||||
-- | Add an assignment.
|
||||
assignTo :: Monad m => Projection v -> AssignTarget r v -> Assignings r m ()
|
||||
assignTo :: Monad m => Projection Flat v -> AssignTarget r v -> Assignings r m ()
|
||||
assignTo vp target = updateAssigningContext . foldr (>>>) id
|
||||
$ zipWith updateAssignments lefts rights where
|
||||
lefts = Projection.columns $ targetProjection target
|
||||
@ -86,7 +87,7 @@ assignTo vp target = updateAssigningContext . foldr (>>>) id
|
||||
(!#) = curry AssignTarget
|
||||
|
||||
-- | Add and assginment.
|
||||
(<-#) :: Monad m => AssignTarget r v -> Projection v -> Assignings r m ()
|
||||
(<-#) :: Monad m => AssignTarget r v -> Projection Flat v -> Assignings r m ()
|
||||
(<-#) = flip assignTo
|
||||
|
||||
infix 8 !#
|
||||
|
||||
@ -24,6 +24,7 @@ import Control.Monad.Trans.State (modify, StateT, runStateT)
|
||||
import Control.Applicative (Applicative, (<$>))
|
||||
import Control.Arrow (second)
|
||||
|
||||
import Database.Relational.Query.Context (Flat)
|
||||
import Database.Relational.Query.Monad.Trans.StatePrepend (Prepend, prepend, liftToString)
|
||||
import Database.Relational.Query.Monad.Trans.JoinState
|
||||
(JoinContext, primeJoinContext, updateProduct, composeFrom)
|
||||
@ -61,7 +62,7 @@ updateContext :: Monad m => (JoinContext -> JoinContext) -> QueryJoin m ()
|
||||
updateContext = QueryJoin . modify
|
||||
|
||||
-- | Add last join product restriction.
|
||||
updateJoinRestriction :: Monad m => Expr Projection (Maybe Bool) -> QueryJoin m ()
|
||||
updateJoinRestriction :: Monad m => Expr Flat (Maybe Bool) -> QueryJoin m ()
|
||||
updateJoinRestriction e = updateContext (updateProduct d) where
|
||||
d Nothing = error "on: product is empty!"
|
||||
d (Just pt) = restrictProduct pt (fromTriBool e)
|
||||
@ -84,7 +85,7 @@ instance (Monad q, Functor q) => MonadQuery (QueryJoin q) where
|
||||
unsafeSubQueryWithAttr :: Monad q
|
||||
=> NodeAttr -- ^ Attribute maybe or just
|
||||
-> Qualified SubQuery -- ^ 'SubQuery' to join
|
||||
-> QueryJoin q (Projection r) -- ^ Result joined context and 'SubQuery' result projection.
|
||||
-> QueryJoin q (Projection Flat r) -- ^ Result joined context and 'SubQuery' result projection.
|
||||
unsafeSubQueryWithAttr attr qsub = do
|
||||
updateContext (updateProduct (`growProduct` (attr, qsub)))
|
||||
return $ Projection.unsafeFromQualifiedSubQuery qsub
|
||||
|
||||
@ -1,4 +1,4 @@
|
||||
{-# LANGUAGE KindSignatures #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||
|
||||
-- |
|
||||
@ -34,8 +34,6 @@ import Database.Relational.Query.Monad.Trans.OrderingState
|
||||
(Order(Asc, Desc), OrderingContext, primeOrderingContext, updateOrderBy, composeOrderBys)
|
||||
import Database.Relational.Query.Projection (Projection)
|
||||
import qualified Database.Relational.Query.Projection as Projection
|
||||
import Database.Relational.Query.Aggregation (Aggregation)
|
||||
import qualified Database.Relational.Query.Aggregation as Aggregation
|
||||
|
||||
import Database.Relational.Query.Monad.Class
|
||||
(MonadRestrict(..), MonadQuery(..), MonadAggregate(..))
|
||||
@ -43,7 +41,7 @@ import Database.Relational.Query.Monad.Class
|
||||
|
||||
-- | 'StateT' type to accumulate ordering context.
|
||||
-- Type 'p' is ordering term projection type.
|
||||
newtype Orderings (p :: * -> *) m a =
|
||||
newtype Orderings p m a =
|
||||
Orderings { orderingState :: StateT OrderingContext m a }
|
||||
deriving (MonadTrans, Monad, Functor, Applicative)
|
||||
|
||||
@ -78,28 +76,24 @@ instance MonadAggregate m => MonadAggregate (Orderings p m) where
|
||||
restrictAggregatedQuery = orderings . restrictAggregatedQuery
|
||||
|
||||
-- | OrderedQuery type synonym. Projection must be the same as 'Orderings' type parameter 'p'
|
||||
type OrderedQuery p m r = Orderings p m (p r)
|
||||
type OrderedQuery p m r = Orderings p m (Projection p r)
|
||||
|
||||
-- | Ordering term projection type interface.
|
||||
class OrderingTerms p where
|
||||
orderTerms :: p t -> [String]
|
||||
|
||||
-- | 'Projection' is ordering term.
|
||||
instance OrderingTerms Projection where
|
||||
instance OrderingTerms (Projection c) where
|
||||
orderTerms = Projection.columns
|
||||
|
||||
-- | 'Aggregation' is ordering term.
|
||||
instance OrderingTerms Aggregation where
|
||||
orderTerms = Projection.columns . Aggregation.unsafeProjection
|
||||
|
||||
-- | Unsafely update ordering context.
|
||||
updateOrderingContext :: Monad m => (OrderingContext -> OrderingContext) -> Orderings p m ()
|
||||
updateOrderingContext = Orderings . modify
|
||||
|
||||
-- | Add ordering terms.
|
||||
updateOrderBys :: (Monad m, OrderingTerms p)
|
||||
updateOrderBys :: (Monad m, OrderingTerms (Projection p))
|
||||
=> Order -- ^ Order direction
|
||||
-> p t -- ^ Ordering terms to add
|
||||
-> Projection p t -- ^ Ordering terms to add
|
||||
-> Orderings p m () -- ^ Result context with ordering
|
||||
updateOrderBys order p = updateOrderingContext . foldr (>>>) id $ updates where
|
||||
updates = updateOrderBy order `map` orderTerms p
|
||||
@ -125,14 +119,14 @@ unsafeMergeAnotherOrderBys naR qR = do
|
||||
|
||||
|
||||
-- | Add ascendant ordering term.
|
||||
asc :: (Monad m, OrderingTerms p)
|
||||
=> p t -- ^ Ordering terms to add
|
||||
asc :: (Monad m, OrderingTerms (Projection p))
|
||||
=> Projection p t -- ^ Ordering terms to add
|
||||
-> Orderings p m () -- ^ Result context with ordering
|
||||
asc = updateOrderBys Asc
|
||||
|
||||
-- | Add descendant ordering term.
|
||||
desc :: (Monad m, OrderingTerms p)
|
||||
=> p t -- ^ Ordering terms to add
|
||||
desc :: (Monad m, OrderingTerms (Projection p))
|
||||
=> Projection p t -- ^ Ordering terms to add
|
||||
-> Orderings p m () -- ^ Result context with ordering
|
||||
desc = updateOrderBys Desc
|
||||
|
||||
|
||||
@ -24,10 +24,10 @@ import Control.Monad.Trans.State (modify, StateT, runStateT)
|
||||
import Control.Applicative (Applicative, (<$>))
|
||||
import Control.Arrow (second)
|
||||
|
||||
import Database.Relational.Query.Context (Flat)
|
||||
import Database.Relational.Query.Monad.Trans.StatePrepend (Prepend, prepend, liftToString)
|
||||
import Database.Relational.Query.Monad.Trans.RestrictingState
|
||||
(RestrictContext, primeRestrictContext, addRestriction, composeWheres)
|
||||
import Database.Relational.Query.Projection (Projection)
|
||||
import Database.Relational.Query.Expr (Expr)
|
||||
|
||||
import Database.Relational.Query.Monad.Class (MonadRestrict(..), MonadQuery (..))
|
||||
@ -58,7 +58,7 @@ updateRestrictContext :: Monad m => (RestrictContext -> RestrictContext) -> Rest
|
||||
updateRestrictContext = Restrictings . modify
|
||||
|
||||
-- | Add whole query restriction.
|
||||
updateRestriction :: Monad m => Expr Projection (Maybe Bool) -> Restrictings m ()
|
||||
updateRestriction :: Monad m => Expr Flat (Maybe Bool) -> Restrictings m ()
|
||||
updateRestriction e = updateRestrictContext (addRestriction e)
|
||||
|
||||
-- | 'MonadRestrict' instance.
|
||||
|
||||
@ -20,11 +20,10 @@ module Database.Relational.Query.Monad.Trans.RestrictingState (
|
||||
composeWheres
|
||||
) where
|
||||
|
||||
import Database.Relational.Query.Context (Flat)
|
||||
import Database.Relational.Query.Expr (Expr, fromTriBool, exprAnd)
|
||||
import Database.Relational.Query.Expr.Unsafe (showExpr)
|
||||
|
||||
import Database.Relational.Query.Projection (Projection)
|
||||
|
||||
import Language.SQL.Keyword (Keyword(..), unwordsSQL)
|
||||
import qualified Language.SQL.Keyword as SQL
|
||||
|
||||
@ -32,21 +31,21 @@ import qualified Language.SQL.Keyword as SQL
|
||||
-- | Context type for Restrict.
|
||||
data RestrictContext =
|
||||
RestrictContext
|
||||
{ restriction :: Maybe (Expr Projection Bool) }
|
||||
{ restriction :: Maybe (Expr Flat Bool) }
|
||||
|
||||
-- | Initial 'RestrictContext'.
|
||||
primeRestrictContext :: RestrictContext
|
||||
primeRestrictContext = RestrictContext Nothing
|
||||
|
||||
-- | Add restriction of 'RestrictContext'.
|
||||
addRestriction :: Expr Projection (Maybe Bool) -> RestrictContext -> RestrictContext
|
||||
addRestriction :: Expr Flat (Maybe Bool) -> RestrictContext -> RestrictContext
|
||||
addRestriction e1 ctx =
|
||||
ctx { restriction = Just . uf . restriction $ ctx }
|
||||
where uf Nothing = fromTriBool e1
|
||||
uf (Just e0) = e0 `exprAnd` fromTriBool e1
|
||||
|
||||
-- | Compose SQL String from 'RestrictContext' object.
|
||||
composeWheres' :: Maybe (Expr Projection Bool) -> String
|
||||
composeWheres' :: Maybe (Expr Flat Bool) -> String
|
||||
composeWheres' = maybe [] (\e -> unwordsSQL [WHERE, SQL.word . showExpr $ e])
|
||||
|
||||
-- | Compose SQL String from 'RestrictContext' object.
|
||||
|
||||
@ -10,8 +10,8 @@
|
||||
-- This module defines operators on various polymorphic projections.
|
||||
module Database.Relational.Query.Projectable (
|
||||
-- * Conversion between individual Projections
|
||||
ExpressionProjectable (expr),
|
||||
ProjectablePi (pi, piMaybe, piMaybe'),
|
||||
expr,
|
||||
-- ProjectablePi (pi, piMaybe, piMaybe'),
|
||||
|
||||
-- * Projectable from SQL strings
|
||||
SqlProjectable (unsafeProjectSqlTerms), unsafeProjectSql,
|
||||
@ -29,7 +29,6 @@ module Database.Relational.Query.Projectable (
|
||||
-- * Projectable into SQL strings
|
||||
unsafeShowSqlExpr,
|
||||
unsafeShowSqlProjection,
|
||||
unsafeShowSqlAggregation,
|
||||
ProjectableShowSql (unsafeShowSql),
|
||||
|
||||
-- * Binary Operators
|
||||
@ -72,9 +71,6 @@ import Database.Relational.Query.Pi (Pi, piZip)
|
||||
import Database.Relational.Query.Projection (Projection, columns, unsafeFromColumns)
|
||||
import qualified Database.Relational.Query.Projection as Projection
|
||||
|
||||
import Database.Relational.Query.Aggregation (Aggregation)
|
||||
import qualified Database.Relational.Query.Aggregation as Aggregation
|
||||
|
||||
|
||||
-- | Parened String.
|
||||
paren :: String -> String
|
||||
@ -88,24 +84,17 @@ sqlTermsString = d where
|
||||
d (cs) = paren $ intercalate ", " cs
|
||||
|
||||
-- | SQL expression strings which represent projection.
|
||||
sqlStringOfProjection :: Projection r -> String
|
||||
sqlStringOfProjection :: Projection c r -> String
|
||||
sqlStringOfProjection = sqlTermsString . columns
|
||||
|
||||
-- | 'Expr' from 'Projection'
|
||||
exprOfProjection :: Projection r -> Expr Projection r
|
||||
exprOfProjection :: Projection c r -> Expr c r
|
||||
exprOfProjection = UnsafeExpr.Expr . sqlStringOfProjection
|
||||
|
||||
-- | Projection interface into expression.
|
||||
class ExpressionProjectable p where
|
||||
-- | Project from Projection type 'p' into expression type.
|
||||
expr :: p a -> Expr p a
|
||||
|
||||
instance ExpressionProjectable Projection where
|
||||
-- | Project from Projection type into expression type.
|
||||
expr :: Projection p a -> Expr p a
|
||||
expr = exprOfProjection
|
||||
|
||||
instance ExpressionProjectable Aggregation where
|
||||
expr = UnsafeExpr.Expr . sqlStringOfProjection . Aggregation.unsafeProjection
|
||||
|
||||
-- | Projection interface.
|
||||
class ProjectablePi p where
|
||||
-- | Trace projection path 'Pi' to get narrower projection type 'p'.
|
||||
@ -116,19 +105,14 @@ class ProjectablePi p where
|
||||
-- Leaf type of projection path is 'Maybe'.
|
||||
piMaybe' :: p (Maybe a) -> Pi a (Maybe b) -> p (Maybe b)
|
||||
|
||||
instance ProjectablePi Projection where
|
||||
instance ProjectablePi (Projection c) where
|
||||
pi = Projection.pi
|
||||
piMaybe = Projection.piMaybe
|
||||
piMaybe' = Projection.piMaybe'
|
||||
|
||||
instance ProjectablePi Aggregation where
|
||||
pi = Aggregation.pi
|
||||
piMaybe = Aggregation.piMaybe
|
||||
piMaybe' = Aggregation.piMaybe'
|
||||
|
||||
|
||||
-- | Unsafely generate 'Projection' from SQL expression strings.
|
||||
unsafeSqlTermsProjection :: [String] -> Projection t
|
||||
unsafeSqlTermsProjection :: [String] -> Projection c t
|
||||
unsafeSqlTermsProjection = unsafeFromColumns
|
||||
|
||||
-- | Interface to project SQL terms unsafely.
|
||||
@ -138,17 +122,13 @@ class SqlProjectable p where
|
||||
-> p t -- ^ Result projection object
|
||||
|
||||
-- | Unsafely make 'Projection' from SQL terms.
|
||||
instance SqlProjectable Projection where
|
||||
instance SqlProjectable (Projection c) where
|
||||
unsafeProjectSqlTerms = unsafeSqlTermsProjection
|
||||
|
||||
-- | Unsafely make 'Expr' from SQL terms.
|
||||
instance SqlProjectable (Expr p) where
|
||||
unsafeProjectSqlTerms = UnsafeExpr.Expr . sqlTermsString
|
||||
|
||||
-- | Unsafely make 'Aggregation' from SQL terms.
|
||||
instance SqlProjectable Aggregation where
|
||||
unsafeProjectSqlTerms = Aggregation.unsafeFromProjection . unsafeProjectSqlTerms
|
||||
|
||||
-- | Unsafely Project single SQL term.
|
||||
unsafeProjectSql :: SqlProjectable p => String -> p t
|
||||
unsafeProjectSql = unsafeProjectSqlTerms . (:[])
|
||||
@ -189,21 +169,13 @@ instance ProjectableShowSql (Expr p) where
|
||||
unsafeShowSql = unsafeShowSqlExpr
|
||||
|
||||
-- | Unsafely get SQL term from 'Proejction'.
|
||||
unsafeShowSqlProjection :: Projection r -> String
|
||||
unsafeShowSqlProjection :: Projection c r -> String
|
||||
unsafeShowSqlProjection = sqlStringOfProjection
|
||||
|
||||
-- | Unsafely get SQL term from 'Proejction'.
|
||||
instance ProjectableShowSql Projection where
|
||||
instance ProjectableShowSql (Projection c) where
|
||||
unsafeShowSql = unsafeShowSqlProjection
|
||||
|
||||
-- | Unsafely get SQL term from 'Aggregation'.
|
||||
unsafeShowSqlAggregation :: Aggregation a -> String
|
||||
unsafeShowSqlAggregation = unsafeShowSql . Aggregation.unsafeProjection
|
||||
|
||||
-- | Unsafely get SQL term from 'Aggregation'.
|
||||
instance ProjectableShowSql Aggregation where
|
||||
unsafeShowSql = unsafeShowSqlAggregation
|
||||
|
||||
|
||||
-- | Binary operator type for SQL String.
|
||||
type SqlBinOp = String -> String -> String
|
||||
@ -394,13 +366,9 @@ instance ProjectableZip PlaceHolders where
|
||||
projectZip PlaceHolders PlaceHolders = PlaceHolders
|
||||
|
||||
-- | Zip 'Projection'.
|
||||
instance ProjectableZip Projection where
|
||||
instance ProjectableZip (Projection c) where
|
||||
projectZip = Projection.compose
|
||||
|
||||
-- | Zip 'Aggregation'
|
||||
instance ProjectableZip Aggregation where
|
||||
projectZip = Aggregation.compose
|
||||
|
||||
-- | Zip 'Pi'
|
||||
instance ProjectableZip (Pi a) where
|
||||
projectZip = piZip
|
||||
@ -422,7 +390,7 @@ instance ProjectableMaybe PlaceHolders where
|
||||
flattenMaybe = unsafeCastPlaceHolders
|
||||
|
||||
-- | Control phantom 'Maybe' type in projection type 'Projection'.
|
||||
instance ProjectableMaybe Projection where
|
||||
instance ProjectableMaybe (Projection c) where
|
||||
just = Projection.just
|
||||
flattenMaybe = Projection.flattenMaybe
|
||||
|
||||
@ -431,11 +399,6 @@ instance ProjectableMaybe (Expr p) where
|
||||
just = Expr.just
|
||||
flattenMaybe = Expr.fromJust
|
||||
|
||||
-- | Control phantom 'Maybe' type in aggregate projection type 'Projection'.
|
||||
instance ProjectableMaybe Aggregation where
|
||||
just = Aggregation.just
|
||||
flattenMaybe = Aggregation.flattenMaybe
|
||||
|
||||
-- | Zipping except for identity element laws.
|
||||
class ProjectableZip p => ProjectableIdZip p where
|
||||
leftId :: p ((), a) -> p a
|
||||
|
||||
@ -43,21 +43,21 @@ import Prelude hiding (pi)
|
||||
import Data.Int (Int32)
|
||||
|
||||
import qualified Language.SQL.Keyword as SQL
|
||||
import Database.Relational.Query.Context (Flat, Aggregated)
|
||||
import Database.Relational.Query.Expr (Expr, fromJust)
|
||||
import Database.Relational.Query.Projection (Projection)
|
||||
import Database.Relational.Query.Aggregation (Aggregation)
|
||||
import qualified Database.Relational.Query.Projection as Projection
|
||||
import Database.Relational.Query.Projectable
|
||||
(ExpressionProjectable (expr), ProjectablePi, PlaceHolders,
|
||||
(expr, PlaceHolders,
|
||||
ProjectableMaybe (flattenMaybe), ProjectableIdZip (leftId, rightId),
|
||||
SqlProjectable, unsafeProjectSql, ProjectableShowSql (unsafeShowSql))
|
||||
import qualified Database.Relational.Query.Projectable as Projectable
|
||||
import Database.Relational.Query.Pi (Pi)
|
||||
|
||||
|
||||
-- | Projection interface.
|
||||
class Projectable p0 p1 where
|
||||
-- ｜ Project from projection type 'p0' into weaken projection types 'p1'.
|
||||
project :: p0 a -> p1 a
|
||||
project :: p0 c a -> p1 c a
|
||||
|
||||
-- | Parened String.
|
||||
paren :: String -> String
|
||||
@ -71,40 +71,40 @@ sqlUniOp :: SQL.Keyword -> SqlUniOp
|
||||
sqlUniOp kw = (SQL.wordShow kw ++) . (' ' :) . paren
|
||||
|
||||
-- | Unsafely make aggregation uni-operator from SQL keyword.
|
||||
unsafeAggregateOp :: (SqlProjectable p, Projectable Aggregation p)
|
||||
=> SQL.Keyword -> Projection a -> p b
|
||||
unsafeAggregateOp :: SqlProjectable (p Aggregated)
|
||||
=> SQL.Keyword -> Projection Flat a -> p Aggregated b
|
||||
unsafeAggregateOp op = unsafeProjectSql . sqlUniOp op . unsafeShowSql
|
||||
|
||||
-- | Aggregation function COUNT.
|
||||
count :: (SqlProjectable p, Projectable Aggregation p) => Projection a -> p Int32
|
||||
count :: SqlProjectable (p Aggregated) => Projection Flat a -> p Aggregated Int32
|
||||
count = unsafeAggregateOp SQL.COUNT
|
||||
|
||||
-- | Aggregation function SUM.
|
||||
sum' :: (Num a, SqlProjectable p, Projectable Aggregation p) => Projection a -> p a
|
||||
sum' :: (Num a, SqlProjectable (p Aggregated)) => Projection Flat a -> p Aggregated a
|
||||
sum' = unsafeAggregateOp SQL.SUM
|
||||
|
||||
-- | Aggregation function AVG.
|
||||
avg :: (Num a, Fractional b, SqlProjectable p, Projectable Aggregation p)=> Projection a -> p b
|
||||
avg :: (Num a, Fractional b, SqlProjectable (p Aggregated))=> Projection Flat a -> p Aggregated b
|
||||
avg = unsafeAggregateOp SQL.AVG
|
||||
|
||||
-- | Aggregation function MAX.
|
||||
max' :: (Ord a, SqlProjectable p, Projectable Aggregation p) => Projection a -> p a
|
||||
max' :: (Ord a, SqlProjectable (p Aggregated)) => Projection Flat a -> p Aggregated a
|
||||
max' = unsafeAggregateOp SQL.MAX
|
||||
|
||||
-- | Aggregation function MIN.
|
||||
min' :: (Ord a, SqlProjectable p, Projectable Aggregation p) => Projection a -> p a
|
||||
min' :: (Ord a, SqlProjectable (p Aggregated)) => Projection Flat a -> p Aggregated a
|
||||
min' = unsafeAggregateOp SQL.MIN
|
||||
|
||||
-- | Aggregation function EVERY.
|
||||
every :: (SqlProjectable p, Projectable Aggregation p) => Projection (Maybe Bool) -> p (Maybe Bool)
|
||||
every :: (SqlProjectable (p Aggregated)) => Projection Flat (Maybe Bool) -> p Aggregated (Maybe Bool)
|
||||
every = unsafeAggregateOp SQL.EVERY
|
||||
|
||||
-- | Aggregation function ANY.
|
||||
any' :: (SqlProjectable p, Projectable Aggregation p) => Projection (Maybe Bool) -> p (Maybe Bool)
|
||||
any' :: (SqlProjectable (p Aggregated)) => Projection Flat (Maybe Bool) -> p Aggregated (Maybe Bool)
|
||||
any' = unsafeAggregateOp SQL.ANY
|
||||
|
||||
-- | Aggregation function SOME.
|
||||
some' :: (SqlProjectable p, Projectable Aggregation p) => Projection (Maybe Bool) -> p (Maybe Bool)
|
||||
some' :: (SqlProjectable (p Aggregated)) => Projection Flat (Maybe Bool) -> p Aggregated (Maybe Bool)
|
||||
some' = unsafeAggregateOp SQL.SOME
|
||||
|
||||
-- | Project from 'Projection' into 'Projection'.
|
||||
@ -112,93 +112,75 @@ instance Projectable Projection Projection where
|
||||
project = id
|
||||
|
||||
-- | Project from 'Projection' into 'Expr' 'Projection'.
|
||||
instance Projectable Projection (Expr Projection) where
|
||||
instance Projectable Projection Expr where
|
||||
project = expr
|
||||
|
||||
-- | Project from 'Aggregation' into 'Aggregation'.
|
||||
instance Projectable Aggregation Aggregation where
|
||||
project = id
|
||||
projectPi :: Projectable Projection p1 => Projection c a -> Pi a b -> p1 c b
|
||||
projectPi p = project . Projection.pi p
|
||||
|
||||
-- | Project from 'Aggregation' into 'Expr' 'Aggregation'.
|
||||
instance Projectable Aggregation (Expr Aggregation) where
|
||||
project = expr
|
||||
projectPiMaybe :: Projectable Projection p1 => Projection c (Maybe a) -> Pi a b -> p1 c (Maybe b)
|
||||
projectPiMaybe p = project . Projection.piMaybe p
|
||||
|
||||
projectPi :: (ProjectablePi p0, Projectable p0 p1) => p0 a -> Pi a b -> p1 b
|
||||
projectPi p = project . Projectable.pi p
|
||||
|
||||
projectPiMaybe :: (ProjectablePi p0, Projectable p0 p1) => p0 (Maybe a) -> Pi a b -> p1 (Maybe b)
|
||||
projectPiMaybe p = project . Projectable.piMaybe p
|
||||
|
||||
projectPiMaybe' :: (ProjectablePi p0, Projectable p0 p1) => p0 (Maybe a) -> Pi a (Maybe b) -> p1 (Maybe b)
|
||||
projectPiMaybe' p = project . Projectable.piMaybe' p
|
||||
projectPiMaybe' :: Projectable Projection p1 => Projection c (Maybe a) -> Pi a (Maybe b) -> p1 c (Maybe b)
|
||||
projectPiMaybe' p = project . Projection.piMaybe' p
|
||||
|
||||
-- | Get narrower projection along with projection path
|
||||
-- and project into result projection type.
|
||||
(!) :: Projectable Projection p
|
||||
=> Projection a -- ^ Source projection
|
||||
=> Projection c a -- ^ Source projection
|
||||
-> Pi a b -- ^ Projection path
|
||||
-> p b -- ^ Narrower projected object
|
||||
-> p c b -- ^ Narrower projected object
|
||||
(!) = projectPi
|
||||
|
||||
-- | Get narrower projection along with projection path
|
||||
-- and project into result projection type.
|
||||
-- 'Maybe' phantom type is propagated.
|
||||
(?!) :: Projectable Projection p
|
||||
=> Projection (Maybe a) -- ^ Source 'Projection'. 'Maybe' type
|
||||
=> Projection c (Maybe a) -- ^ Source 'Projection'. 'Maybe' type
|
||||
-> Pi a b -- ^ Projection path
|
||||
-> p (Maybe b) -- ^ Narrower projected object. 'Maybe' type result
|
||||
-> p c (Maybe b) -- ^ Narrower projected object. 'Maybe' type result
|
||||
(?!) = projectPiMaybe
|
||||
|
||||
-- | Get narrower projection along with projection path
|
||||
-- and project into result projection type.
|
||||
-- 'Maybe' phantom type is propagated. Projection path leaf is 'Maybe' case.
|
||||
(?!?) :: Projectable Projection p
|
||||
=> Projection (Maybe a) -- ^ Source 'Projection'. 'Maybe' phantom type
|
||||
=> Projection c (Maybe a) -- ^ Source 'Projection'. 'Maybe' phantom type
|
||||
-> Pi a (Maybe b) -- ^ Projection path. 'Maybe' type leaf
|
||||
-> p (Maybe b) -- ^ Narrower projected object. 'Maybe' phantom type result
|
||||
-> p c (Maybe b) -- ^ Narrower projected object. 'Maybe' phantom type result
|
||||
(?!?) = projectPiMaybe'
|
||||
|
||||
-- | Get narrower aggregated projection along with projection path
|
||||
-- and project into result projection type.
|
||||
(<!>) :: Projectable Aggregation p
|
||||
=> Aggregation a -- ^ Source 'Aggregation'
|
||||
(<!>) :: Projectable Projection p
|
||||
=> Projection c a -- ^ Source projection
|
||||
-> Pi a b -- ^ Projection path
|
||||
-> p b -- ^ Narrower projected object
|
||||
(<!>) = projectPi
|
||||
-> p c b -- ^ Narrower projected object
|
||||
(<!>) = (!)
|
||||
|
||||
-- | Get narrower aggregated projection along with projection path
|
||||
-- and project into result projection type.
|
||||
-- 'Maybe' phantom type is propagated.
|
||||
(<?!>) :: Projectable Aggregation p
|
||||
=> Aggregation (Maybe a) -- ^ Source 'Aggregation'. 'Maybe' phantom type
|
||||
(<?!>) :: Projectable Projection p
|
||||
=> Projection c (Maybe a) -- ^ Source 'Projection'. 'Maybe' type
|
||||
-> Pi a b -- ^ Projection path
|
||||
-> p (Maybe b) -- ^ Narrower projected object. 'Maybe' phantom type result
|
||||
(<?!>) = projectPiMaybe
|
||||
-> p c (Maybe b) -- ^ Narrower projected object. 'Maybe' type result
|
||||
(<?!>) = (?!)
|
||||
|
||||
-- | Get narrower aggregated projection along with projection path
|
||||
-- and project into result projection type.
|
||||
-- 'Maybe' phantom type is propagated. Projection path leaf is 'Maybe' case.
|
||||
(<?!?>) :: Projectable Aggregation p
|
||||
=> Aggregation (Maybe a) -- ^ Source 'Aggregation'. 'Maybe' phantom type
|
||||
(<?!?>) :: Projectable Projection p
|
||||
=> Projection c (Maybe a) -- ^ Source 'Projection'. 'Maybe' phantom type
|
||||
-> Pi a (Maybe b) -- ^ Projection path. 'Maybe' type leaf
|
||||
-> p (Maybe b) -- ^ Narrower projected object. 'Maybe' phantom type result
|
||||
(<?!?>) = projectPiMaybe'
|
||||
-> p c (Maybe b) -- ^ Narrower projected object. 'Maybe' phantom type result
|
||||
(<?!?>) = (?!?)
|
||||
|
||||
-- | Get narrower projected expression along with projectino path
|
||||
-- and strip 'Maybe' phantom type off.
|
||||
(.!) :: (ProjectablePi p, Projectable p (Expr p))
|
||||
=> p (Maybe a) -- ^ Source projection type 'p'. 'Maybe' phantom type
|
||||
(.!) :: Projection c (Maybe a) -- ^ Source projection type 'p'. 'Maybe' phantom type
|
||||
-> Pi a b -- ^ Projection path
|
||||
-> Expr p b -- ^ Narrower projected expression. 'Maybe' phantom type is stripped off
|
||||
-> Expr c b -- ^ Narrower projected expression. 'Maybe' phantom type is stripped off
|
||||
(.!) p = fromJust . projectPiMaybe p
|
||||
|
||||
-- | Get narrower projected expression along with projectino path
|
||||
-- and strip 'Maybe' phantom type off.
|
||||
-- Projection path leaf is 'Maybe' case.
|
||||
(.?) :: (ProjectablePi p, Projectable p (Expr p))
|
||||
=> p (Maybe a) -- ^ Source projection type 'p'. 'Maybe' phantom type
|
||||
(.?) :: Projection c (Maybe a) -- ^ Source projection type 'p'. 'Maybe' phantom type
|
||||
-> Pi a (Maybe b) -- ^ Projection path. 'Maybe' type leaf
|
||||
-> Expr p b -- ^ Narrower projected expression. 'Maybe' phantom type is stripped off
|
||||
-> Expr c b -- ^ Narrower projected expression. 'Maybe' phantom type is stripped off
|
||||
(.?) p = fromJust . projectPiMaybe' p
|
||||
|
||||
|
||||
@ -216,35 +198,34 @@ instance ProjectableFlattenMaybe (Maybe a) (Maybe a) where
|
||||
flatten = id
|
||||
|
||||
-- | Get narrower projection with flatten leaf phantom Maybe types along with projection path.
|
||||
flattenPiMaybe :: (ProjectablePi p, ProjectableMaybe p, ProjectableFlattenMaybe (Maybe b) c)
|
||||
=> p (Maybe a) -- ^ Source 'Projection'. 'Maybe' phantom type
|
||||
flattenPiMaybe :: (ProjectableMaybe (Projection cont), ProjectableFlattenMaybe (Maybe b) c)
|
||||
=> Projection cont (Maybe a) -- ^ Source 'Projection'. 'Maybe' phantom type
|
||||
-> Pi a b -- ^ Projection path
|
||||
-> p c -- ^ Narrower 'Projection'. Flatten 'Maybe' phantom type
|
||||
flattenPiMaybe p = flatten . Projectable.piMaybe p
|
||||
-> Projection cont c -- ^ Narrower 'Projection'. Flatten 'Maybe' phantom type
|
||||
flattenPiMaybe p = flatten . Projection.piMaybe p
|
||||
|
||||
projectFlattenPiMaybe :: (ProjectablePi p0, ProjectableMaybe p0, Projectable p0 p1, ProjectableFlattenMaybe (Maybe b) c)
|
||||
=> p0 (Maybe a) -- ^ Source 'Projection'. 'Maybe' phantom type
|
||||
projectFlattenPiMaybe :: (ProjectableMaybe (Projection cont),
|
||||
Projectable Projection p1, ProjectableFlattenMaybe (Maybe b) c)
|
||||
=> Projection cont (Maybe a) -- ^ Source 'Projection'. 'Maybe' phantom type
|
||||
-> Pi a b -- ^ Projection path
|
||||
-> p1 c -- ^ Narrower 'Projection'. Flatten 'Maybe' phantom type
|
||||
-> p1 cont c -- ^ Narrower 'Projection'. Flatten 'Maybe' phantom type
|
||||
projectFlattenPiMaybe p = project . flattenPiMaybe p
|
||||
|
||||
-- | Get narrower projection with flatten leaf phantom Maybe types along with projection path
|
||||
-- and project into result projection type.
|
||||
(!??) :: (ProjectableFlattenMaybe (Maybe b) c,
|
||||
Projectable Projection p, ProjectableMaybe p)
|
||||
=> Projection (Maybe a) -- ^ Source 'Aggregation'. 'Maybe' phantom type
|
||||
Projectable Projection p, ProjectableMaybe (p cont))
|
||||
=> Projection cont (Maybe a) -- ^ Source 'Projection'. 'Maybe' phantom type
|
||||
-> Pi a b -- ^ Projection path
|
||||
-> p c -- ^ Narrower flatten and projected object.
|
||||
-> p cont c -- ^ Narrower flatten and projected object.
|
||||
(!??) = projectFlattenPiMaybe
|
||||
|
||||
-- | Get narrower aggregated projection with flatten leaf phantom Maybe types along with projection path
|
||||
-- and project into result projection type.
|
||||
(<!??>) :: (ProjectableFlattenMaybe (Maybe b) c,
|
||||
Projectable Aggregation p, ProjectableMaybe p)
|
||||
=> Aggregation (Maybe a) -- ^ Source 'Aggregation'. 'Maybe' phantom type
|
||||
Projectable Projection p, ProjectableMaybe (p cont))
|
||||
=> Projection cont (Maybe a) -- ^ Source 'Projection'. 'Maybe' phantom type
|
||||
-> Pi a b -- ^ Projection path
|
||||
-> p c -- ^ Narrower flatten and projected object.
|
||||
(<!??>) = projectFlattenPiMaybe
|
||||
-> p cont c -- ^ Narrower flatten and projected object.
|
||||
(<!??>) = (!??)
|
||||
|
||||
|
||||
-- | Interface to run recursively identity element laws.
|
||||
@ -272,5 +253,5 @@ flattenPh = runIds
|
||||
-- => p a -> p b -> p c
|
||||
-- (>?<) = generalizedZip'
|
||||
|
||||
infixl 8 !, ?!, ?!?, !??, <!>, <?!>, <?!?>, <!??>, .!, .?
|
||||
infixl 8 !, ?!, ?!?, !??, .!, .?, <!>, <?!>, <?!?>, <!??>
|
||||
-- infixl 1 >?<
|
||||
|
||||
@ -24,11 +24,14 @@ module Database.Relational.Query.Projection (
|
||||
|
||||
pi, piMaybe, piMaybe',
|
||||
|
||||
flattenMaybe, just
|
||||
flattenMaybe, just,
|
||||
|
||||
unsafeToAggregated, unsafeToFlat
|
||||
) where
|
||||
|
||||
import Prelude hiding (pi)
|
||||
|
||||
import Database.Relational.Query.Context (Aggregated, Flat)
|
||||
import Database.Relational.Query.Table (Table)
|
||||
import qualified Database.Relational.Query.Table as Table
|
||||
import Database.Relational.Query.Pi (Pi)
|
||||
@ -40,23 +43,23 @@ import Database.Relational.Query.Sub
|
||||
|
||||
|
||||
-- | Phantom typed projection. Projected into Haskell record type 't'.
|
||||
newtype Projection t = Projection { untypeProjection :: UntypedProjection }
|
||||
newtype Projection c t = Projection { untypeProjection :: UntypedProjection }
|
||||
|
||||
typedProjection :: UntypedProjection -> Projection t
|
||||
typedProjection :: UntypedProjection -> Projection c t
|
||||
typedProjection = Projection
|
||||
|
||||
units :: Projection t -> [ProjectionUnit]
|
||||
units :: Projection c t -> [ProjectionUnit]
|
||||
units = untypeProjection
|
||||
|
||||
fromUnits :: [ProjectionUnit] -> Projection t
|
||||
fromUnits :: [ProjectionUnit] -> Projection c t
|
||||
fromUnits = typedProjection
|
||||
|
||||
-- | Width of 'Projection'.
|
||||
width :: Projection r -> Int
|
||||
width :: Projection c r -> Int
|
||||
width = sum . map widthOfProjectionUnit . units where
|
||||
|
||||
-- | Get column SQL string of 'Projection'.
|
||||
column :: Projection r -- ^ Source 'Projection'
|
||||
column :: Projection c r -- ^ Source 'Projection'
|
||||
-> Int -- ^ Column index
|
||||
-> String -- ^ Result SQL string
|
||||
column = d where
|
||||
@ -68,7 +71,7 @@ column = d where
|
||||
| otherwise = rec us (i - widthOfProjectionUnit u)
|
||||
|
||||
-- | Get column SQL string list of projection.
|
||||
columns :: Projection r -- ^ Source 'Projection'
|
||||
columns :: Projection c r -- ^ Source 'Projection'
|
||||
-> [String] -- ^ Result SQL string list
|
||||
columns p = map (\n -> column p n) . take w $ [0 .. ]
|
||||
where w = width p
|
||||
@ -76,53 +79,67 @@ columns p = map (\n -> column p n) . take w $ [0 .. ]
|
||||
|
||||
-- | Unsafely generate 'Projection' from SQL string list.
|
||||
unsafeFromColumns :: [String] -- ^ SQL string list specifies columns
|
||||
-> Projection r -- ^ Result 'Projection'
|
||||
-> Projection c r -- ^ Result 'Projection'
|
||||
unsafeFromColumns = typedProjection . untypedProjectionFromColumns
|
||||
|
||||
-- | Unsafely generate 'Projection' from qualified subquery.
|
||||
unsafeFromQualifiedSubQuery :: Qualified SubQuery -> Projection t
|
||||
unsafeFromQualifiedSubQuery :: Qualified SubQuery -> Projection c t
|
||||
unsafeFromQualifiedSubQuery = typedProjection . untypedProjectionFromSubQuery
|
||||
|
||||
-- | Unsafely generate unqualified 'Projection' from 'Table'.
|
||||
unsafeFromTable :: Table r
|
||||
-> Projection r
|
||||
-> Projection c r
|
||||
unsafeFromTable = unsafeFromColumns . Table.columns
|
||||
|
||||
-- | Concatenate 'Projection'.
|
||||
compose :: Projection a -> Projection b -> Projection (c a b)
|
||||
compose :: Projection c a -> Projection c b -> Projection c (pair a b)
|
||||
compose a b = fromUnits $ units a ++ units b
|
||||
|
||||
|
||||
-- | Unsafely trace projection path.
|
||||
unsafeProject :: Projection a' -> Pi a b -> Projection b'
|
||||
unsafeProject :: Projection c a' -> Pi a b -> Projection c b'
|
||||
unsafeProject p pi' =
|
||||
unsafeFromColumns
|
||||
. (`UnsafePi.pi` pi')
|
||||
. columns $ p
|
||||
|
||||
-- | Trace projection path to get narrower 'Projection'.
|
||||
pi :: Projection a -- ^ Source 'Projection'
|
||||
pi :: Projection c a -- ^ Source 'Projection'
|
||||
-> Pi a b -- ^ Projection path
|
||||
-> Projection b -- ^ Narrower 'Projection'
|
||||
-> Projection c b -- ^ Narrower 'Projection'
|
||||
pi = unsafeProject
|
||||
|
||||
-- | Trace projection path to get narrower 'Projection'. From 'Maybe' type to 'Maybe' type.
|
||||
piMaybe :: Projection (Maybe a) -- ^ Source 'Projection'. 'Maybe' type
|
||||
piMaybe :: Projection c (Maybe a) -- ^ Source 'Projection'. 'Maybe' type
|
||||
-> Pi a b -- ^ Projection path
|
||||
-> Projection (Maybe b) -- ^ Narrower 'Projection'. 'Maybe' type result
|
||||
-> Projection c (Maybe b) -- ^ Narrower 'Projection'. 'Maybe' type result
|
||||
piMaybe = unsafeProject
|
||||
|
||||
-- | Trace projection path to get narrower 'Projection'. From 'Maybe' type to 'Maybe' type.
|
||||
-- Leaf type of projection path is 'Maybe'.
|
||||
piMaybe' :: Projection (Maybe a) -- ^ Source 'Projection'. 'Maybe' type
|
||||
piMaybe' :: Projection c (Maybe a) -- ^ Source 'Projection'. 'Maybe' type
|
||||
-> Pi a (Maybe b) -- ^ Projection path. 'Maybe' type leaf
|
||||
-> Projection (Maybe b) -- ^ Narrower 'Projection'. 'Maybe' type result
|
||||
-> Projection c (Maybe b) -- ^ Narrower 'Projection'. 'Maybe' type result
|
||||
piMaybe' = unsafeProject
|
||||
|
||||
unsafeCast :: Projection c r -> Projection c r'
|
||||
unsafeCast = typedProjection . untypeProjection
|
||||
|
||||
-- | Composite nested 'Maybe' on projection phantom type.
|
||||
flattenMaybe :: Projection (Maybe (Maybe a)) -> Projection (Maybe a)
|
||||
flattenMaybe = typedProjection . untypeProjection
|
||||
flattenMaybe :: Projection c (Maybe (Maybe a)) -> Projection c (Maybe a)
|
||||
flattenMaybe = unsafeCast
|
||||
|
||||
-- | Cast into 'Maybe' on projection phantom type.
|
||||
just :: Projection r -> Projection (Maybe r)
|
||||
just = typedProjection . untypeProjection
|
||||
just :: Projection c r -> Projection c (Maybe r)
|
||||
just = unsafeCast
|
||||
|
||||
unsafeChangeContext :: Projection c r -> Projection c' r
|
||||
unsafeChangeContext = typedProjection . untypeProjection
|
||||
|
||||
-- | Unsafely lift to aggregated context.
|
||||
unsafeToAggregated :: Projection Flat r -> Projection Aggregated r
|
||||
unsafeToAggregated = unsafeChangeContext
|
||||
|
||||
-- | Unsafely down to flat context.
|
||||
unsafeToFlat :: Projection Aggregated r -> Projection Flat r
|
||||
unsafeToFlat = unsafeChangeContext
|
||||
|
||||
@ -38,6 +38,7 @@ module Database.Relational.Query.Relation (
|
||||
union', except', intersect'
|
||||
) where
|
||||
|
||||
import Database.Relational.Query.Context (Flat, Aggregated)
|
||||
import Database.Relational.Query.Monad.Qualify (Qualify, evalQualifyPrime, qualifyQuery)
|
||||
import Database.Relational.Query.Monad.Class
|
||||
(MonadQualify (liftQualify), MonadQuery (unsafeSubQuery), on)
|
||||
@ -52,7 +53,6 @@ import Database.Relational.Query.Internal.Product (NodeAttr(Just', Maybe))
|
||||
|
||||
import Database.Relational.Query.Projection (Projection)
|
||||
import qualified Database.Relational.Query.Projection as Projection
|
||||
import Database.Relational.Query.Aggregation (Aggregation)
|
||||
import Database.Relational.Query.Projectable
|
||||
(PlaceHolders, addPlaceHolders, projectZip)
|
||||
|
||||
@ -84,7 +84,7 @@ subQueryQualifyFromRelation = d where
|
||||
|
||||
-- | Basic monadic join operation using 'MonadQuery'.
|
||||
queryWithAttr :: MonadQualify Qualify m
|
||||
=> NodeAttr -> Relation p r -> m (PlaceHolders p, Projection r)
|
||||
=> NodeAttr -> Relation p r -> m (PlaceHolders p, Projection Flat r)
|
||||
queryWithAttr attr = addPlaceHolders . run where
|
||||
run rel = do
|
||||
q <- liftQualify $ do
|
||||
@ -94,42 +94,42 @@ queryWithAttr attr = addPlaceHolders . run where
|
||||
-- d (Relation q) = unsafeMergeAnotherQuery attr q
|
||||
|
||||
-- | Join subquery with place-holder parameter 'p'. query result is not 'Maybe'.
|
||||
query' :: MonadQualify Qualify m => Relation p r -> m (PlaceHolders p, Projection r)
|
||||
query' :: MonadQualify Qualify m => Relation p r -> m (PlaceHolders p, Projection Flat r)
|
||||
query' = queryWithAttr Just'
|
||||
|
||||
-- | Join subquery. Query result is not 'Maybe'.
|
||||
query :: MonadQualify Qualify m => Relation () r -> m (Projection r)
|
||||
query :: MonadQualify Qualify m => Relation () r -> m (Projection Flat r)
|
||||
query = fmap snd . query'
|
||||
|
||||
-- | Join subquery with place-holder parameter 'p'. Query result is 'Maybe'.
|
||||
queryMaybe' :: MonadQualify Qualify m => Relation p r -> m (PlaceHolders p, Projection (Maybe r))
|
||||
queryMaybe' :: MonadQualify Qualify m => Relation p r -> m (PlaceHolders p, Projection Flat (Maybe r))
|
||||
queryMaybe' pr = do
|
||||
(ph, pj) <- queryWithAttr Maybe pr
|
||||
return (ph, Projection.just pj)
|
||||
|
||||
-- | Join subquery. Query result is 'Maybe'.
|
||||
queryMaybe :: MonadQualify Qualify m => Relation () r -> m (Projection (Maybe r))
|
||||
queryMaybe :: MonadQualify Qualify m => Relation () r -> m (Projection Flat (Maybe r))
|
||||
queryMaybe = fmap snd . queryMaybe'
|
||||
|
||||
-- | Finalize 'QuerySimple' monad and generate 'Relation'.
|
||||
relation :: QuerySimple (Projection r) -> Relation () r
|
||||
relation :: QuerySimple (Projection Flat r) -> Relation () r
|
||||
relation = SimpleRel
|
||||
|
||||
-- | Finalize 'QuerySimple' monad and generate 'Relation' with place-holder parameter 'p'.
|
||||
relation' :: QuerySimple (PlaceHolders p, Projection r) -> Relation p r
|
||||
relation' :: QuerySimple (PlaceHolders p, Projection Flat r) -> Relation p r
|
||||
relation' = SimpleRel . fmap snd
|
||||
|
||||
-- | Finalize 'QueryAggregate' monad and geneate 'Relation'.
|
||||
aggregateRelation :: QueryAggregate (Aggregation r) -> Relation () r
|
||||
aggregateRelation :: QueryAggregate (Projection Aggregated r) -> Relation () r
|
||||
aggregateRelation = AggregateRel
|
||||
|
||||
-- | Finalize 'QueryAggregate' monad and geneate 'Relation' with place-holder parameter 'p'.
|
||||
aggregateRelation' :: QueryAggregate (PlaceHolders p, Aggregation r) -> Relation p r
|
||||
aggregateRelation' :: QueryAggregate (PlaceHolders p, Projection Aggregated r) -> Relation p r
|
||||
aggregateRelation' = AggregateRel . fmap snd
|
||||
|
||||
|
||||
-- | Restriction function type for direct style join operator.
|
||||
type JoinRestriction a b = Projection a -> Projection b -> Projection (Maybe Bool)
|
||||
type JoinRestriction a b = Projection Flat a -> Projection Flat b -> Projection Flat (Maybe Bool)
|
||||
|
||||
unsafeCastPlaceHolder :: Relation a r -> Relation b r
|
||||
unsafeCastPlaceHolder = d where
|
||||
@ -146,8 +146,8 @@ leftPh :: Relation (p, ()) r -> Relation p r
|
||||
leftPh = unsafeCastPlaceHolder
|
||||
|
||||
-- | Basic direct join operation with place-holder parameters.
|
||||
join' :: (qa -> QuerySimple (PlaceHolders pa, Projection a))
|
||||
-> (qb -> QuerySimple (PlaceHolders pb, Projection b))
|
||||
join' :: (qa -> QuerySimple (PlaceHolders pa, Projection Flat a))
|
||||
-> (qb -> QuerySimple (PlaceHolders pb, Projection Flat b))
|
||||
-> qa
|
||||
-> qb
|
||||
-> [JoinRestriction a b]
|
||||
@ -187,8 +187,8 @@ full' :: Relation pa a -- ^ Left query to join
|
||||
full' = join' queryMaybe' queryMaybe'
|
||||
|
||||
-- | Basic direct join operation.
|
||||
join :: (qa -> QuerySimple (Projection a))
|
||||
-> (qb -> QuerySimple (Projection b))
|
||||
join :: (qa -> QuerySimple (Projection Flat a))
|
||||
-> (qb -> QuerySimple (Projection Flat b))
|
||||
-> qa
|
||||
-> qb
|
||||
-> [JoinRestriction a b]
|
||||
|
||||
@ -25,6 +25,7 @@ module Database.Relational.Query.Restriction (
|
||||
|
||||
import Database.Record (PersistableWidth)
|
||||
|
||||
import Database.Relational.Query.Context (Flat)
|
||||
import Database.Relational.Query.Pi (id')
|
||||
import Database.Relational.Query.Table (Table)
|
||||
import Database.Relational.Query.Projection (Projection)
|
||||
@ -38,14 +39,15 @@ import Database.Relational.Query.Monad.Trans.Restricting (prependWhere)
|
||||
import Database.Relational.Query.Monad.Restrict (Restrict, RestrictedStatement, expandWhere)
|
||||
import Database.Relational.Query.Monad.Target (Target, TargetStatement, expandPrepend)
|
||||
|
||||
|
||||
-- | Restriction type with place-holder parameter 'p' and projection record type 'r'.
|
||||
newtype Restriction p r = Restriction (Projection r -> Restrict ())
|
||||
newtype Restriction p r = Restriction (Projection Flat r -> Restrict ())
|
||||
|
||||
-- | Not finalized 'Restrict' monad type.
|
||||
type RestrictionContext p r = RestrictedStatement r (PlaceHolders p)
|
||||
|
||||
-- | Finalize 'Restrict' monad and generate 'Restriction'.
|
||||
restriction :: (Projection r -> Restrict ()) -> Restriction () r
|
||||
restriction :: (Projection Flat r -> Restrict ()) -> Restriction () r
|
||||
restriction = Restriction
|
||||
|
||||
-- | Finalize 'Restrict' monad and generate 'Restriction' with place-holder parameter 'p'
|
||||
@ -65,13 +67,13 @@ sqlWhereFromRestriction tbl (Restriction q) = prependWhere aw
|
||||
|
||||
-- | UpdateTarget type with place-holder parameter 'p' and projection record type 'r'.
|
||||
newtype UpdateTarget p r =
|
||||
UpdateTarget (Table r -> Projection r -> Target r ())
|
||||
UpdateTarget (Table r -> Projection Flat r -> Target r ())
|
||||
|
||||
-- | Not finalized 'Target' monad type.
|
||||
type UpdateTargetContext p r = TargetStatement r (PlaceHolders p)
|
||||
|
||||
-- | Finalize 'Target' monad and generate 'UpdateTarget'.
|
||||
updateTarget :: (Table r -> Projection r -> Target r ())
|
||||
updateTarget :: (Table r -> Projection Flat r -> Target r ())
|
||||
-> UpdateTarget () r
|
||||
updateTarget = UpdateTarget
|
||||
|
||||
@ -107,13 +109,13 @@ liftTargetAllColumn' rs = updateTarget' $ updateAllColumn rs
|
||||
|
||||
-- | Finalize 'Restrict' monad and generate 'UpdateTarget'. Update target columns are all.
|
||||
updateTargetAllColumn :: PersistableWidth r
|
||||
=> (Projection r -> Restrict ())
|
||||
=> (Projection Flat r -> Restrict ())
|
||||
-> UpdateTarget r r
|
||||
updateTargetAllColumn = liftTargetAllColumn . restriction
|
||||
|
||||
-- | Finalize 'Restrict' monad and generate 'UpdateTarget'. Update target columns are all. With placefolder type 'p'.
|
||||
updateTargetAllColumn' :: PersistableWidth r
|
||||
=> (Projection r -> Restrict (PlaceHolders p))
|
||||
=> (Projection Flat r -> Restrict (PlaceHolders p))
|
||||
-> UpdateTarget (r, p) r
|
||||
updateTargetAllColumn' = liftTargetAllColumn' . restriction'
|
||||
|
||||
|
||||
@ -39,7 +39,7 @@ import qualified Database.Relational.Query.Projection as Projection
|
||||
|
||||
|
||||
-- | Generate select SQL. Seed SQL string append to this.
|
||||
selectSeedSQL :: Projection r -> ShowS
|
||||
selectSeedSQL :: Projection c r -> ShowS
|
||||
selectSeedSQL pj =
|
||||
(unwordsSQL [SELECT, columns' `SQL.sepBy` ", "] ++)
|
||||
where columns' = zipWith
|
||||
|
||||
Loading…
Reference in New Issue
Block a user