git.iko.soy/rel8
on 137ebed help sign in
rel8/src/Rel8/Table/Tag.hs
97 lines 2.5 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.Name ( Name( Name ) )
33import Rel8.Schema.Null ( Sql )
34import Rel8.Type.Monoid ( DBMonoid )
37type Tag :: Symbol -> Type -> Type
38data Tag label a = Tag
39 { expr :: Expr a
40 , aggregator :: Maybe Aggregator
41 , name :: Name a
42 }
45type Taggable :: Type -> Constraint
46class Taggable a where
47 tappend :: KnownSymbol label => Tag label a -> Tag label a -> Tag label a
48 tempty :: KnownSymbol label => Tag label a
51instance Sql DBMonoid a => Taggable a where
52 tappend :: forall label. KnownSymbol label
53 => Tag label a -> Tag label a -> Tag label a
54 tappend a b = Tag
55 { expr = expr a <> expr b
56 , aggregator = aggregator a <|> aggregator b
57 , name = case (name a, symbolVal (Proxy @label)) of
58 (Name x, y)
59 | x == y -> name b
60 | otherwise -> name a
61 }
62 {-# INLINABLE tappend #-}
64 tempty :: forall label. KnownSymbol label => Tag label a
65 tempty = Tag
66 { expr = mempty
67 , aggregator = empty
68 , name = Name (symbolVal (Proxy @label))
69 }
70 {-# INLINABLE tempty #-}
73instance (KnownSymbol label, Taggable a) => Semigroup (Tag label a) where
74 (<>) = tappend
77instance (KnownSymbol label, Taggable a) => Monoid (Tag label a) where
78 mempty = tempty
81fromAggregate :: forall a label. (KnownSymbol label, Taggable a)
82 => Aggregate a -> Tag label a
83fromAggregate = fold . getFirst . foldInputs go
84 where
85 go aggregator primExpr = pure $ (tempty @a @label)
86 { expr = fromPrimExpr primExpr
87 , aggregator
88 }
91fromExpr :: forall label a. (KnownSymbol label, Taggable a)
92 => Expr a -> Tag label a
93fromExpr expr = (tempty @a @label) {expr}
96fromName :: forall a label. Taggable a => Name a -> Tag label a
97fromName name = (tempty @a @"") {name}