Add support for ordered-set aggregation functions (WITHIN GROUP)

This commit adds support for ordered-set aggregation functions such as `mode()` which use the `WITHIN GROUP (ORDER BY _)` syntax. However, it doesn't actually expose any public facing API for this, basically because I don't know yet what that API should be for Opaleye. There are a lot of subtle restrictions on the kinds of arguments you can pass to the ordered-set aggregation functions (e.g., `percentile_disc()` can take either a constant expression or one of the columns from the query we're aggregating over, but only if it's part of the `GROUP BY` clause) that would be hard to capture in the types that Opaleye currently uses.

What this commit does is add just enough internals for me to able to experiment with a limited API in Rel8 for ordered-set aggregation functions that might be subject to change in the future. But I don't want to add something half-baked to Opaleye's public facing API just yet.

src/Opaleye/Internal/Aggregate.hs

@@ -48,7 +48,7 @@ makeAggr' mAggrOp = P.dimap C.unColumn C.Column $ Aggregator (PM.PackMap
   where
     aggr = case mAggrOp of
       Nothing -> HPQ.GroupBy
-      Just op -> \e -> HPQ.Aggregate (HPQ.Aggr op [e] [] HPQ.AggrAll Nothing)
+      Just op -> \e -> HPQ.Aggregate (HPQ.Aggr op [e] [] HPQ.AggrAll [] Nothing)
 
 makeAggr :: HPQ.AggrOp -> Aggregator (C.Field_ n a) (C.Field_ n' b)
 makeAggr = makeAggr' . Just
@@ -57,7 +57,7 @@ makeAggrExplicit :: U.Unpackspec a a -> HPQ.AggrOp -> Aggregator a (C.Field_ n b
 makeAggrExplicit unpackspec op =
   C.Column <$> Aggregator (PM.PackMap (\f e -> f (aggr e)))
   where
-    aggr a = HPQ.Aggregate (HPQ.Aggr op exprs [] HPQ.AggrAll Nothing)
+    aggr a = HPQ.Aggregate (HPQ.Aggr op exprs [] HPQ.AggrAll [] Nothing)
       where
         exprs = U.collectPEs unpackspec a
 
@@ -228,6 +228,16 @@ filterWhereInternal maybeField predicate aggregator =
           Nothing -> cond'
           Just cond -> HPQ.BinExpr HPQ.OpAnd cond cond'
 
+withinGroup :: O.Order a -> Aggregator a b -> Aggregator a b
+withinGroup o (Aggregator (PM.PackMap pm)) = Aggregator (PM.PackMap
+  (\f c -> pm (f . setOrder (O.orderExprs c o)) c))
+  where
+    setOrder _ (HPQ.GroupBy e) = HPQ.GroupBy e
+    setOrder order (HPQ.Aggregate aggr) =
+      HPQ.Aggregate aggr
+        { HPQ.aggrGroup = order
+        }
+
 -- { Boilerplate instances
 
 instance Functor (Aggregator a) where

src/Opaleye/Internal/HaskellDB/PrimQuery.hs

@@ -101,6 +101,7 @@ data Aggr' a = Aggr
   , aggrExprs :: ![a]
   , aggrOrder :: ![OrderExpr' a]
   , aggrDistinct :: !AggrDistinct
+  , aggrGroup :: ![OrderExpr' a]
   , aggrFilter :: !(Maybe PrimExpr)
   }
   deriving (Functor, Foldable, Traversable, Eq, Ord, Read, Show)

src/Opaleye/Internal/HaskellDB/Sql.hs

@@ -52,7 +52,7 @@ data SqlExpr = ColumnSqlExpr  SqlColumn
              | PrefixSqlExpr  String SqlExpr
              | PostfixSqlExpr String SqlExpr
              | FunSqlExpr     String [SqlExpr]
-             | AggrFunSqlExpr String [SqlExpr] [(SqlExpr, SqlOrder)] SqlDistinct (Maybe SqlExpr) -- ^ Aggregate functions separate from normal functions.
+             | AggrFunSqlExpr String [SqlExpr] [(SqlExpr, SqlOrder)] SqlDistinct [(SqlExpr, SqlOrder)] (Maybe SqlExpr) -- ^ Aggregate functions separate from normal functions.
              | WndwFunSqlExpr String [SqlExpr] SqlPartition
              | ConstSqlExpr   String
              | CaseSqlExpr    (NEL.NonEmpty (SqlExpr,SqlExpr)) SqlExpr

src/Opaleye/Internal/HaskellDB/Sql/Default.hs

@@ -132,15 +132,16 @@ defaultSqlExpr gen expr =
                                 UnOpFun     -> FunSqlExpr op' [e']
                                 UnOpPrefix  -> PrefixSqlExpr op' (ParensSqlExpr e')
                                 UnOpPostfix -> PostfixSqlExpr op' (ParensSqlExpr e')
-      AggrExpr (Aggr op e ord distinct mfilter) ->
+      AggrExpr (Aggr op e ord distinct group mfilter) ->
         let
           (op', e') = showAggrOp gen op e
           ord' = toSqlOrder gen <$> ord
           distinct' = case distinct of
             AggrDistinct -> SqlDistinct
             AggrAll      -> SqlNotDistinct
+          group' = toSqlOrder gen <$> group
           mfilter' = sqlExpr gen <$> mfilter
-         in AggrFunSqlExpr op' e' ord' distinct' mfilter'
+         in AggrFunSqlExpr op' e' ord' distinct' group' mfilter'
       WndwExpr op window  -> let (op', e') = showWndwOp gen op
                                  window' = toSqlPartition gen window
                               in WndwFunSqlExpr op' e' window'

src/Opaleye/Internal/HaskellDB/Sql/Print.hs

@@ -192,9 +192,16 @@ ppSqlExpr expr =
       DefaultSqlExpr         -> text "DEFAULT"
       ArraySqlExpr es        -> text "ARRAY" <> brackets (commaH ppSqlExpr es)
       RangeSqlExpr t s e     -> ppRange t s e
-      AggrFunSqlExpr f es ord distinct mfilter -> text f <> parens (ppSqlDistinct distinct <+> commaH ppSqlExpr es <+> ppOrderBy ord) <+> case mfilter of
-        Nothing -> mempty
-        Just e -> text "FILTER" <+> parens (text "WHERE" <+> ppSqlExpr e)
+      AggrFunSqlExpr f es ord distinct group mfilter ->
+        text f <> args <+> within <+> filter
+        where
+          args = parens (ppSqlDistinct distinct <+> commaH ppSqlExpr es <+> ppOrderBy ord)
+          within = case group of
+            [] -> empty
+            _ -> text "WITHIN GROUP" <+> parens (ppOrderBy group)
+          filter = case mfilter of
+            Nothing -> mempty
+            Just e -> text "FILTER" <+> parens (text "WHERE" <+> ppSqlExpr e)
       WndwFunSqlExpr f es window -> ppWindowExpr f es window
       CaseSqlExpr cs el   -> text "CASE" <+> vcat (toList (fmap ppWhen cs))
                              <+> text "ELSE" <+> ppSqlExpr el <+> text "END"

src/Opaleye/Internal/Window.hs

@@ -129,10 +129,9 @@ aggregatorWindowFunction :: A.Aggregator a b -> (a' -> a) -> WindowFunction a' b
 aggregatorWindowFunction agg g = WindowFunction $ PM.PackMap $ \f a ->
   pm (\aggregate -> case aggregate of
          HPQ.GroupBy expr -> pure expr
-         HPQ.Aggregate (HPQ.Aggr op exprs _ _ _) -> f (HPQ.WndwAggregate op exprs)) a
+         HPQ.Aggregate (HPQ.Aggr op exprs _ _ _ _) -> f (HPQ.WndwAggregate op exprs)) a
   where A.Aggregator (PM.PackMap pm) = lmap g agg
 
-
 -- | 'over' applies a 'WindowFunction' on a particular 'Window'.  For
 -- example,
 --