git.iko.soy/rel8
on fab5b4e help sign in
rel8/src/Rel8/Schema/Context/Nullify.hs
188 lines 5.7 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, Col(..)
29 , mapInputs
30 , unsafeMakeAggregate
31 )
32import Rel8.Expr ( Expr, Col(..) )
33import Rel8.Expr.Bool ( boolExpr )
34import Rel8.Expr.Null ( nullify, unsafeUnnullify )
35import Rel8.Expr.Opaleye ( fromPrimExpr, toPrimExpr )
36import Rel8.Kind.Necessity ( Necessity( Required ) )
37import Rel8.Schema.Context ( Interpretation )
38import qualified Rel8.Schema.Kind as K
39import Rel8.Schema.Name ( Name( Name ), Col(..) )
40import Rel8.Schema.Null ( Nullify, Nullity( Null, NotNull ), Sql )
41import Rel8.Schema.Dict ( Dict( Dict ) )
42import Rel8.Schema.Spec ( Spec( Spec ), SSpec(..) )
43import Rel8.Schema.Spec.ConstrainDBType ( ConstrainDBType )
44import qualified Rel8.Schema.Spec.ConstrainDBType as ConstrainDBType
45import Rel8.Table.Tag ( Tag(..), Taggable, fromAggregate, fromExpr, fromName )
48type Nullifiable :: K.Context -> Constraint
49class Interpretation context => Nullifiable context where
50 type ConstrainTag context :: Type -> Constraint
51 type ConstrainTag _context = DefaultConstrainTag
53 encodeTag ::
54 ( Sql (ConstrainTag context) a
55 , KnownSymbol label
56 , Taggable a
57 )
58 => Tag label a
59 -> Col context ('Spec labels 'Required a)
61 decodeTag ::
62 ( Sql (ConstrainTag context) a
63 , KnownSymbol label
64 , Taggable a
65 )
66 => Col context ('Spec labels 'Required a)
67 -> Tag label a
69 nullifier :: ()
70 => Tag label a
71 -> (Expr a -> Expr Bool)
72 -> SSpec ('Spec labels necessity x)
73 -> Col context ('Spec labels necessity x)
74 -> Col context ('Spec labels necessity (Nullify x))
76 unnullifier :: ()
77 => SSpec ('Spec labels necessity x)
78 -> Col context ('Spec labels necessity (Nullify x))
79 -> Col context ('Spec labels necessity x)
82instance Nullifiable Aggregate where
83 encodeTag Tag {aggregator, expr} =
84 Aggregation $ unsafeMakeAggregate toPrimExpr fromPrimExpr aggregator expr
86 decodeTag (Aggregation aggregate) = fromAggregate aggregate
88 nullifier Tag {expr} test SSpec {nullity} (Aggregation aggregate) =
89 Aggregation $
90 mapInputs (toPrimExpr . runTag nullity condition . fromPrimExpr) $
91 runTag nullity condition <$> aggregate
92 where
93 condition = test expr
95 unnullifier SSpec {nullity} (Aggregation aggregate) =
96 Aggregation $ unnull nullity <$> aggregate
98 {-# INLINABLE encodeTag #-}
99 {-# INLINABLE decodeTag #-}
100 {-# INLINABLE nullifier #-}
101 {-# INLINABLE unnullifier #-}
104instance Nullifiable Expr where
105 encodeTag Tag {expr} = DB expr
106 decodeTag (DB a) = fromExpr a
107 nullifier Tag {expr} test SSpec {nullity} (DB a) =
108 DB $ runTag nullity (test expr) a
109 unnullifier SSpec {nullity} (DB a) = DB $ unnull nullity a
111 {-# INLINABLE encodeTag #-}
112 {-# INLINABLE decodeTag #-}
113 {-# INLINABLE nullifier #-}
114 {-# INLINABLE unnullifier #-}
117instance Nullifiable Name where
118 encodeTag Tag {name = Name name} = NameCol name
119 decodeTag (NameCol name) = fromName (Name name)
120 nullifier _ _ _ (NameCol name) = NameCol name
121 unnullifier _ (NameCol name) = NameCol 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 'Required a)
152 hdecodeTag :: (Sql (HConstrainTag context) a, KnownSymbol label, Taggable a)
153 => context ('Spec labels 'Required a)
154 -> Tag label a
156 hnullifier :: ()
157 => Tag label a
158 -> (Expr a -> Expr Bool)
159 -> SSpec ('Spec labels necessity x)
160 -> context ('Spec labels necessity x)
161 -> context ('Spec labels necessity (Nullify x))
163 hunnullifier :: ()
164 => SSpec ('Spec labels necessity x)
165 -> context ('Spec labels necessity (Nullify x))
166 -> context ('Spec labels necessity 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