git.iko.soy/rel8
on b0e47ec help sign in
rel8/src/Rel8/Aggregate.hs
107 lines 3.6 kB history raw
1{-# language DataKinds #-}
2{-# language FlexibleContexts #-}
3{-# language FlexibleInstances #-}
4{-# language MultiParamTypeClasses #-}
5{-# language NamedFieldPuns #-}
6{-# language RankNTypes #-}
7{-# language StandaloneKindSignatures #-}
8{-# language TypeFamilies #-}
9{-# language UndecidableInstances #-}
11module Rel8.Aggregate
12 ( Aggregate(..), foldInputs, mapInputs
13 , Aggregator(..), unsafeMakeAggregate
14 , Aggregates
15 )
16where
18-- base
19import Data.Functor.Const ( Const( Const ), getConst )
20import Data.Functor.Identity ( Identity( Identity ) )
21import Data.Kind ( Constraint, Type )
22import Prelude
24-- opaleye
25import qualified Opaleye.Internal.Aggregate as Opaleye
26import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
27import qualified Opaleye.Internal.PackMap as Opaleye
29-- rel8
30import Rel8.Expr ( Expr )
31import Rel8.Schema.HTable.Identity ( HIdentity(..) )
32import qualified Rel8.Schema.Kind as K
33import Rel8.Schema.Null ( Sql )
34import Rel8.Table
35 ( Table, Columns, Context, fromColumns, toColumns
36 , FromExprs, fromResult, toResult
37 , Transpose
38 )
39import Rel8.Table.Transpose ( Transposes )
40import Rel8.Type ( DBType )
43-- | An @Aggregate a@ describes how to aggregate @Table@s of type @a@. You can
44-- unpack an @Aggregate@ back to @a@ by running it with 'Rel8.aggregate'. As
45-- @Aggregate@ is almost an 'Applicative' functor - but there is no 'pure'
46-- operation. This means 'Aggregate' is an instance of 'Apply', and you can
47-- combine @Aggregate@s using the @<.>@ combinator.
48type Aggregate :: K.Context
49newtype Aggregate a = Aggregate (Opaleye.Aggregator () (Expr a))
52instance Sql DBType a => Table Aggregate (Aggregate a) where
53 type Columns (Aggregate a) = HIdentity a
54 type Context (Aggregate a) = Aggregate
55 type FromExprs (Aggregate a) = a
56 type Transpose to (Aggregate a) = to a
58 toColumns = HIdentity
59 fromColumns (HIdentity a) = a
60 toResult = HIdentity . Identity
61 fromResult (HIdentity (Identity a)) = a
64-- | @Aggregates a b@ means that the columns in @a@ are all 'Aggregate' 'Expr's
65-- for the columns in @b@.
66type Aggregates :: Type -> Type -> Constraint
67class Transposes Aggregate Expr aggregates exprs => Aggregates aggregates exprs
68instance Transposes Aggregate Expr aggregates exprs => Aggregates aggregates exprs
71foldInputs :: forall (a :: Type) (b :: Type). Monoid b
72 => (Maybe Aggregator -> Opaleye.PrimExpr -> b) -> Aggregate a -> b
73foldInputs f (Aggregate (Opaleye.Aggregator (Opaleye.PackMap agg))) =
74 getConst $ flip agg () $ \(aggregator, a) ->
75 Const $ f (detuplize <$> aggregator) a
76 where
77 detuplize (operation, ordering, distinction) =
78 Aggregator {operation, ordering, distinction}
81mapInputs :: forall (a :: Type). ()
82 => (Opaleye.PrimExpr -> Opaleye.PrimExpr) -> Aggregate a -> Aggregate a
83mapInputs transform (Aggregate (Opaleye.Aggregator (Opaleye.PackMap agg))) =
84 Aggregate $ Opaleye.Aggregator $ Opaleye.PackMap $ agg . \f input ->
85 f (fmap transform input)
88type Aggregator :: Type
89data Aggregator = Aggregator
90 { operation :: Opaleye.AggrOp
91 , ordering :: [Opaleye.OrderExpr]
92 , distinction :: Opaleye.AggrDistinct
93 }
96unsafeMakeAggregate :: forall (input :: Type) (output :: Type). ()
97 => (Expr input -> Opaleye.PrimExpr)
98 -> (Opaleye.PrimExpr -> Expr output)
99 -> Maybe Aggregator
100 -> Expr input
101 -> Aggregate output
102unsafeMakeAggregate input output aggregator expr =
103 Aggregate $ Opaleye.Aggregator $ Opaleye.PackMap $ \f _ ->
104 output <$> f (tuplize <$> aggregator, input expr)
105 where
106 tuplize Aggregator {operation, ordering, distinction} =
107 (operation, ordering, distinction)