git.iko.soy/rel8
on 2ba99ea help sign in
rel8/src/Rel8/Schema/Context/Nullify.hs
188 lines 5.4 kB history raw
1{-# language DataKinds #-}
2{-# language FlexibleContexts #-}
3{-# language FlexibleInstances #-}
4{-# language InstanceSigs #-}
5{-# language MultiParamTypeClasses #-}
6{-# language NamedFieldPuns #-}
7{-# language ScopedTypeVariables #-}
8{-# language StandaloneKindSignatures #-}
9{-# language TypeFamilies #-}
11module Rel8.Schema.Context.Nullify
12 ( Nullifiable( ConstrainTag, encodeTag, decodeTag, nullifier, unnullifier )
13 , HNullifiable( HConstrainTag, hencodeTag, hdecodeTag, hnullifier, hunnullifier )
14 , runTag, unnull
15 )
16where
18-- base
19import Data.Kind ( Constraint, Type )
20import GHC.TypeLits ( KnownSymbol )
21import Prelude hiding ( null )
23-- opaleye
24import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
26-- rel8
27import Rel8.Aggregate
28 ( Aggregate( Aggregate ), Col( A )
29 , mapInputs
30 , unsafeMakeAggregate
31 )
32import Rel8.Expr ( Expr, Col( E ) )
33import Rel8.Expr.Bool ( boolExpr )
34import Rel8.Expr.Null ( nullify, unsafeUnnullify )
35import Rel8.Expr.Opaleye ( fromPrimExpr, toPrimExpr )
36import Rel8.Schema.Context ( Interpretation )
37import qualified Rel8.Schema.Kind as K
38import Rel8.Schema.Name ( Name( Name ), Col( N ) )
39import Rel8.Schema.Null ( Nullify, Nullity( Null, NotNull ), Sql )
40import Rel8.Schema.Dict ( Dict( Dict ) )
41import Rel8.Schema.Spec ( Spec( Spec ), SSpec(..) )
42import Rel8.Schema.Spec.ConstrainDBType ( ConstrainDBType )
43import qualified Rel8.Schema.Spec.ConstrainDBType as ConstrainDBType
44import Rel8.Table.Tag ( Tag(..), Taggable, fromAggregate, fromExpr, fromName )
47type Nullifiable :: K.Context -> Constraint
48class Interpretation context => Nullifiable context where
49 type ConstrainTag context :: Type -> Constraint
50 type ConstrainTag _context = DefaultConstrainTag
52 encodeTag ::
53 ( Sql (ConstrainTag context) a
54 , KnownSymbol label
55 , Taggable a
56 )
57 => Tag label a
58 -> Col context ('Spec labels a)
60 decodeTag ::
61 ( Sql (ConstrainTag context) a
62 , KnownSymbol label
63 , Taggable a
64 )
65 => Col context ('Spec labels a)
66 -> Tag label a
68 nullifier :: ()
69 => Tag label a
70 -> (Expr a -> Expr Bool)
71 -> SSpec ('Spec labels x)
72 -> Col context ('Spec labels x)
73 -> Col context ('Spec labels (Nullify x))
75 unnullifier :: ()
76 => SSpec ('Spec labels x)
77 -> Col context ('Spec labels (Nullify x))
78 -> Col context ('Spec labels x)
81instance Nullifiable Aggregate where
82 encodeTag Tag {aggregator, expr} =
83 A $ unsafeMakeAggregate toPrimExpr fromPrimExpr aggregator expr
85 decodeTag (A aggregate) = fromAggregate aggregate
87 nullifier Tag {expr} test SSpec {nullity} (A (Aggregate a)) =
88 A $
89 mapInputs (toPrimExpr . runTag nullity condition . fromPrimExpr) $
90 Aggregate $
91 runTag nullity condition <$> a
92 where
93 condition = test expr
95 unnullifier SSpec {nullity} (A (Aggregate a)) =
96 A (Aggregate (unnull nullity <$> a))
98 {-# INLINABLE encodeTag #-}
99 {-# INLINABLE decodeTag #-}
100 {-# INLINABLE nullifier #-}
101 {-# INLINABLE unnullifier #-}
104instance Nullifiable Expr where
105 encodeTag Tag {expr} = E expr
106 decodeTag (E a) = fromExpr a
107 nullifier Tag {expr} test SSpec {nullity} (E a) =
108 E $ runTag nullity (test expr) a
109 unnullifier SSpec {nullity} (E a) = E $ unnull nullity a
111 {-# INLINABLE encodeTag #-}
112 {-# INLINABLE decodeTag #-}
113 {-# INLINABLE nullifier #-}
114 {-# INLINABLE unnullifier #-}
117instance Nullifiable Name where
118 encodeTag Tag {name} = N name
119 decodeTag (N name) = fromName name
120 nullifier _ _ _ (N (Name name)) = N (Name name)
121 unnullifier _ (N (Name name)) = N (Name name)
123 {-# INLINABLE encodeTag #-}
124 {-# INLINABLE decodeTag #-}
125 {-# INLINABLE nullifier #-}
126 {-# INLINABLE unnullifier #-}
129runTag :: Nullity a -> Expr Bool -> Expr a -> Expr (Nullify a)
130runTag nullity tag a = case nullity of
131 Null -> boolExpr null a tag
132 NotNull -> boolExpr null (nullify a) tag
133 where
134 null = fromPrimExpr $ Opaleye.ConstExpr Opaleye.NullLit
137unnull :: Nullity a -> Expr (Nullify a) -> Expr a
138unnull nullity a = case nullity of
139 Null -> a
140 NotNull -> unsafeUnnullify a
143type HNullifiable :: K.HContext -> Constraint
144class HNullifiable context where
145 type HConstrainTag context :: Type -> Constraint
146 type HConstrainTag _context = DefaultConstrainTag
148 hencodeTag :: (Sql (HConstrainTag context) a, KnownSymbol label, Taggable a)
149 => Tag label a
150 -> context ('Spec labels a)
152 hdecodeTag :: (Sql (HConstrainTag context) a, KnownSymbol label, Taggable a)
153 => context ('Spec labels a)
154 -> Tag label a
156 hnullifier :: ()
157 => Tag label a
158 -> (Expr a -> Expr Bool)
159 -> SSpec ('Spec labels x)
160 -> context ('Spec labels x)
161 -> context ('Spec labels (Nullify x))
163 hunnullifier :: ()
164 => SSpec ('Spec labels x)
165 -> context ('Spec labels (Nullify x))
166 -> context ('Spec labels x)
169instance Nullifiable context => HNullifiable (Col context) where
170 type HConstrainTag (Col context) = ConstrainTag context
171 hencodeTag = encodeTag
172 hdecodeTag = decodeTag
173 hnullifier = nullifier
174 hunnullifier = unnullifier
177instance HNullifiable (Dict (ConstrainDBType constraint)) where
178 type HConstrainTag (Dict (ConstrainDBType constraint)) = constraint
180 hencodeTag _ = Dict
181 hdecodeTag = mempty
182 hnullifier _ _ = ConstrainDBType.nullifier
183 hunnullifier = ConstrainDBType.unnullifier
186type DefaultConstrainTag :: Type -> Constraint
187class DefaultConstrainTag a
188instance DefaultConstrainTag a