Merge branch 'master' into verify

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.

docs/tutorial.rst

@@ -357,7 +357,6 @@ focus on the /type/ of that query::
         author  <- each authorSchema
         project <- projectsForAuthor author
         return (author, project)
-        where
 
   >>> :t select conn authorsAndProjects
   select conn authorsAndProjects

rel8.cabal

@@ -187,6 +187,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,12 +96,17 @@ module Rel8
   , keepThatTable, loseThatTable
   , keepThoseTable, loseThoseTable
   , bitraverseTheseTable
+  , aggregateThisTable, aggregateThisTable1
+  , aggregateThatTable, aggregateThatTable1
+  , aggregateThoseTable, aggregateThoseTable1
+  , aggregateHereTable, aggregateHereTable1
+  , aggregateThereTable, aggregateThereTable1
   , aggregateTheseTable
   , nameTheseTable
 
     -- ** @ListTable@
   , ListTable
-  , listTable, ($*)
+  , listOf, listTable, ($*)
   , nameListTable
   , many
   , manyExpr
@@ -107,7 +115,7 @@ module Rel8
 
     -- ** @NonEmptyTable@
   , NonEmptyTable
-  , nonEmptyTable, ($+)
+  , nonEmptyOf, nonEmptyTable, ($+)
   , nameNonEmptyTable
   , some
   , someExpr
@@ -396,6 +404,7 @@ import Rel8.Column.Null
 import Rel8.Column.These
 import Rel8.Expr
 import Rel8.Expr.Aggregate
+import Rel8.Expr.Array
 import Rel8.Expr.Bool
 import Rel8.Expr.Default
 import Rel8.Expr.Eq
@@ -453,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/Query/Materialize.hs

@@ -15,7 +15,6 @@ import Opaleye.With ( withMaterializedExplicit )
 import Rel8.Expr ( Expr )
 import Rel8.Query ( Query )
 import Rel8.Query.Opaleye ( fromOpaleye, toOpaleye )
-import Rel8.Query.Rebind ( rebind )
 import Rel8.Table ( Table )
 import Rel8.Table.Opaleye ( unpackspec )
 
@@ -31,10 +30,9 @@ import Rel8.Table.Opaleye ( unpackspec )
 -- specifically the @WITH _ AS MATERIALIZED (_)@ form introduced in PostgreSQL
 -- 12. This means that 'materialize' can only be used with PostgreSQL 12 or
 -- newer.
-materialize :: (Table Expr a, Table Expr b)
-  => Query a -> (Query a -> Query b) -> Query b
+materialize :: Table Expr a => Query a -> (Query a -> Query b) -> Query b
 materialize query f =
-  (>>= rebind "with") . fromOpaleye $
+  fromOpaleye $
     withMaterializedExplicit unpackspec
       (toOpaleye query')
       (toOpaleye . f . fromOpaleye)

src/Rel8/Statement.hs

@@ -132,7 +132,7 @@ data Returning where
 --     delete Delete
 --       { from = fooSchema
 --       , using = pure ()
---       , deleteWhere = \_ -> predicate
+--       , deleteWhere = \\_ -> predicate
 --       , returning = Returning id
 --       }
 --   insert Insert

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 :: ()