git.iko.soy/rel8
on b36091a help sign in
rel8/src/Rel8/Aggregate.hs
169 lines 5.2 kB history raw
1{-# language DataKinds #-}
2{-# language DerivingVia #-}
3{-# language FlexibleContexts #-}
4{-# language FlexibleInstances #-}
5{-# language GADTs #-}
6{-# language MultiParamTypeClasses #-}
7{-# language NamedFieldPuns #-}
8{-# language PolyKinds #-}
9{-# language StandaloneKindSignatures #-}
10{-# language TypeFamilies #-}
11{-# language UndecidableInstances #-}
12{-# language UndecidableSuperClasses #-}
14module Rel8.Aggregate
15 ( Aggregate(..), foldInputs, mapInputs
16 , Aggregator(..), unsafeMakeAggregate
17 , Aggregates
18 , Col( Aggregation )
19 )
20where
22-- base
23import Data.Functor.Const ( Const( Const ), getConst )
24import Data.Functor.Identity ( Identity )
25import Data.Kind ( Constraint, Type )
26import Prelude
28-- opaleye
29import qualified Opaleye.Internal.Aggregate as Opaleye
30import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
31import qualified Opaleye.Internal.PackMap as Opaleye
33-- rel8
34import Rel8.Expr ( Expr, Col(..) )
35import Rel8.Schema.Context ( Interpretation(..) )
36import Rel8.Schema.Context.Label ( Labelable(..) )
37import Rel8.Schema.HTable ( hfield, htabulate, htabulateA, hspecs )
38import Rel8.Schema.Name ( Name )
39import Rel8.Schema.Null ( Sql )
40import Rel8.Schema.Reify ( notReify )
41import Rel8.Schema.Result ( Result )
42import Rel8.Schema.Spec ( Spec( Spec ), SSpec(..) )
43import Rel8.Table
44 ( Table, Columns, Context, fromColumns, toColumns
45 , reify, unreify
46 )
47import Rel8.Table.Recontextualize ( Recontextualize )
48import Rel8.Type ( DBType )
50-- semigroupoids
51import Data.Functor.Apply ( Apply, (<.>) )
54-- | An @Aggregate a@ describes how to aggregate @Table@s of type @a@. You can
55-- unpack an @Aggregate@ back to @a@ by running it with 'Rel8.aggregate'. As
56-- @Aggregate@ is almost an 'Applicative' functor - but there is no 'pure'
57-- operation. This means 'Aggregate' is an instance of 'Apply', and you can
58-- combine @Aggregate@s using the @<.>@ combinator.
59type Aggregate :: k -> Type
60data Aggregate a where
61 Aggregate :: !(Opaleye.Aggregator () a) -> Aggregate a
64instance Functor Aggregate where
65 fmap f (Aggregate a) = Aggregate (fmap f a)
68instance Apply Aggregate where
69 Aggregate f <.> Aggregate a = Aggregate (f <*> a)
72instance Interpretation Aggregate where
73 data Col Aggregate _spec where
74 Aggregation :: ()
75 => Aggregate (Expr a)
76 -> Col Aggregate ('Spec labels necessity a)
79instance Table Expr a => Table Aggregate (Aggregate a) where
80 type Columns (Aggregate a) = Columns a
81 type Context (Aggregate a) = Aggregate
83 toColumns a = htabulate $ \field -> case hfield hspecs field of
84 SSpec {} -> Aggregation $ unDB . (`hfield` field) . toColumns <$> a
85 fromColumns as = fmap fromColumns $ htabulateA $ \field ->
86 case hfield as field of
87 Aggregation a -> DB <$> a
89 reify = notReify
90 unreify = notReify
93instance Sql DBType a =>
94 Recontextualize Aggregate Aggregate (Aggregate (Expr a)) (Aggregate (Expr a))
97instance Sql DBType a =>
98 Recontextualize Aggregate Expr (Aggregate (Expr a)) (Expr a)
101instance Sql DBType a =>
102 Recontextualize Aggregate Result (Aggregate (Expr a)) (Identity a)
105instance Sql DBType a =>
106 Recontextualize Aggregate Name (Aggregate (Expr a)) (Name a)
109instance Sql DBType a =>
110 Recontextualize Expr Aggregate (Expr a) (Aggregate (Expr a))
113instance Sql DBType a =>
114 Recontextualize Result Aggregate (Identity a) (Aggregate (Expr a))
117instance Sql DBType a =>
118 Recontextualize Name Aggregate (Name a) (Aggregate (Expr a))
121instance Labelable Aggregate where
122 labeler (Aggregation aggregate) = Aggregation aggregate
123 unlabeler (Aggregation aggregate) = Aggregation aggregate
126-- | @Aggregates a b@ means that the columns in @a@ are all 'Aggregate' 'Expr's
127-- for the columns in @b@.
128type Aggregates :: Type -> Type -> Constraint
129class Recontextualize Aggregate Expr aggregates exprs => Aggregates aggregates exprs
130instance Recontextualize Aggregate Expr aggregates exprs => Aggregates aggregates exprs
133foldInputs :: Monoid b
134 => (Maybe Aggregator -> Opaleye.PrimExpr -> b) -> Aggregate a -> b
135foldInputs f (Aggregate (Opaleye.Aggregator (Opaleye.PackMap agg))) =
136 getConst $ flip agg () $ \(aggregator, a) ->
137 Const $ f (detuplize <$> aggregator) a
138 where
139 detuplize (operation, ordering, distinction) =
140 Aggregator {operation, ordering, distinction}
143mapInputs :: ()
144 => (Opaleye.PrimExpr -> Opaleye.PrimExpr) -> Aggregate a -> Aggregate a
145mapInputs transform (Aggregate (Opaleye.Aggregator (Opaleye.PackMap agg))) =
146 Aggregate $ Opaleye.Aggregator $ Opaleye.PackMap $ agg . \f input ->
147 f (fmap transform input)
150type Aggregator :: Type
151data Aggregator = Aggregator
152 { operation :: Opaleye.AggrOp
153 , ordering :: [Opaleye.OrderExpr]
154 , distinction :: Opaleye.AggrDistinct
155 }
158unsafeMakeAggregate :: ()
159 => (input -> Opaleye.PrimExpr)
160 -> (Opaleye.PrimExpr -> output)
161 -> Maybe Aggregator
162 -> input
163 -> Aggregate output
164unsafeMakeAggregate input output aggregator expr =
165 Aggregate $ Opaleye.Aggregator $ Opaleye.PackMap $ \f _ ->
166 output <$> f (tuplize <$> aggregator, input expr)
167 where
168 tuplize Aggregator {operation, ordering, distinction} =
169 (operation, ordering, distinction)