Fix aggregateMaybeTable and friends (#127)

None of these functions actually worked (they would generate invalid SQL that referenced the inner tag column where it was no longer in scope). The root of the problem was in the Nullifiable instance for the Aggregate context. The new version works, at the cost of grouping by the tag `n + 1` times instead of just once (where `n` is the number of columns in the `MaybeTable`).

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