diff --git a/src/Opaleye/Internal/Aggregate.hs b/src/Opaleye/Internal/Aggregate.hs index 301bf40d..b19eeb6c 100644 --- a/src/Opaleye/Internal/Aggregate.hs +++ b/src/Opaleye/Internal/Aggregate.hs @@ -41,7 +41,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 @@ -50,7 +50,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 @@ -202,6 +202,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 diff --git a/src/Opaleye/Internal/HaskellDB/PrimQuery.hs b/src/Opaleye/Internal/HaskellDB/PrimQuery.hs index 4fd266df..9e31a5c7 100644 --- a/src/Opaleye/Internal/HaskellDB/PrimQuery.hs +++ b/src/Opaleye/Internal/HaskellDB/PrimQuery.hs @@ -99,6 +99,7 @@ data Aggr' a = Aggr , aggrExprs :: ![a] , aggrOrder :: ![OrderExpr' a] , aggrDistinct :: !AggrDistinct + , aggrGroup :: ![OrderExpr' a] , aggrFilter :: !(Maybe PrimExpr) } deriving (Functor, Foldable, Traversable, Show, Read) diff --git a/src/Opaleye/Internal/HaskellDB/Sql.hs b/src/Opaleye/Internal/HaskellDB/Sql.hs index 2b1b485a..b5df11e9 100644 --- a/src/Opaleye/Internal/HaskellDB/Sql.hs +++ b/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 diff --git a/src/Opaleye/Internal/HaskellDB/Sql/Default.hs b/src/Opaleye/Internal/HaskellDB/Sql/Default.hs index 120c0eaf..201052e1 100644 --- a/src/Opaleye/Internal/HaskellDB/Sql/Default.hs +++ b/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' diff --git a/src/Opaleye/Internal/HaskellDB/Sql/Print.hs b/src/Opaleye/Internal/HaskellDB/Sql/Print.hs index 65b3d71f..cc5d3ac2 100644 --- a/src/Opaleye/Internal/HaskellDB/Sql/Print.hs +++ b/src/Opaleye/Internal/HaskellDB/Sql/Print.hs @@ -192,10 +192,13 @@ 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 <> args <+> filter + 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) diff --git a/src/Opaleye/Internal/Window.hs b/src/Opaleye/Internal/Window.hs index 8dde5cee..87127b01 100644 --- a/src/Opaleye/Internal/Window.hs +++ b/src/Opaleye/Internal/Window.hs @@ -131,10 +131,9 @@ aggregatorWindowFunction :: A.Aggregator a b -> (a' -> a) -> WindowFunction a' b aggregatorWindowFunction agg g = WindowFunction $ PM.PackMap $ \f a -> pm (\case HPQ.GroupBy expr -> pure expr - HPQ.Aggregate (HPQ.Aggr op e _ _ _) -> f (HPQ.WndwAggregate op e)) a + HPQ.Aggregate (HPQ.Aggr op e _ _ _ _) -> f (HPQ.WndwAggregate op e)) a where A.Aggregator (PM.PackMap pm) = lmap g agg - -- | 'over' applies a 'WindowFunction' on a particular 'Window'. For -- example, --