Add Aggregation type distinguished from Projection type.

Add projection type (Aggregation) for aggregation
which is distinguished from not aggregated projection type (Projection).

relational-join/src/Database/Relational/Query/Aggregation.hs

@@ -0,0 +1,52 @@
+{-# LANGUAGE FlexibleContexts #-}
+
+module Database.Relational.Query.Aggregation (
+  Aggregation, projection,
+  liftAggregation,
+
+  compose,
+
+  just, flattenMaybe,
+
+  pi, piMaybe,
+
+  unsafeFromProjection
+  ) where
+
+import Prelude hiding (pi)
+
+import Database.Record (PersistableWidth)
+
+import Database.Relational.Query.Projection (Projection)
+import qualified Database.Relational.Query.Projection as Projection
+import Database.Relational.Query.Pi (Pi)
+
+
+newtype Aggregation r = Aggregation (Projection r)
+
+projection :: Aggregation r -> Projection r
+projection (Aggregation p) = p
+
+liftAggregation ::  (Projection a -> Projection b) -> Aggregation a -> Aggregation b
+liftAggregation f = Aggregation . f . projection
+
+unsafeFromProjection :: Projection r -> Aggregation r
+unsafeFromProjection =  Aggregation
+
+compose :: Aggregation a -> Aggregation b -> Aggregation (c a b)
+compose (Aggregation a) (Aggregation b) = Aggregation $ a `Projection.compose` b
+
+just :: Aggregation a -> Aggregation (Maybe a)
+just =  liftAggregation Projection.just
+
+flattenMaybe :: Aggregation (Maybe (Maybe a)) -> Aggregation (Maybe a)
+flattenMaybe =  liftAggregation Projection.flattenMaybe
+
+definePi :: (Projection a -> Pi a' b' -> Projection b) -> Aggregation a -> Pi a' b' -> Aggregation b
+definePi (!!!) p pi' = liftAggregation (!!! pi') p
+
+pi :: PersistableWidth b => Aggregation a -> Pi a b -> Aggregation b
+pi =  definePi Projection.pi
+
+piMaybe :: PersistableWidth b => Aggregation (Maybe a) -> Pi a b -> Aggregation (Maybe b)
+piMaybe = definePi Projection.piMaybe

relational-join/src/Database/Relational/Query/Projectable.hs

@@ -1,6 +1,8 @@
 module Database.Relational.Query.Projectable (
   Projectable (project),
 
+  projectAggregation,
+
   value,
 
   valueTrue, valueFalse,
@@ -10,6 +12,9 @@ module Database.Relational.Query.Projectable (
   SqlProjectable (unsafeProjectSql),
   valueNull, placeholder,
 
+  unsafeAggregateOp,
+  count, sum', avg, max', min', every, any', some',
+
   ProjectableShowSql (unsafeShowSql),
   unsafeBinOp,
 
@@ -25,6 +30,7 @@ module Database.Relational.Query.Projectable (
 
 import Prelude hiding (and, or)
 
+import Data.Int (Int32)
 import Data.List (intercalate)
 
 import qualified Language.SQL.Keyword as SQL
@@ -37,6 +43,9 @@ import qualified Database.Relational.Query.Expr.Unsafe as UnsafeExpr
 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
+
 
 sqlString :: Projection r -> String
 sqlString =  d . columns  where
@@ -56,10 +65,13 @@ instance Projectable Projection where
 instance Projectable Expr where
   project = toExpr
 
+projectAggregation :: Projectable p => Aggregation a -> p a
+projectAggregation =  project . Aggregation.projection
+
+
 unsafeSqlProjection :: String -> Projection t
 unsafeSqlProjection =  unsafeFromColumns . (:[])
 
-
 class SqlProjectable p where
   unsafeProjectSql :: String -> p t
 
@@ -69,6 +81,9 @@ instance SqlProjectable Projection where
 instance SqlProjectable Expr where
   unsafeProjectSql = UnsafeExpr.Expr
 
+instance SqlProjectable Aggregation where
+  unsafeProjectSql = Aggregation.unsafeFromProjection . unsafeProjectSql
+
 valueNull :: SqlProjectable p => p (Maybe a)
 valueNull =  unsafeProjectSql "NULL"
 
@@ -97,6 +112,43 @@ instance ProjectableShowSql Projection where
 instance ProjectableShowSql Expr where
   unsafeShowSql = UnsafeExpr.showExpr
 
+instance ProjectableShowSql Aggregation where
+  unsafeShowSql = unsafeShowSql . Aggregation.projection
+
+
+paren :: String -> String
+paren =  ('(' :) . (++[')'])
+
+type SqlUniOp = String -> String
+
+sqlUniOp :: SQL.Keyword -> SqlUniOp
+sqlUniOp kw = (SQL.wordShow kw ++) . (' ' :) . paren
+
+unsafeAggregateOp :: SQL.Keyword
+                  -> Projection a -> Aggregation b
+unsafeAggregateOp op = unsafeProjectSql . sqlUniOp op . unsafeShowSql
+
+count :: Projection a -> Aggregation Int32
+count =  unsafeAggregateOp SQL.COUNT
+
+sum'  :: Num a => Projection a -> Aggregation a
+sum'  =  unsafeAggregateOp SQL.SUM
+
+avg   :: (Num a, Fractional b)=> Projection a -> Aggregation b
+avg   =  unsafeAggregateOp SQL.AVG
+
+max'  :: Ord a => Projection a -> Aggregation a
+max'  =  unsafeAggregateOp SQL.MAX
+
+min'  :: Ord a => Projection a -> Aggregation a
+min'  =  unsafeAggregateOp SQL.MIN
+
+every =  unsafeAggregateOp SQL.EVERY
+any'  =  unsafeAggregateOp SQL.ANY
+some' =  unsafeAggregateOp SQL.SOME
+
+every, any', some' :: Projection Bool -> Aggregation Bool
+
 
 type SqlBinOp = String -> String -> String
 
@@ -108,7 +160,6 @@ unsafeBinOp :: (SqlProjectable p, ProjectableShowSql p)
             -> p a -> p b -> p c
 unsafeBinOp op a b = unsafeProjectSql . paren
                      $ op (unsafeShowSql a) (unsafeShowSql b)
-  where paren = ('(' :) . (++[')'])
 
 compareBinOp :: (SqlProjectable p, ProjectableShowSql p)
              => SqlBinOp
@@ -177,6 +228,9 @@ instance ProjectableZip PlaceHolders where
 instance ProjectableZip Projection where
   projectZip = Projection.compose
 
+instance ProjectableZip Aggregation where
+  projectZip = Aggregation.compose
+
 (><) ::ProjectableZip p => p a -> p b -> p (a, b)
 (><) = projectZip
 
@@ -196,6 +250,10 @@ instance ProjectableMaybe Expr where
   just         = Expr.just
   flattenMaybe = Expr.flattenMaybe
 
+instance ProjectableMaybe Aggregation where
+  just         = Aggregation.just
+  flattenMaybe = Aggregation.flattenMaybe
+
 
 infixl 7 .*., ./.
 infixl 6 .+., .-.

relational-join/src/Database/Relational/Query/ProjectableExtended.hs

@@ -5,10 +5,13 @@
 module Database.Relational.Query.ProjectableExtended (
   ProjectableFlattenMaybe (flatten),
   
-  piMaybeFlatten,
+  piMaybe',
 
   (!), (!?), (!??),
 
+  piMaybeAggregation',
+  (<!>), (<!?>), (<!??>),
+
   ProjectableGeneralizedZip (generalizedZip), (>?<)
   )  where
 
@@ -16,8 +19,11 @@ import Database.Record (PersistableWidth)
 
 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.Projectable
-  (Projectable(project), ProjectableMaybe (flattenMaybe), ProjectableZip(projectZip))
+  (Projectable(project), projectAggregation,
+   ProjectableMaybe (flattenMaybe), ProjectableZip(projectZip))
 import Database.Relational.Query.Pi (Pi)
 
 class ProjectableFlattenMaybe a b where
@@ -38,14 +44,38 @@ p ! pi' = project $ Projection.pi p pi'
         => Projection (Maybe a) -> Pi a b -> p (Maybe b)
 p !? pi' = project $ Projection.piMaybe p pi'
 
-piMaybeFlatten :: (PersistableWidth b, ProjectableFlattenMaybe c (Maybe a))
+piMaybe' :: (PersistableWidth b, ProjectableFlattenMaybe c (Maybe a))
                => Projection c -> Pi a b -> Projection (Maybe b)
-piMaybeFlatten = Projection.piMaybe . flatten
+piMaybe' = Projection.piMaybe . flatten
 
 (!??) :: (PersistableWidth b, ProjectableFlattenMaybe c (Maybe a),
           Projectable p, ProjectableMaybe p)
       => Projection c -> Pi a b -> p (Maybe b)
-p !?? pi' = project $ piMaybeFlatten p pi'
+p !?? pi' = project $ piMaybe' p pi'
+
+
+piMaybeAggregation' :: (PersistableWidth b, ProjectableFlattenMaybe c (Maybe a))
+                    => Aggregation c -> Pi a b -> Aggregation (Maybe b)
+piMaybeAggregation' = Aggregation.piMaybe . flatten
+
+(<!>) :: (PersistableWidth b, Projectable p)
+      => Aggregation a
+      -> Pi a b
+      -> p b
+(<!>) a = projectAggregation . Aggregation.pi a
+
+(<!?>) :: (PersistableWidth b, Projectable p)
+       => Aggregation (Maybe a)
+       -> Pi a b
+       -> p (Maybe b)
+(<!?>) a = projectAggregation . Aggregation.piMaybe a
+
+(<!??>) :: (PersistableWidth b, Projectable p, ProjectableFlattenMaybe c (Maybe a))
+        => Aggregation c
+        -> Pi a b
+        -> p (Maybe b)
+(<!??>) a = projectAggregation . piMaybeAggregation' a
+
 
 class ProjectableGeneralizedZip a b c where
   generalizedZip :: ProjectableZip p => p a -> p b -> p c