git.iko.soy/rel8
on 11bcbbb help sign in
rel8/src/Rel8/Aggregate.hs
188 lines 6.2 kB history raw
1{-# language DataKinds #-}
2{-# language DerivingVia #-}
3{-# language FlexibleContexts #-}
4{-# language FlexibleInstances #-}
5{-# language GADTs #-}
6{-# language GeneralizedNewtypeDeriving #-}
7{-# language MultiParamTypeClasses #-}
8{-# language NamedFieldPuns #-}
9{-# language StandaloneKindSignatures #-}
10{-# language TypeFamilies #-}
11{-# language UndecidableInstances #-}
12{-# language UndecidableSuperClasses #-}
14module Rel8.Aggregate
15 ( Aggregate(..)
16 , Aggregator(..), unsafeMakeAggregate
17 , Aggregates
18 , Col( Aggregation )
19 )
20where
22-- base
23import Control.Applicative ( empty )
24import Data.Foldable ( fold )
25import Data.Functor.Const ( Const( Const ), getConst )
26import Data.Functor.Identity ( Identity )
27import Data.Kind ( Constraint, Type )
28import Data.Monoid ( First( First ), getFirst )
29import Prelude
31-- opaleye
32import qualified Opaleye.Internal.Aggregate as Opaleye
33import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
34import qualified Opaleye.Internal.PackMap as Opaleye
36-- rel8
37import Rel8.Expr ( Expr, Col(..) )
38import Rel8.Expr.Opaleye ( fromPrimExpr, toPrimExpr )
39import Rel8.Opaque ( Opaque )
40import Rel8.Schema.Context ( Interpretation(..) )
41import Rel8.Schema.Context.Label ( Labelable(..) )
42import Rel8.Schema.Context.Nullify
43 ( Nullifiable, encodeTag, decodeTag, nullifier, unnullifier
44 , runTag, unnull
45 )
46import Rel8.Schema.HTable ( hfield, htabulate, htabulateA, hspecs )
47import Rel8.Schema.Name ( Name )
48import Rel8.Schema.Nullability ( Sql )
49import Rel8.Schema.Spec ( Spec( Spec ), SSpec(..) )
50import Rel8.Table ( Table, Columns, Context, fromColumns, toColumns )
51import Rel8.Table.Recontextualize ( Recontextualize )
52import Rel8.Type ( DBType )
54-- semigroupoids
55import Data.Functor.Apply ( Apply, WrappedApplicative(..) )
58-- | An @Aggregate a@ describes how to aggregate @Table@s of type @a@. You can
59-- unpack an @Aggregate@ back to @a@ by running it with 'aggregate'. As
60-- @Aggregate@ is almost an 'Applicative' functor - but there is no 'pure'
61-- operation. This means 'Aggregate' is an instance of 'Apply', and you can
62-- combine @Aggregate@s using the @<.>@ combinator.
63type Aggregate :: Type -> Type
64newtype Aggregate a = Aggregate (Opaleye.Aggregator () a)
65 deriving newtype Functor
66 deriving Apply via (WrappedApplicative (Opaleye.Aggregator ()))
69instance Interpretation Aggregate where
70 data Col Aggregate _spec where
71 Aggregation :: ()
72 => Aggregate (Expr a)
73 -> Col Aggregate ('Spec labels necessity a)
76instance Table Expr a => Table Aggregate (Aggregate a) where
77 type Columns (Aggregate a) = Columns a
78 type Context (Aggregate a) = Aggregate
80 toColumns a = htabulate $ \field -> case hfield hspecs field of
81 SSpec {} -> Aggregation $ unDB . (`hfield` field) . toColumns <$> a
82 fromColumns as = fmap fromColumns $ htabulateA $ \field ->
83 case hfield as field of
84 Aggregation a -> DB <$> a
87instance Sql DBType a =>
88 Recontextualize Aggregate Aggregate (Aggregate (Expr a)) (Aggregate (Expr a))
91instance Sql DBType a =>
92 Recontextualize Aggregate Expr (Aggregate (Expr a)) (Expr a)
95instance Sql DBType a =>
96 Recontextualize Aggregate Identity (Aggregate (Expr a)) (Identity a)
99instance Sql DBType a =>
100 Recontextualize Aggregate Name (Aggregate (Expr a)) (Name a)
103instance Sql DBType a =>
104 Recontextualize Expr Aggregate (Expr a) (Aggregate (Expr a))
107instance Sql DBType a =>
108 Recontextualize Identity Aggregate (Identity a) (Aggregate (Expr a))
111instance Sql DBType a =>
112 Recontextualize Name Aggregate (Name a) (Aggregate (Expr a))
115instance Labelable Aggregate where
116 labeler (Aggregation aggregate) = Aggregation aggregate
117 unlabeler (Aggregation aggregate) = Aggregation aggregate
120instance Nullifiable Aggregate where
121 encodeTag = Aggregation . groupByExpr
122 where
123 groupByExpr = unsafeMakeAggregate toPrimExpr fromPrimExpr Nothing
124 decodeTag (Aggregation aggregate) = fold $ undoGroupBy aggregate
125 where
126 undoGroupBy = getFirst . foldInputs go
127 where
128 go Nothing = pure . fromPrimExpr
129 go _ = const $ First empty
131 nullifier tag SSpec {nullability} (Aggregation aggregate) = Aggregation $
132 mapInputs (toPrimExpr . runTag nullability tag . fromPrimExpr) $
133 runTag nullability tag <$> aggregate
135 unnullifier _ SSpec {nullability} (Aggregation aggregate) =
136 Aggregation $ unnull nullability <$> aggregate
138 {-# INLINABLE encodeTag #-}
139 {-# INLINABLE decodeTag #-}
140 {-# INLINABLE nullifier #-}
141 {-# INLINABLE unnullifier #-}
144-- | @Aggregates a b@ means that the columns in @a@ are all 'Aggregate' 'Expr's
145-- for the columns in @b@.
146type Aggregates :: Type -> Type -> Constraint
147class Recontextualize Aggregate Expr aggregates exprs => Aggregates aggregates exprs
148instance Recontextualize Aggregate Expr aggregates exprs => Aggregates aggregates exprs
149instance {-# OVERLAPPING #-} Aggregates (Opaque Aggregate Opaque) (Opaque Expr Opaque)
152foldInputs :: Monoid b
153 => (Maybe Aggregator -> Opaleye.PrimExpr -> b) -> Aggregate a -> b
154foldInputs f (Aggregate (Opaleye.Aggregator (Opaleye.PackMap agg))) =
155 getConst $ flip agg () $ \(aggregator, a) ->
156 Const $ f (detuplize <$> aggregator) a
157 where
158 detuplize (operation, ordering, distinction) =
159 Aggregator {operation, ordering, distinction}
162mapInputs :: ()
163 => (Opaleye.PrimExpr -> Opaleye.PrimExpr) -> Aggregate a -> Aggregate a
164mapInputs transform (Aggregate (Opaleye.Aggregator (Opaleye.PackMap agg))) =
165 Aggregate $ Opaleye.Aggregator $ Opaleye.PackMap $ agg . \f input ->
166 f (fmap transform input)
169type Aggregator :: Type
170data Aggregator = Aggregator
171 { operation :: Opaleye.AggrOp
172 , ordering :: [Opaleye.OrderExpr]
173 , distinction :: Opaleye.AggrDistinct
174 }
177unsafeMakeAggregate :: ()
178 => (input -> Opaleye.PrimExpr)
179 -> (Opaleye.PrimExpr -> output)
180 -> Maybe Aggregator
181 -> input
182 -> Aggregate output
183unsafeMakeAggregate input output aggregator expr =
184 Aggregate $ Opaleye.Aggregator $ Opaleye.PackMap $ \f _ ->
185 output <$> f (tuplize <$> aggregator, input expr)
186 where
187 tuplize Aggregator {operation, ordering, distinction} =
188 (operation, ordering, distinction)