diff --git a/relational-join/relational-join.cabal b/relational-join/relational-join.cabal index 11bbd71b..ee0a974f 100644 --- a/relational-join/relational-join.cabal +++ b/relational-join/relational-join.cabal @@ -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 diff --git a/relational-join/src/Database/Relational/Query.hs b/relational-join/src/Database/Relational/Query.hs index 7fa99c26..f1a4b6b3 100644 --- a/relational-join/src/Database/Relational/Query.hs +++ b/relational-join/src/Database/Relational/Query.hs @@ -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 diff --git a/relational-join/src/Database/Relational/Query/Aggregation.hs b/relational-join/src/Database/Relational/Query/Aggregation.hs deleted file mode 100644 index c1761dee..00000000 --- a/relational-join/src/Database/Relational/Query/Aggregation.hs +++ /dev/null @@ -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 diff --git a/relational-join/src/Database/Relational/Query/Expr/Unsafe.hs b/relational-join/src/Database/Relational/Query/Expr/Unsafe.hs index 7b2865d6..cc814b4e 100644 --- a/relational-join/src/Database/Relational/Query/Expr/Unsafe.hs +++ b/relational-join/src/Database/Relational/Query/Expr/Unsafe.hs @@ -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 diff --git a/relational-join/src/Database/Relational/Query/Internal/Product.hs b/relational-join/src/Database/Relational/Query/Internal/Product.hs index 4d7f1b2e..18f7145d 100644 --- a/relational-join/src/Database/Relational/Query/Internal/Product.hs +++ b/relational-join/src/Database/Relational/Query/Internal/Product.hs @@ -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 diff --git a/relational-join/src/Database/Relational/Query/Monad/Aggregate.hs b/relational-join/src/Database/Relational/Query/Monad/Aggregate.hs index ca1a24e6..39d4199f 100644 --- a/relational-join/src/Database/Relational/Query/Monad/Aggregate.hs +++ b/relational-join/src/Database/Relational/Query/Monad/Aggregate.hs @@ -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) diff --git a/relational-join/src/Database/Relational/Query/Monad/Class.hs b/relational-join/src/Database/Relational/Query/Monad/Class.hs index 5affee4e..0e729dbc 100644 --- a/relational-join/src/Database/Relational/Query/Monad/Class.hs +++ b/relational-join/src/Database/Relational/Query/Monad/Class.hs @@ -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,21 +31,21 @@ 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 - -> m () -- ^ Restricted query context + 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 -- -> m () -- ^ Restricted query context -- | 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. + unsafeSubQuery :: NodeAttr -- ^ Attribute maybe or just + -> Qualified SubQuery -- ^ 'SubQuery' to join + -> 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 diff --git a/relational-join/src/Database/Relational/Query/Monad/Restrict.hs b/relational-join/src/Database/Relational/Query/Monad/Restrict.hs index a53467f3..b65affe3 100644 --- a/relational-join/src/Database/Relational/Query/Monad/Restrict.hs +++ b/relational-join/src/Database/Relational/Query/Monad/Restrict.hs @@ -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 diff --git a/relational-join/src/Database/Relational/Query/Monad/Simple.hs b/relational-join/src/Database/Relational/Query/Monad/Simple.hs index 5a882170..3f4eecfa 100644 --- a/relational-join/src/Database/Relational/Query/Monad/Simple.hs +++ b/relational-join/src/Database/Relational/Query/Monad/Simple.hs @@ -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) diff --git a/relational-join/src/Database/Relational/Query/Monad/Target.hs b/relational-join/src/Database/Relational/Query/Monad/Target.hs index ba35bb7c..9a00393b 100644 --- a/relational-join/src/Database/Relational/Query/Monad/Target.hs +++ b/relational-join/src/Database/Relational/Query/Monad/Target.hs @@ -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 diff --git a/relational-join/src/Database/Relational/Query/Monad/Trans/Aggregating.hs b/relational-join/src/Database/Relational/Query/Monad/Trans/Aggregating.hs index cd560f7c..e5cea3c9 100644 --- a/relational-join/src/Database/Relational/Query/Monad/Trans/Aggregating.hs +++ b/relational-join/src/Database/Relational/Query/Monad/Trans/Aggregating.hs @@ -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 - -> Aggregatings m () -- ^ Result restricted context + => 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 diff --git a/relational-join/src/Database/Relational/Query/Monad/Trans/AggregatingState.hs b/relational-join/src/Database/Relational/Query/Monad/Trans/AggregatingState.hs index 582a9fc0..33c36bc6 100644 --- a/relational-join/src/Database/Relational/Query/Monad/Trans/AggregatingState.hs +++ b/relational-join/src/Database/Relational/Query/Monad/Trans/AggregatingState.hs @@ -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 diff --git a/relational-join/src/Database/Relational/Query/Monad/Trans/Assigning.hs b/relational-join/src/Database/Relational/Query/Monad/Trans/Assigning.hs index 54cf5f4d..fa2071df 100644 --- a/relational-join/src/Database/Relational/Query/Monad/Trans/Assigning.hs +++ b/relational-join/src/Database/Relational/Query/Monad/Trans/Assigning.hs @@ -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 !# diff --git a/relational-join/src/Database/Relational/Query/Monad/Trans/Join.hs b/relational-join/src/Database/Relational/Query/Monad/Trans/Join.hs index 9d110dac..4d1b9861 100644 --- a/relational-join/src/Database/Relational/Query/Monad/Trans/Join.hs +++ b/relational-join/src/Database/Relational/Query/Monad/Trans/Join.hs @@ -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) @@ -82,9 +83,9 @@ instance (Monad q, Functor q) => MonadQuery (QueryJoin q) where -- | Unsafely join subquery with this query. unsafeSubQueryWithAttr :: Monad q - => NodeAttr -- ^ Attribute maybe or just - -> Qualified SubQuery -- ^ 'SubQuery' to join - -> QueryJoin q (Projection r) -- ^ Result joined context and 'SubQuery' result projection. + => NodeAttr -- ^ Attribute maybe or just + -> Qualified SubQuery -- ^ 'SubQuery' to join + -> 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 diff --git a/relational-join/src/Database/Relational/Query/Monad/Trans/Ordering.hs b/relational-join/src/Database/Relational/Query/Monad/Trans/Ordering.hs index 1c9d4e8f..2d49af5a 100644 --- a/relational-join/src/Database/Relational/Query/Monad/Trans/Ordering.hs +++ b/relational-join/src/Database/Relational/Query/Monad/Trans/Ordering.hs @@ -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 - -> Orderings p m () -- ^ Result context with ordering +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 diff --git a/relational-join/src/Database/Relational/Query/Monad/Trans/Restricting.hs b/relational-join/src/Database/Relational/Query/Monad/Trans/Restricting.hs index f33ec2cb..4739e96b 100644 --- a/relational-join/src/Database/Relational/Query/Monad/Trans/Restricting.hs +++ b/relational-join/src/Database/Relational/Query/Monad/Trans/Restricting.hs @@ -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. diff --git a/relational-join/src/Database/Relational/Query/Monad/Trans/RestrictingState.hs b/relational-join/src/Database/Relational/Query/Monad/Trans/RestrictingState.hs index e5641966..57fe279d 100644 --- a/relational-join/src/Database/Relational/Query/Monad/Trans/RestrictingState.hs +++ b/relational-join/src/Database/Relational/Query/Monad/Trans/RestrictingState.hs @@ -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. diff --git a/relational-join/src/Database/Relational/Query/Projectable.hs b/relational-join/src/Database/Relational/Query/Projectable.hs index 949dde7c..b62b173b 100644 --- a/relational-join/src/Database/Relational/Query/Projectable.hs +++ b/relational-join/src/Database/Relational/Query/Projectable.hs @@ -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,23 +84,16 @@ 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 - expr = exprOfProjection - -instance ExpressionProjectable Aggregation where - expr = UnsafeExpr.Expr . sqlStringOfProjection . Aggregation.unsafeProjection +-- | Project from Projection type into expression type. +expr :: Projection p a -> Expr p a +expr = exprOfProjection -- | Projection interface. class ProjectablePi p where @@ -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 diff --git a/relational-join/src/Database/Relational/Query/ProjectableExtended.hs b/relational-join/src/Database/Relational/Query/ProjectableExtended.hs index 445a9b0f..57ced7b1 100644 --- a/relational-join/src/Database/Relational/Query/ProjectableExtended.hs +++ b/relational-join/src/Database/Relational/Query/ProjectableExtended.hs @@ -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' - -> Pi a b -- ^ Projection path - -> p b -- ^ Narrower projected object -() = projectPi +() :: Projectable Projection p + => Projection c a -- ^ Source projection + -> Pi a b -- ^ Projection path + -> 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 - -> Pi a b -- ^ Projection path - -> p (Maybe b) -- ^ Narrower projected object. 'Maybe' phantom type result -() = projectPiMaybe +() :: Projectable Projection p + => Projection c (Maybe a) -- ^ Source 'Projection'. 'Maybe' type + -> Pi a b -- ^ Projection path + -> 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 - -> Pi a (Maybe b) -- ^ Projection path. 'Maybe' type leaf - -> p (Maybe b) -- ^ Narrower projected object. 'Maybe' phantom type result -() = projectPiMaybe' +() :: Projectable Projection p + => Projection c (Maybe a) -- ^ Source 'Projection'. 'Maybe' phantom type + -> Pi a (Maybe b) -- ^ Projection path. 'Maybe' type leaf + -> 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 - -> Pi a b -- ^ Projection path - -> p1 c -- ^ Narrower 'Projection'. Flatten '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 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 - -> Pi a b -- ^ Projection path - -> p c -- ^ Narrower flatten and projected object. + Projectable Projection p, ProjectableMaybe (p cont)) + => Projection cont (Maybe a) -- ^ Source 'Projection'. 'Maybe' phantom type + -> Pi a b -- ^ Projection path + -> 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 - -> Pi a b -- ^ Projection path - -> p c -- ^ Narrower flatten and projected object. -() = projectFlattenPiMaybe + Projectable Projection p, ProjectableMaybe (p cont)) + => Projection cont (Maybe a) -- ^ Source 'Projection'. 'Maybe' phantom type + -> Pi a b -- ^ Projection path + -> 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 >?< diff --git a/relational-join/src/Database/Relational/Query/Projection.hs b/relational-join/src/Database/Relational/Query/Projection.hs index f3edf420..9a77d4fd 100644 --- a/relational-join/src/Database/Relational/Query/Projection.hs +++ b/relational-join/src/Database/Relational/Query/Projection.hs @@ -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,25 +43,25 @@ 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' - -> Int -- ^ Column index - -> String -- ^ Result SQL string +column :: Projection c r -- ^ Source 'Projection' + -> Int -- ^ Column index + -> String -- ^ Result SQL string column = d where d proj i' = rec (units proj) i' where rec [] _ = error $ "index out of bounds: " ++ show i' @@ -68,61 +71,75 @@ column = d where | otherwise = rec us (i - widthOfProjectionUnit u) -- | Get column SQL string list of projection. -columns :: Projection r -- ^ Source 'Projection' - -> [String] -- ^ Result SQL string list +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 -- | Unsafely generate 'Projection' from SQL string list. -unsafeFromColumns :: [String] -- ^ SQL string list specifies columns - -> Projection r -- ^ Result 'Projection' +unsafeFromColumns :: [String] -- ^ SQL string list specifies columns + -> 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 a b -- ^ Projection path - -> Projection b -- ^ Narrower 'Projection' +pi :: Projection c a -- ^ Source 'Projection' + -> Pi a b -- ^ Projection path + -> 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 - -> Pi a b -- ^ Projection path - -> Projection (Maybe b) -- ^ Narrower 'Projection'. 'Maybe' type result +piMaybe :: Projection c (Maybe a) -- ^ Source 'Projection'. 'Maybe' type + -> Pi a b -- ^ Projection path + -> 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 - -> Pi a (Maybe b) -- ^ Projection path. 'Maybe' type leaf - -> Projection (Maybe b) -- ^ Narrower 'Projection'. 'Maybe' type result +piMaybe' :: Projection c (Maybe a) -- ^ Source 'Projection'. 'Maybe' type + -> Pi a (Maybe b) -- ^ Projection path. 'Maybe' type leaf + -> 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 diff --git a/relational-join/src/Database/Relational/Query/Relation.hs b/relational-join/src/Database/Relational/Query/Relation.hs index 4b1f6295..97af20e2 100644 --- a/relational-join/src/Database/Relational/Query/Relation.hs +++ b/relational-join/src/Database/Relational/Query/Relation.hs @@ -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] diff --git a/relational-join/src/Database/Relational/Query/Restriction.hs b/relational-join/src/Database/Relational/Query/Restriction.hs index bdd26f7d..0e8196e8 100644 --- a/relational-join/src/Database/Relational/Query/Restriction.hs +++ b/relational-join/src/Database/Relational/Query/Restriction.hs @@ -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' diff --git a/relational-join/src/Database/Relational/Query/SQL.hs b/relational-join/src/Database/Relational/Query/SQL.hs index 71c7d5a9..be2202e0 100644 --- a/relational-join/src/Database/Relational/Query/SQL.hs +++ b/relational-join/src/Database/Relational/Query/SQL.hs @@ -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