git.iko.soy/rel8
on 28aaa76 help sign in
rel8/src/Rel8/Table/Tag.hs
104 lines 2.8 kB history raw
1{-# language DataKinds #-}
2{-# language FlexibleInstances #-}
3{-# language GADTs #-}
4{-# language InstanceSigs #-}
5{-# language NamedFieldPuns #-}
6{-# language ScopedTypeVariables #-}
7{-# language StandaloneKindSignatures #-}
8{-# language TypeApplications #-}
9{-# language UndecidableInstances #-}
11module Rel8.Table.Tag
12 ( Tag(..), Taggable
13 , fromAggregate
14 , fromExpr
15 , fromName
16 )
17where
19-- base
20import Control.Applicative ( (<|>), empty )
21import Data.Kind ( Constraint, Type )
22import Data.Foldable ( fold )
23import Data.Monoid ( getFirst )
24import Data.Proxy ( Proxy( Proxy ) )
25import GHC.TypeLits ( KnownSymbol, Symbol, symbolVal )
26import Prelude
28-- rel8
29import Rel8.Aggregate ( Aggregate, Aggregator, foldInputs )
30import Rel8.Expr ( Expr )
31import Rel8.Expr.Opaleye ( fromPrimExpr )
32import Rel8.Schema.Dict ( Dict( Dict ) )
33import Rel8.Schema.Name ( Name( Name ) )
34import Rel8.Schema.Nullability ( Sql, mapSql )
35import Rel8.Type.Monoid ( DBMonoid )
36import Rel8.Type.Semigroup ( DBSemigroup )
39type Tag :: Symbol -> Type -> Type
40data Tag label a = Tag
41 { expr :: Expr a
42 , aggregator :: Maybe Aggregator
43 , name :: Name a
44 }
47type Taggable :: Type -> Constraint
48class Taggable a where
49 tappend :: KnownSymbol label => Tag label a -> Tag label a -> Tag label a
50 tempty :: KnownSymbol label => Tag label a
53instance Sql DBMonoid a => Taggable a where
54 tappend :: forall label. KnownSymbol label
55 => Tag label a -> Tag label a -> Tag label a
56 tappend a b = Tag
57 { expr = case mapSql dbSemigroupFromDBMonoid (Dict @_ @a) of
58 Dict -> expr a <> expr b
59 , aggregator = aggregator a <|> aggregator b
60 , name = case (name a, symbolVal (Proxy @label)) of
61 (Name x, y)
62 | x == y -> name b
63 | otherwise -> name a
64 }
65 {-# INLINABLE tappend #-}
67 tempty :: forall label. KnownSymbol label => Tag label a
68 tempty = Tag
69 { expr = mempty
70 , aggregator = empty
71 , name = Name (symbolVal (Proxy @label))
72 }
73 {-# INLINABLE tempty #-}
76instance (KnownSymbol label, Taggable a) => Semigroup (Tag label a) where
77 (<>) = tappend
80instance (KnownSymbol label, Taggable a) => Monoid (Tag label a) where
81 mempty = tempty
84fromAggregate :: forall a label. (KnownSymbol label, Taggable a)
85 => Aggregate (Expr a) -> Tag label a
86fromAggregate = fold . getFirst . foldInputs go
87 where
88 go aggregator primExpr = pure $ (tempty @a @label)
89 { expr = fromPrimExpr primExpr
90 , aggregator
91 }
94fromExpr :: forall label a. (KnownSymbol label, Taggable a)
95 => Expr a -> Tag label a
96fromExpr expr = (tempty @a @label) {expr}
99fromName :: forall a label. Taggable a => Name a -> Tag label a
100fromName name = (tempty @a @"") {name}
103dbSemigroupFromDBMonoid :: Dict DBMonoid a -> Dict DBSemigroup a
104dbSemigroupFromDBMonoid Dict = Dict