git.iko.soy/rel8
on ca7aaef help sign in
rel8/src/Rel8/Schema/Context/Nullify.hs
205 lines 6.1 kB history raw
1{-# language DataKinds #-}
2{-# language FlexibleContexts #-}
3{-# language FlexibleInstances #-}
4{-# language InstanceSigs #-}
5{-# language LambdaCase #-}
6{-# language MultiParamTypeClasses #-}
7{-# language NamedFieldPuns #-}
8{-# language ScopedTypeVariables #-}
9{-# language StandaloneKindSignatures #-}
10{-# language TypeApplications #-}
11{-# language TypeFamilies #-}
13module Rel8.Schema.Context.Nullify
14 ( Nullifiable( ConstrainTag, encodeTag, decodeTag, nullifier, unnullifier )
15 , HNullifiable( HConstrainTag, hencodeTag, hdecodeTag, hnullifier, hunnullifier )
16 , runTag, unnull
17 )
18where
20-- base
21import Data.Kind ( Constraint, Type )
22import GHC.TypeLits ( KnownSymbol )
23import Prelude hiding ( null )
25-- opaleye
26import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
28-- rel8
29import Rel8.Aggregate
30 ( Aggregate, Col(..)
31 , mapInputs
32 , unsafeMakeAggregate
33 )
34import Rel8.Expr ( Expr, Col(..) )
35import Rel8.Expr.Bool ( boolExpr )
36import Rel8.Expr.Null ( nullify, unsafeUnnullify )
37import Rel8.Expr.Opaleye ( fromPrimExpr, toPrimExpr )
38import Rel8.Kind.Necessity ( Necessity( Required ) )
39import Rel8.Schema.Context ( Interpretation )
40import qualified Rel8.Schema.Kind as K
41import Rel8.Schema.Name ( Name( Name ), Col(..) )
42import Rel8.Schema.Nullability
43 ( Nullify
44 , Nullability( Nullable, NonNullable )
45 , Sql
46 )
47import Rel8.Schema.Dict ( Dict( Dict ) )
48import Rel8.Schema.Spec ( Spec( Spec ), SSpec(..) )
49import Rel8.Schema.Spec.ConstrainDBType
50 ( ConstrainDBType
51 , dbTypeDict, dbTypeNullability, fromNullabilityDict
52 )
53import Rel8.Table.Tag ( Tag(..), Taggable, fromAggregate, fromExpr, fromName )
56type Nullifiable :: K.Context -> Constraint
57class Interpretation context => Nullifiable context where
58 type ConstrainTag context :: Type -> Constraint
59 type ConstrainTag _context = DefaultConstrainTag
61 encodeTag ::
62 ( Sql (ConstrainTag context) a
63 , KnownSymbol label
64 , Taggable a
65 )
66 => Tag label a
67 -> Col context ('Spec labels 'Required a)
69 decodeTag ::
70 ( Sql (ConstrainTag context) a
71 , KnownSymbol label
72 , Taggable a
73 )
74 => Col context ('Spec labels 'Required a)
75 -> Tag label a
77 nullifier :: ()
78 => Tag label a
79 -> (Expr a -> Expr Bool)
80 -> SSpec ('Spec labels necessity x)
81 -> Col context ('Spec labels necessity x)
82 -> Col context ('Spec labels necessity (Nullify x))
84 unnullifier :: ()
85 => SSpec ('Spec labels necessity x)
86 -> Col context ('Spec labels necessity (Nullify x))
87 -> Col context ('Spec labels necessity x)
90instance Nullifiable Aggregate where
91 encodeTag Tag {aggregator, expr} =
92 Aggregation $ unsafeMakeAggregate toPrimExpr fromPrimExpr aggregator expr
94 decodeTag (Aggregation aggregate) = fromAggregate aggregate
96 nullifier Tag {expr} test SSpec {nullability} (Aggregation aggregate) =
97 Aggregation $
98 mapInputs (toPrimExpr . runTag nullability condition . fromPrimExpr) $
99 runTag nullability condition <$> aggregate
100 where
101 condition = test expr
103 unnullifier SSpec {nullability} (Aggregation aggregate) =
104 Aggregation $ unnull nullability <$> aggregate
106 {-# INLINABLE encodeTag #-}
107 {-# INLINABLE decodeTag #-}
108 {-# INLINABLE nullifier #-}
109 {-# INLINABLE unnullifier #-}
112instance Nullifiable Expr where
113 encodeTag Tag {expr} = DB expr
114 decodeTag (DB a) = fromExpr a
115 nullifier Tag {expr} test SSpec {nullability} (DB a) =
116 DB $ runTag nullability (test expr) a
117 unnullifier SSpec {nullability} (DB a) = DB $ unnull nullability a
119 {-# INLINABLE encodeTag #-}
120 {-# INLINABLE decodeTag #-}
121 {-# INLINABLE nullifier #-}
122 {-# INLINABLE unnullifier #-}
125instance Nullifiable Name where
126 encodeTag Tag {name = Name name} = NameCol name
127 decodeTag (NameCol name) = fromName (Name name)
128 nullifier _ _ _ (NameCol name) = NameCol name
129 unnullifier _ (NameCol name) = NameCol name
131 {-# INLINABLE encodeTag #-}
132 {-# INLINABLE decodeTag #-}
133 {-# INLINABLE nullifier #-}
134 {-# INLINABLE unnullifier #-}
137runTag :: Nullability a -> Expr Bool -> Expr a -> Expr (Nullify a)
138runTag nullability tag a = case nullability of
139 Nullable -> boolExpr null a tag
140 NonNullable -> boolExpr null (nullify a) tag
141 where
142 null = fromPrimExpr $ Opaleye.ConstExpr Opaleye.NullLit
145unnull :: Nullability a -> Expr (Nullify a) -> Expr a
146unnull nullability a = case nullability of
147 Nullable -> a
148 NonNullable -> unsafeUnnullify a
151type HNullifiable :: K.HContext -> Constraint
152class HNullifiable context where
153 type HConstrainTag context :: Type -> Constraint
154 type HConstrainTag _context = DefaultConstrainTag
156 hencodeTag :: (Sql (HConstrainTag context) a, KnownSymbol label, Taggable a)
157 => Tag label a
158 -> context ('Spec labels 'Required a)
160 hdecodeTag :: (Sql (HConstrainTag context) a, KnownSymbol label, Taggable a)
161 => context ('Spec labels 'Required a)
162 -> Tag label a
164 hnullifier :: ()
165 => Tag label a
166 -> (Expr a -> Expr Bool)
167 -> SSpec ('Spec labels necessity x)
168 -> context ('Spec labels necessity x)
169 -> context ('Spec labels necessity (Nullify x))
171 hunnullifier :: ()
172 => SSpec ('Spec labels necessity x)
173 -> context ('Spec labels necessity (Nullify x))
174 -> context ('Spec labels necessity x)
177instance Nullifiable context => HNullifiable (Col context) where
178 type HConstrainTag (Col context) = ConstrainTag context
179 hencodeTag = encodeTag
180 hdecodeTag = decodeTag
181 hnullifier = nullifier
182 hunnullifier = unnullifier
185instance HNullifiable (Dict (ConstrainDBType constraint)) where
186 type HConstrainTag (Dict (ConstrainDBType constraint)) = constraint
188 hencodeTag _ = Dict
189 hdecodeTag = mempty
191 hnullifier _ _ SSpec {} dict = case dbTypeDict dict of
192 Dict -> case dbTypeNullability dict of
193 Nullable -> Dict
194 NonNullable -> Dict
196 hunnullifier SSpec {nullability} dict = case dbTypeDict dict of
197 Dict -> case nullability of
198 Nullable -> Dict
199 NonNullable -> case dbTypeNullability dict of
200 Nullable -> fromNullabilityDict nullability Dict
203type DefaultConstrainTag :: Type -> Constraint
204class DefaultConstrainTag a
205instance DefaultConstrainTag a