git.iko.soy/rel8
on f3daaff help sign in
rel8/src/Rel8/Schema/Context/Nullify.hs
158 lines 4.9 kB history raw
1{-# language DataKinds #-}
2{-# language LambdaCase #-}
3{-# language FlexibleContexts #-}
4{-# language FlexibleInstances #-}
5{-# language MultiParamTypeClasses #-}
6{-# language NamedFieldPuns #-}
7{-# language ScopedTypeVariables #-}
8{-# language StandaloneKindSignatures #-}
9{-# language TypeApplications #-}
10{-# language TypeFamilies #-}
12module Rel8.Schema.Context.Nullify
13 ( Nullifiable( encodeTag, decodeTag, nullifier, unnullifier )
14 , NullifiableEq
15 )
16where
18-- base
19import Control.Applicative ( empty )
20import Data.Foldable ( fold )
21import Data.Kind ( Constraint )
22import qualified Data.List.NonEmpty as NonEmpty
23import Data.Monoid ( First( First ), getFirst )
24import Prelude hiding ( null )
26-- opaleye
27import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
29-- rel8
30import Rel8.Aggregate ( Aggregate, foldInputs, mapInputs )
31import Rel8.Expr ( Expr( Expr ) )
32import Rel8.Expr.Aggregate ( groupByExpr )
33import Rel8.Expr.Bool ( boolExpr )
34import Rel8.Expr.Null ( nullify, unsafeUnnullify )
35import Rel8.Expr.Opaleye ( fromPrimExpr, toPrimExpr )
36import Rel8.Kind.Labels ( KnownLabels, labelsSing, renderLabels )
37import Rel8.Kind.Necessity ( Necessity( Required ) )
38import Rel8.Schema.Context ( Interpretation, Col(..), Insertion, Name )
39import qualified Rel8.Schema.Kind as K
40import Rel8.Schema.Nullability ( Nullability( Nullable, NonNullable ), Sql )
41import Rel8.Schema.Spec ( Spec( Spec ), SSpec(..) )
42import Rel8.Type.Eq ( DBEq )
43import Rel8.Type.Monoid ( DBMonoid )
46type Nullifiable :: K.Context -> Constraint
47class Interpretation context => Nullifiable context where
48 encodeTag :: (Sql DBEq a, KnownLabels labels)
49 => Expr a
50 -> Col context ('Spec labels 'Required db a)
52 decodeTag :: Sql DBMonoid a
53 => Col context ('Spec labels 'Required db a)
54 -> Expr a
56 nullifier :: ()
57 => Expr Bool
58 -> SSpec ('Spec labels necessity db a)
59 -> Col context ('Spec labels necessity db a)
60 -> Col context ('Spec labels necessity db (Maybe db))
62 unnullifier :: ()
63 => Expr Bool
64 -> SSpec ('Spec labels necessity db a)
65 -> Col context ('Spec labels necessity db (Maybe db))
66 -> Col context ('Spec labels necessity db a)
69instance Nullifiable Aggregate where
70 encodeTag = Aggregation . groupByExpr
71 decodeTag (Aggregation aggregate) = fold $ undoGroupBy aggregate
73 nullifier tag SSpec {nullability} (Aggregation aggregate) = Aggregation $
74 mapInputs (toPrimExpr . runTag nullability tag . fromPrimExpr) $
75 runTag nullability tag <$> aggregate
77 unnullifier _ SSpec {nullability} (Aggregation aggregate) =
78 Aggregation $ unnull nullability <$> aggregate
80 {-# INLINABLE encodeTag #-}
81 {-# INLINABLE decodeTag #-}
82 {-# INLINABLE nullifier #-}
83 {-# INLINABLE unnullifier #-}
86instance Nullifiable Expr where
87 encodeTag = DB
88 decodeTag (DB a) = a
89 nullifier tag SSpec {nullability} (DB a) = DB $ runTag nullability tag a
90 unnullifier _ SSpec {nullability} (DB a) = DB $ unnull nullability a
92 {-# INLINABLE encodeTag #-}
93 {-# INLINABLE decodeTag #-}
94 {-# INLINABLE nullifier #-}
95 {-# INLINABLE unnullifier #-}
98instance Nullifiable Insertion where
99 encodeTag = RequiredInsert
100 decodeTag (RequiredInsert a) = a
102 nullifier tag SSpec {nullability} = \case
103 RequiredInsert a -> RequiredInsert $ runTag nullability tag a
104 OptionalInsert ma -> OptionalInsert $ runTag nullability tag <$> ma
106 unnullifier _ SSpec {nullability} = \case
107 RequiredInsert a -> RequiredInsert $ unnull nullability a
108 OptionalInsert ma -> OptionalInsert $ unnull nullability <$> ma
110 {-# INLINABLE encodeTag #-}
111 {-# INLINABLE decodeTag #-}
112 {-# INLINABLE nullifier #-}
113 {-# INLINABLE unnullifier #-}
116instance Nullifiable Name where
117 encodeTag _ = nameFromLabel
118 decodeTag _ = mempty
119 nullifier _ _ (NameCol name) = NameCol name
120 unnullifier _ _ (NameCol name) = NameCol name
122 {-# INLINABLE encodeTag #-}
123 {-# INLINABLE decodeTag #-}
124 {-# INLINABLE nullifier #-}
125 {-# INLINABLE unnullifier #-}
128type NullifiableEq :: K.Context -> K.Context -> Constraint
129class (a ~ b, Nullifiable b) => NullifiableEq a b
130instance (a ~ b, Nullifiable b) => NullifiableEq a b
133runTag :: Nullability db a -> Expr Bool -> Expr a -> Expr (Maybe db)
134runTag nullability tag a = case nullability of
135 Nullable -> boolExpr null a tag
136 NonNullable -> boolExpr null (nullify a) tag
137 where
138 null = Expr (Opaleye.ConstExpr Opaleye.NullLit)
141unnull :: Nullability db a -> Expr (Maybe db) -> Expr a
142unnull nullability a = case nullability of
143 Nullable -> a
144 NonNullable -> unsafeUnnullify a
147-- HACK
148undoGroupBy :: Aggregate (Expr _a) -> Maybe (Expr a)
149undoGroupBy = getFirst . foldInputs go
150 where
151 go Nothing a = pure (Expr a)
152 go _ _ = First empty
155nameFromLabel :: forall labels necessity db a.
156 KnownLabels labels => Col Name ('Spec labels necessity db a)
157nameFromLabel = case labelsSing @labels of
158 labels -> NameCol (NonEmpty.last (renderLabels labels))