Add aggregate{Just,Left,Right,This,That,Those,Here,There}Table{,1} …

…aggregators (#333)

These provide another way to do aggregation of `MaybeTable`, `EitherTable` and `TheseTable`s than the existing `aggregate{Maybe,Either,These}Table`.

changelog.d/20240527_022306_shane.obrien_aggregateJustTable.md

@@ -0,0 +1,5 @@
+### Added
+
+- Add `aggregateJustTable`, `aggregateJustTable` aggregator functions. These provide another way to do aggregation of `MaybeTable`s than the existing `aggregateMaybeTable` function.
+- Add `aggregateLeftTable`, `aggregateLeftTable1`, `aggregateRightTable` and `aggregateRightTable1` aggregator functions. These provide another way to do aggregation of `EitherTable`s than the existing `aggregateEitherTable` function.
+- Add `aggregateThisTable`, `aggregateThisTable1`, `aggregateThatTable`, `aggregateThatTable1`, `aggregateThoseTable`, `aggregateThoseTable1`, `aggregateHereTable`, `aggregateHereTable1`, `aggregateThereTable` and `aggregateThereTable1` aggregation functions. These provide another way to do aggregation of `TheseTable`s than the existing `aggregateTheseTable` function.

rel8.cabal

@@ -185,6 +185,7 @@ library
     Rel8.Table
     Rel8.Table.ADT
     Rel8.Table.Aggregate
+    Rel8.Table.Aggregate.Maybe
     Rel8.Table.Alternative
     Rel8.Table.Bool
     Rel8.Table.Cols

src/Rel8.hs

@@ -66,6 +66,7 @@ module Rel8
   , optional
   , catMaybeTable
   , traverseMaybeTable
+  , aggregateJustTable, aggregateJustTable1
   , aggregateMaybeTable
   , nameMaybeTable
 
@@ -76,6 +77,8 @@ module Rel8
   , keepLeftTable
   , keepRightTable
   , bitraverseEitherTable
+  , aggregateLeftTable, aggregateLeftTable1
+  , aggregateRightTable, aggregateRightTable1
   , aggregateEitherTable
   , nameEitherTable
 
@@ -93,6 +96,11 @@ module Rel8
   , keepThatTable, loseThatTable
   , keepThoseTable, loseThoseTable
   , bitraverseTheseTable
+  , aggregateThisTable, aggregateThisTable1
+  , aggregateThatTable, aggregateThatTable1
+  , aggregateThoseTable, aggregateThoseTable1
+  , aggregateHereTable, aggregateHereTable1
+  , aggregateThereTable, aggregateThereTable1
   , aggregateTheseTable
   , nameTheseTable
 
@@ -454,6 +462,7 @@ import Rel8.Statement.View
 import Rel8.Table
 import Rel8.Table.ADT
 import Rel8.Table.Aggregate
+import Rel8.Table.Aggregate.Maybe
 import Rel8.Table.Alternative
 import Rel8.Table.Bool
 import Rel8.Table.Either

src/Rel8/Table/Aggregate.hs

@@ -9,9 +9,8 @@ module Rel8.Table.Aggregate
   ( groupBy, groupByOn
   , listAgg, listAggOn, nonEmptyAgg, nonEmptyAggOn
   , listCat, listCatOn, nonEmptyCat, nonEmptyCatOn
-  , filterWhere, filterWhereOptional
+  , filterWhere
   , orderAggregateBy
-  , optionalAggregate
   )
 where
 
@@ -25,11 +24,7 @@ import qualified Opaleye.Internal.Aggregate as Opaleye
 import Data.Profunctor (dimap, lmap)
 
 -- rel8
-import Rel8.Aggregate
-  ( Aggregator,  Aggregator' (Aggregator), Aggregator1
-  , toAggregator
-  )
-import Rel8.Aggregate.Fold (Fallback (Fallback))
+import Rel8.Aggregate (Aggregator,  Aggregator' (Aggregator), Aggregator1)
 import Rel8.Expr ( Expr )
 import Rel8.Expr.Aggregate
   ( filterWhereExplicit
@@ -39,7 +34,6 @@ import Rel8.Expr.Aggregate
   , snonEmptyAggExpr
   , snonEmptyCatExpr
   )
-import Rel8.Expr.Opaleye (toColumn, toPrimExpr)
 import Rel8.Order (Order (Order))
 import Rel8.Schema.Dict ( Dict( Dict ) )
 import Rel8.Schema.HTable (HTable, hfield, hspecs, htabulateA)
@@ -49,7 +43,6 @@ import Rel8.Schema.Spec ( Spec( Spec, info ) )
 import Rel8.Table (Table, toColumns, fromColumns)
 import Rel8.Table.Eq ( EqTable, eqTable )
 import Rel8.Table.List ( ListTable )
-import Rel8.Table.Maybe (MaybeTable, makeMaybeTable, justTable, nothingTable)
 import Rel8.Table.NonEmpty ( NonEmptyTable )
 import Rel8.Table.Opaleye (ifPP)
 import Rel8.Type.Eq ( DBEq )
@@ -91,22 +84,13 @@ hgroupBy eqs = htabulateA $ \field -> case hfield eqs field of
 -- predicate supplied to 'filterWhere' could return 'Rel8.false' for every
 -- row, 'filterWhere' needs an 'Aggregator' as opposed to an 'Aggregator1', so
 -- that it can return a default value in such a case. For a variant of
--- 'filterWhere' that can work with 'Aggregator1's, see 'filterWhereOptional'.
+-- 'filterWhere' that can work with 'Aggregator1's, see
+-- 'Rel8.filterWhereOptional'.
 filterWhere :: Table Expr a
   => (i -> Expr Bool) -> Aggregator i a -> Aggregator' fold i a
 filterWhere = filterWhereExplicit ifPP
 
 
--- | A variant of 'filterWhere' that can be used with an 'Aggregator1'
--- (upgrading it to an 'Aggregator' in the process). It returns
--- 'nothingTable' in the case where the predicate matches zero rows.
-filterWhereOptional :: Table Expr a
-  => (i -> Expr Bool) -> Aggregator' fold i a -> Aggregator' fold' i (MaybeTable Expr a)
-filterWhereOptional f (Aggregator _ aggregator) =
-  Aggregator (Fallback nothingTable) $
-    Opaleye.filterWhereInternal makeMaybeTable (toColumn . toPrimExpr . f) aggregator
-
-
 -- | Aggregate rows into a single row containing an array of all aggregated
 -- rows. This can be used to associate multiple rows with a single row, without
 -- changing the over cardinality of the query. This allows you to essentially
@@ -184,11 +168,3 @@ nonEmptyCatOn f = lmap f nonEmptyCat
 orderAggregateBy :: Order i -> Aggregator' fold i a -> Aggregator' fold i a
 orderAggregateBy (Order order) (Aggregator fallback aggregator) =
   Aggregator fallback $ Opaleye.orderAggregate order aggregator
-
-
--- | 'optionalAggregate' upgrades an 'Aggregator1' into an 'Aggregator' by
--- having it return 'nothingTable' when aggregating over an empty collection
--- of rows.
-optionalAggregate :: Table Expr a
-  => Aggregator' fold i a -> Aggregator' fold' i (MaybeTable Expr a)
-optionalAggregate = toAggregator nothingTable . fmap justTable

src/Rel8/Table/Aggregate/Maybe.hs

@@ -0,0 +1,89 @@
+{-# language FlexibleContexts #-}
+
+module Rel8.Table.Aggregate.Maybe
+  ( filterWhereOptional
+  , optionalAggregate
+  , aggregateJustTable
+  , aggregateJustTable1
+  , aggregateMaybeTable
+  )
+where
+
+-- base
+import Prelude
+
+-- opaleye
+import qualified Opaleye.Internal.Aggregate as Opaleye
+
+-- profunctors
+import Data.Profunctor (lmap)
+
+-- rel8
+import Rel8.Aggregate
+  ( Aggregator' (Aggregator)
+  , Aggregator, toAggregator
+  , Aggregator1, toAggregator1
+  )
+import Rel8.Aggregate.Fold (Fallback (Fallback))
+import Rel8.Expr (Expr)
+import Rel8.Expr.Aggregate (groupByExprOn)
+import Rel8.Expr.Opaleye (toColumn, toPrimExpr)
+import Rel8.Table (Table)
+import Rel8.Table.Aggregate (filterWhere)
+import Rel8.Table.Maybe
+  ( MaybeTable (MaybeTable, just, tag), justTable, nothingTable
+  , isJustTable
+  , makeMaybeTable
+  )
+import Rel8.Table.Nullify (aggregateNullify, unsafeUnnullifyTable)
+
+
+-- | A variant of 'filterWhere' that can be used with an 'Aggregator1'
+-- (upgrading it to an 'Aggregator' in the process). It returns
+-- 'nothingTable' in the case where the predicate matches zero rows.
+filterWhereOptional :: Table Expr a
+  => (i -> Expr Bool) -> Aggregator' fold i a -> Aggregator' fold' i (MaybeTable Expr a)
+filterWhereOptional f (Aggregator _ aggregator) =
+  Aggregator (Fallback nothingTable) $
+    Opaleye.filterWhereInternal makeMaybeTable (toColumn . toPrimExpr . f) aggregator
+
+
+-- | 'optionalAggregate' upgrades an 'Aggregator1' into an 'Aggregator' by
+-- having it return 'nothingTable' when aggregating over an empty collection
+-- of rows.
+optionalAggregate :: Table Expr a
+  => Aggregator' fold i a -> Aggregator' fold' i (MaybeTable Expr a)
+optionalAggregate = toAggregator nothingTable . fmap justTable
+
+
+-- | Lift an 'Aggregator' to operate on a 'MaybeTable'. If the input query has
+-- @'justTable' i@s, they are folded into a single @a@ by the given aggregator
+-- — in the case where the input query is all 'nothingTable's, the
+-- 'Aggregator'\'s fallback @a@ is returned.
+aggregateJustTable :: Table Expr a
+  => Aggregator i a
+  -> Aggregator' fold (MaybeTable Expr i) a
+aggregateJustTable =
+  filterWhere isJustTable . lmap (unsafeUnnullifyTable . just)
+
+
+-- | Lift an 'Aggregator1' to operate on a 'MaybeTable'. If the input query
+-- has @'justTable' i@s, they are folded into a single @'justTable' a@ by the
+-- given aggregator — in the case where the input query is all
+-- 'nothingTable's, a single 'nothingTable' row is returned.
+aggregateJustTable1 :: Table Expr a
+  => Aggregator' fold i a
+  -> Aggregator' fold' (MaybeTable Expr i) (MaybeTable Expr a)
+aggregateJustTable1 =
+  filterWhereOptional isJustTable . lmap (unsafeUnnullifyTable . just)
+
+
+-- | Lift an aggregator to operate on a 'MaybeTable'. @nothingTable@s and
+-- @justTable@s are grouped separately.
+aggregateMaybeTable :: ()
+  => Aggregator' fold i a
+  -> Aggregator1 (MaybeTable Expr i) (MaybeTable Expr a)
+aggregateMaybeTable aggregator =
+  MaybeTable
+    <$> groupByExprOn tag
+    <*> lmap just (toAggregator1 (aggregateNullify aggregator))

src/Rel8/Table/Either.hs

@@ -1,3 +1,4 @@
+{-# language ApplicativeDo #-}
 {-# language DataKinds #-}
 {-# language DeriveFunctor #-}
 {-# language DerivingStrategies #-}
@@ -19,6 +20,8 @@ module Rel8.Table.Either
   ( EitherTable(..)
   , eitherTable, leftTable, rightTable
   , isLeftTable, isRightTable
+  , aggregateLeftTable, aggregateLeftTable1
+  , aggregateRightTable, aggregateRightTable1
   , aggregateEitherTable
   , nameEitherTable
   )
@@ -37,7 +40,7 @@ import Control.Comonad ( extract )
 import Data.Profunctor (lmap)
 
 -- rel8
-import Rel8.Aggregate (Aggregator', Aggregator1, toAggregator1)
+import Rel8.Aggregate (Aggregator, Aggregator', Aggregator1, toAggregator1)
 import Rel8.Expr ( Expr )
 import Rel8.Expr.Aggregate (groupByExprOn)
 import Rel8.Expr.Serialize ( litExpr )
@@ -54,9 +57,14 @@ import Rel8.Table
   , FromExprs, fromResult, toResult
   , Transpose
   )
+import Rel8.Table.Aggregate (filterWhere)
+import Rel8.Table.Aggregate.Maybe (filterWhereOptional)
 import Rel8.Table.Bool ( bool )
 import Rel8.Table.Eq ( EqTable, eqTable )
-import Rel8.Table.Nullify ( Nullify, aggregateNullify, guard )
+import Rel8.Table.Maybe (MaybeTable)
+import Rel8.Table.Nullify
+  ( Nullify, aggregateNullify, guard, unsafeUnnullifyTable
+  )
 import Rel8.Table.Ord ( OrdTable, ordTable )
 import Rel8.Table.Projection ( Biprojectable, Projectable, biproject, project )
 import Rel8.Table.Serialize ( ToExprs )
@@ -218,6 +226,50 @@ rightTable :: Table Expr a => b -> EitherTable Expr a b
 rightTable = EitherTable (litExpr IsRight) undefined . pure
 
 
+-- | Lift an 'Aggregator' to operate on an 'EitherTable'. If the input query has
+-- @'leftTable' a@s, they are folded into a single @c@ by the given aggregator
+-- — in the case where the input query is all 'rightTable's, the
+-- 'Aggregator'\'s fallback @c@ is returned.
+aggregateLeftTable :: Table Expr c
+  => Aggregator a c
+  -> Aggregator' fold (EitherTable Expr a b) c
+aggregateLeftTable =
+  filterWhere isLeftTable . lmap (unsafeUnnullifyTable . left)
+
+
+-- | Lift an 'Aggregator1' to operate on an 'EitherTable'. If the input query
+-- has @'leftTable' a@s, they are folded into a single @'Rel8.justTable' c@
+-- by the given aggregator — in the case where the input query is all
+-- 'rightTable's, a single 'nothingTable' row is returned.
+aggregateLeftTable1 :: Table Expr c
+  => Aggregator' fold a c
+  -> Aggregator' fold' (EitherTable Expr a b) (MaybeTable Expr c)
+aggregateLeftTable1 =
+  filterWhereOptional isLeftTable . lmap (unsafeUnnullifyTable . left)
+
+
+-- | Lift an 'Aggregator' to operate on an 'EitherTable'. If the input query has
+-- @'rightTable' b@s, they are folded into a single @c@ by the given aggregator
+-- — in the case where the input query is all 'rightTable's, the
+-- 'Aggregator'\'s fallback @c@ is returned.
+aggregateRightTable :: Table Expr c
+  => Aggregator b c
+  -> Aggregator' fold (EitherTable Expr a b) c
+aggregateRightTable =
+  filterWhere isRightTable . lmap (unsafeUnnullifyTable . right)
+
+
+-- | Lift an 'Aggregator1' to operate on an 'EitherTable'. If the input query
+-- has @'rightTable' b@s, they are folded into a single @'Rel8.justTable' c@
+-- by the given aggregator — in the case where the input query is all
+-- 'leftTable's, a single 'nothingTable' row is returned.
+aggregateRightTable1 :: Table Expr c
+  => Aggregator' fold a c
+  -> Aggregator' fold' (EitherTable Expr a b) (MaybeTable Expr c)
+aggregateRightTable1 =
+  filterWhereOptional isLeftTable . lmap (unsafeUnnullifyTable . left)
+
+
 -- | Lift a pair aggregators to operate on an 'EitherTable'. @leftTable@s and
 -- @rightTable@s are grouped separately.
 aggregateEitherTable :: ()

src/Rel8/Table/Maybe.hs

@@ -18,9 +18,9 @@ module Rel8.Table.Maybe
   , isNothingTable, isJustTable
   , fromMaybeTable
   , ($?)
-  , aggregateMaybeTable
   , nameMaybeTable
   , makeMaybeTable
+  , unsafeFromJustTable
   )
 where
 
@@ -38,13 +38,8 @@ import Control.Comonad ( extract )
 import qualified Opaleye.Field as Opaleye
 import qualified Opaleye.SqlTypes as Opaleye
 
--- profunctors
-import Data.Profunctor (lmap)
-
 -- rel8
-import Rel8.Aggregate (Aggregator', Aggregator1, toAggregator1)
 import Rel8.Expr ( Expr )
-import Rel8.Expr.Aggregate (groupByExprOn)
 import Rel8.Expr.Bool ( boolExpr )
 import Rel8.Expr.Null ( isNull, isNonNull, null, nullify )
 import Rel8.Expr.Opaleye (fromColumn, fromPrimExpr)
@@ -70,7 +65,7 @@ import Rel8.Table.Bool ( bool )
 import Rel8.Table.Eq ( EqTable, eqTable )
 import Rel8.Table.Ord ( OrdTable, ordTable )
 import Rel8.Table.Projection ( Projectable, project )
-import Rel8.Table.Nullify ( Nullify, aggregateNullify, guard )
+import Rel8.Table.Nullify (Nullify, guard, unsafeUnnullifyTable)
 import Rel8.Table.Serialize ( ToExprs )
 import Rel8.Table.Undefined ( undefined )
 import Rel8.Type ( DBType )
@@ -222,6 +217,10 @@ fromMaybeTable :: Table Expr a => a -> MaybeTable Expr a -> a
 fromMaybeTable fallback = maybeTable fallback id
 
 
+unsafeFromJustTable :: MaybeTable Expr a -> a
+unsafeFromJustTable (MaybeTable _ just) = unsafeUnnullifyTable just
+
+
 -- | Project a single expression out of a 'MaybeTable'. You can think of this
 -- operator like the '$' operator, but it also has the ability to return
 -- @null@.
@@ -233,17 +232,6 @@ f $? ma@(MaybeTable _ a) = case nullable @b of
 infixl 4 $?
 
 
--- | Lift an aggregator to operate on a 'MaybeTable'. @nothingTable@s and
--- @justTable@s are grouped separately.
-aggregateMaybeTable :: ()
-  => Aggregator' fold i a
-  -> Aggregator1 (MaybeTable Expr i) (MaybeTable Expr a)
-aggregateMaybeTable aggregator =
-  MaybeTable
-    <$> groupByExprOn tag
-    <*> lmap just (toAggregator1 (aggregateNullify aggregator))
-
-
 -- | Construct a 'MaybeTable' in the 'Name' context. This can be useful if you
 -- have a 'MaybeTable' that you are storing in a table and need to construct a
 -- 'TableSchema'.