Fix aggregateMaybeTable and friends

src/Rel8/Aggregate.hs

@@ -9,14 +9,14 @@
 {-# language UndecidableInstances #-}
 
 module Rel8.Aggregate
-  ( Aggregate(..), foldInputs, mapInputs
+  ( Aggregate(..), zipOutputs
   , Aggregator(..), unsafeMakeAggregate
   , Aggregates
   )
 where
 
 -- base
-import Data.Functor.Const ( Const( Const ), getConst )
+import Control.Applicative ( liftA2 )
 import Data.Functor.Identity ( Identity( Identity ) )
 import Data.Kind ( Constraint, Type )
 import Prelude
@@ -40,11 +40,7 @@ import Rel8.Table.Transpose ( Transposes )
 import Rel8.Type ( DBType )
 
 
--- | An @Aggregate a@ describes how to aggregate @Table@s of type @a@. You can
--- unpack an @Aggregate@ back to @a@ by running it with 'Rel8.aggregate'. As
--- @Aggregate@ is almost an 'Applicative' functor - but there is no 'pure'
--- operation. This means 'Aggregate' is an instance of 'Apply', and you can
--- combine @Aggregate@s using the @<.>@ combinator.
+-- | 'Aggregate' is a special context used by 'Rel8.aggregate'.
 type Aggregate :: K.Context
 newtype Aggregate a = Aggregate (Opaleye.Aggregator () (Expr a))
 
@@ -61,28 +57,16 @@ instance Sql DBType a => Table Aggregate (Aggregate a) where
   fromResult (HIdentity (Identity a)) = a
 
 
--- | @Aggregates a b@ means that the columns in @a@ are all 'Aggregate' 'Expr's
--- for the columns in @b@.
+-- | @Aggregates a b@ means that the columns in @a@ are all 'Aggregate's
+-- for the 'Expr' columns in @b@.
 type Aggregates :: Type -> Type -> Constraint
 class Transposes Aggregate Expr aggregates exprs => Aggregates aggregates exprs
 instance Transposes Aggregate Expr aggregates exprs => Aggregates aggregates exprs
 
 
-foldInputs :: forall (a :: Type) (b :: Type). Monoid b
-  => (Maybe Aggregator -> Opaleye.PrimExpr -> b) -> Aggregate a -> b
-foldInputs f (Aggregate (Opaleye.Aggregator (Opaleye.PackMap agg))) =
-  getConst $ flip agg () $ \(aggregator, a) ->
-    Const $ f (detuplize <$> aggregator) a
-  where
-    detuplize (operation, ordering, distinction) =
-      Aggregator {operation, ordering, distinction}
-
-
-mapInputs :: forall (a :: Type). ()
-  => (Opaleye.PrimExpr -> Opaleye.PrimExpr) -> Aggregate a -> Aggregate a
-mapInputs transform (Aggregate (Opaleye.Aggregator (Opaleye.PackMap agg))) =
-  Aggregate $ Opaleye.Aggregator $ Opaleye.PackMap $ agg . \f input ->
-    f (fmap transform input)
+zipOutputs :: ()
+  => (Expr a -> Expr b -> Expr c) -> Aggregate a -> Aggregate b -> Aggregate c
+zipOutputs f (Aggregate a) (Aggregate b) = Aggregate (liftA2 f a b)
 
 
 type Aggregator :: Type

src/Rel8/Schema/Context/Nullify.hs

@@ -18,18 +18,17 @@ where
 import Data.Bool ( bool )
 import Data.Functor.Identity ( Identity( Identity ) )
 import Data.Kind ( Constraint, Type )
-import Data.Monoid ( getFirst )
 import Prelude hiding ( null )
 
 -- opaleye
 import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
 
 -- rel8
-import Rel8.Aggregate ( Aggregate( Aggregate ), foldInputs, mapInputs )
+import Rel8.Aggregate ( Aggregate(..), zipOutputs )
 import Rel8.Expr ( Expr )
 import Rel8.Expr.Bool ( boolExpr )
 import Rel8.Expr.Null ( nullify, unsafeUnnullify )
-import Rel8.Expr.Opaleye ( fromPrimExpr, toPrimExpr )
+import Rel8.Expr.Opaleye ( fromPrimExpr )
 import Rel8.Kind.Context ( SContext(..) )
 import Rel8.Schema.Field ( Field )
 import qualified Rel8.Schema.Kind as K
@@ -95,17 +94,10 @@ guarder :: ()
   -> context (Maybe a)
   -> context (Maybe a)
 guarder = \case
-  SAggregate -> \tag _ isNonNull (Aggregate a) ->
-    let
-      mtag = foldInputs (\_ -> pure . fromPrimExpr) tag
-      run = maybe id (sguard . isNonNull) (getFirst mtag)
-    in
-      mapInputs (toPrimExpr . run . fromPrimExpr) $
-      Aggregate $
-      run <$> a
-  SExpr -> \tag _ isNonNull a -> sguard (isNonNull tag) a
-  SField -> \_ _ _ field -> field
-  SName -> \_ _ _ name -> name
+  SAggregate -> \tag _ isNonNull -> zipOutputs (sguard . isNonNull) tag
+  SExpr -> \tag _ isNonNull -> sguard (isNonNull tag)
+  SField -> \_ _ _ -> id
+  SName -> \_ _ _ -> id
   SResult -> \(Identity tag) isNonNull _ (Identity a) ->
     Identity (bool Nothing a (isNonNull tag))
 

tests/Main.hs

@@ -1,3 +1,4 @@
+{-# language BangPatterns #-}
 {-# language BlockArguments #-}
 {-# language DeriveAnyClass #-}
 {-# language DeriveGeneric #-}
@@ -113,6 +114,7 @@ tests =
     , testCatMaybeTable getTestDatabase
     , testCatMaybe getTestDatabase
     , testMaybeTable getTestDatabase
+    , testAggregateMaybeTable getTestDatabase
     , testNestedTables getTestDatabase
     , testMaybeTableApplicative getTestDatabase
     , testLogicalFixities getTestDatabase
@@ -555,6 +557,28 @@ testMaybeTable = databasePropertyTest "maybeTable" \transaction -> evalM do
       _ -> sort selected === sort rows
 
 
+testAggregateMaybeTable :: IO TmpPostgres.DB -> TestTree
+testAggregateMaybeTable = databasePropertyTest "aggregateMaybeTable" \transaction -> evalM do
+  rows <- forAll $ Gen.list (Range.linear 0 10) (Gen.maybe (Gen.int64 (Range.linear 0 10)))
+
+  let
+    aggregate = go 0 False False
+      where
+        go !n nothing _ (Just a : as) = go (n + a) nothing True as
+        go n _ just (Nothing : as) = go n True just as
+        go _ False False [] = []
+        go _ True False [] = [Nothing]
+        go n False True [] = [Just n]
+        go n True True [] = [Nothing, Just n]
+
+  transaction do
+    selected <- lift do
+      statement () $ Rel8.select do
+        Rel8.aggregate $ Rel8.aggregateMaybeTable Rel8.sum <$> Rel8.values (Rel8.lit <$> rows)
+
+    sort selected === aggregate rows
+
+
 data TwoTestTables f =
   TwoTestTables
     { testTable1 :: TestTable f