git.iko.soy/rel8
on 7c4c6ff help sign in
rel8/src/Rel8/Aggregate.hs
162 lines 5.1 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.Result ( Result )
41import Rel8.Schema.Spec ( Spec( Spec ), SSpec(..) )
42import Rel8.Table ( Table, Columns, Context, fromColumns, toColumns )
43import Rel8.Table.Recontextualize ( Recontextualize )
44import Rel8.Type ( DBType )
46-- semigroupoids
47import Data.Functor.Apply ( Apply, (<.>) )
50-- | An @Aggregate a@ describes how to aggregate @Table@s of type @a@. You can
51-- unpack an @Aggregate@ back to @a@ by running it with 'Rel8.aggregate'. As
52-- @Aggregate@ is almost an 'Applicative' functor - but there is no 'pure'
53-- operation. This means 'Aggregate' is an instance of 'Apply', and you can
54-- combine @Aggregate@s using the @<.>@ combinator.
55type Aggregate :: k -> Type
56data Aggregate a where
57 Aggregate :: !(Opaleye.Aggregator () a) -> Aggregate a
60instance Functor Aggregate where
61 fmap f (Aggregate a) = Aggregate (fmap f a)
64instance Apply Aggregate where
65 Aggregate f <.> Aggregate a = Aggregate (f <*> a)
68instance Interpretation Aggregate where
69 data Col Aggregate _spec where
70 Aggregation :: ()
71 => Aggregate (Expr a)
72 -> Col Aggregate ('Spec labels necessity a)
75instance Table Expr a => Table Aggregate (Aggregate a) where
76 type Columns (Aggregate a) = Columns a
77 type Context (Aggregate a) = Aggregate
79 toColumns a = htabulate $ \field -> case hfield hspecs field of
80 SSpec {} -> Aggregation $ unDB . (`hfield` field) . toColumns <$> a
81 fromColumns as = fmap fromColumns $ htabulateA $ \field ->
82 case hfield as field of
83 Aggregation a -> DB <$> a
86instance Sql DBType a =>
87 Recontextualize Aggregate Aggregate (Aggregate (Expr a)) (Aggregate (Expr a))
90instance Sql DBType a =>
91 Recontextualize Aggregate Expr (Aggregate (Expr a)) (Expr a)
94instance Sql DBType a =>
95 Recontextualize Aggregate Result (Aggregate (Expr a)) (Identity a)
98instance Sql DBType a =>
99 Recontextualize Aggregate Name (Aggregate (Expr a)) (Name a)
102instance Sql DBType a =>
103 Recontextualize Expr Aggregate (Expr a) (Aggregate (Expr a))
106instance Sql DBType a =>
107 Recontextualize Result Aggregate (Identity a) (Aggregate (Expr a))
110instance Sql DBType a =>
111 Recontextualize Name Aggregate (Name a) (Aggregate (Expr a))
114instance Labelable Aggregate where
115 labeler (Aggregation aggregate) = Aggregation aggregate
116 unlabeler (Aggregation aggregate) = Aggregation aggregate
119-- | @Aggregates a b@ means that the columns in @a@ are all 'Aggregate' 'Expr's
120-- for the columns in @b@.
121type Aggregates :: Type -> Type -> Constraint
122class Recontextualize Aggregate Expr aggregates exprs => Aggregates aggregates exprs
123instance Recontextualize Aggregate Expr aggregates exprs => Aggregates aggregates exprs
126foldInputs :: Monoid b
127 => (Maybe Aggregator -> Opaleye.PrimExpr -> b) -> Aggregate a -> b
128foldInputs f (Aggregate (Opaleye.Aggregator (Opaleye.PackMap agg))) =
129 getConst $ flip agg () $ \(aggregator, a) ->
130 Const $ f (detuplize <$> aggregator) a
131 where
132 detuplize (operation, ordering, distinction) =
133 Aggregator {operation, ordering, distinction}
136mapInputs :: ()
137 => (Opaleye.PrimExpr -> Opaleye.PrimExpr) -> Aggregate a -> Aggregate a
138mapInputs transform (Aggregate (Opaleye.Aggregator (Opaleye.PackMap agg))) =
139 Aggregate $ Opaleye.Aggregator $ Opaleye.PackMap $ agg . \f input ->
140 f (fmap transform input)
143type Aggregator :: Type
144data Aggregator = Aggregator
145 { operation :: Opaleye.AggrOp
146 , ordering :: [Opaleye.OrderExpr]
147 , distinction :: Opaleye.AggrDistinct
148 }
151unsafeMakeAggregate :: ()
152 => (input -> Opaleye.PrimExpr)
153 -> (Opaleye.PrimExpr -> output)
154 -> Maybe Aggregator
155 -> input
156 -> Aggregate output
157unsafeMakeAggregate input output aggregator expr =
158 Aggregate $ Opaleye.Aggregator $ Opaleye.PackMap $ \f _ ->
159 output <$> f (tuplize <$> aggregator, input expr)
160 where
161 tuplize Aggregator {operation, ordering, distinction} =
162 (operation, ordering, distinction)