git.iko.soy/rel8
on eb180fa help sign in
rel8/src/Rel8/Schema/Context/Nullify.hs
163 lines 5.0 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
39 ( Interpretation
40 , Col, Col'(..)
41 , Insertion
42 , Name( Name )
43 )
44import qualified Rel8.Schema.Kind as K
45import Rel8.Schema.Nullability ( Nullability( Nullable, NonNullable ), Sql )
46import Rel8.Schema.Spec ( Spec( Spec ), SSpec(..) )
47import Rel8.Type.Eq ( DBEq )
48import Rel8.Type.Monoid ( DBMonoid )
51type Nullifiable :: K.Context -> Constraint
52class Interpretation context => Nullifiable context where
53 encodeTag :: (Sql DBEq a, KnownLabels labels)
54 => Expr a
55 -> Col context ('Spec labels 'Required db a)
57 decodeTag :: Sql DBMonoid a
58 => Col context ('Spec labels 'Required db a)
59 -> Expr a
61 nullifier :: ()
62 => Expr Bool
63 -> SSpec ('Spec labels necessity db a)
64 -> Col context ('Spec labels necessity db a)
65 -> Col context ('Spec labels necessity db (Maybe db))
67 unnullifier :: ()
68 => Expr Bool
69 -> SSpec ('Spec labels necessity db a)
70 -> Col context ('Spec labels necessity db (Maybe db))
71 -> Col context ('Spec labels necessity db a)
74instance Nullifiable Aggregate where
75 encodeTag = Aggregation . groupByExpr
76 decodeTag (Aggregation aggregate) = fold $ undoGroupBy aggregate
78 nullifier tag SSpec {nullability} (Aggregation aggregate) = Aggregation $
79 mapInputs (toPrimExpr . runTag nullability tag . fromPrimExpr) $
80 runTag nullability tag <$> aggregate
82 unnullifier _ SSpec {nullability} (Aggregation aggregate) =
83 Aggregation $ unnull nullability <$> aggregate
85 {-# INLINABLE encodeTag #-}
86 {-# INLINABLE decodeTag #-}
87 {-# INLINABLE nullifier #-}
88 {-# INLINABLE unnullifier #-}
91instance Nullifiable Expr where
92 encodeTag = DB
93 decodeTag (DB a) = a
94 nullifier tag SSpec {nullability} (DB a) = DB $ runTag nullability tag a
95 unnullifier _ SSpec {nullability} (DB a) = DB $ unnull nullability a
97 {-# INLINABLE encodeTag #-}
98 {-# INLINABLE decodeTag #-}
99 {-# INLINABLE nullifier #-}
100 {-# INLINABLE unnullifier #-}
103instance Nullifiable Insertion where
104 encodeTag = RequiredInsert
105 decodeTag (RequiredInsert a) = a
107 nullifier tag SSpec {nullability} = \case
108 RequiredInsert a -> RequiredInsert $ runTag nullability tag a
109 OptionalInsert ma -> OptionalInsert $ runTag nullability tag <$> ma
111 unnullifier _ SSpec {nullability} = \case
112 RequiredInsert a -> RequiredInsert $ unnull nullability a
113 OptionalInsert ma -> OptionalInsert $ unnull nullability <$> ma
115 {-# INLINABLE encodeTag #-}
116 {-# INLINABLE decodeTag #-}
117 {-# INLINABLE nullifier #-}
118 {-# INLINABLE unnullifier #-}
121instance Nullifiable Name where
122 encodeTag _ = nameFromLabel
123 decodeTag _ = mempty
124 nullifier _ _ (Col (Name name)) = Col (Name name)
125 unnullifier _ _ (Col (Name name)) = Col (Name name)
127 {-# INLINABLE encodeTag #-}
128 {-# INLINABLE decodeTag #-}
129 {-# INLINABLE nullifier #-}
130 {-# INLINABLE unnullifier #-}
133type NullifiableEq :: K.Context -> K.Context -> Constraint
134class (a ~ b, Nullifiable b) => NullifiableEq a b
135instance (a ~ b, Nullifiable b) => NullifiableEq a b
138runTag :: Nullability db a -> Expr Bool -> Expr a -> Expr (Maybe db)
139runTag nullability tag a = case nullability of
140 Nullable -> boolExpr null a tag
141 NonNullable -> boolExpr null (nullify a) tag
142 where
143 null = Expr (Opaleye.ConstExpr Opaleye.NullLit)
146unnull :: Nullability db a -> Expr (Maybe db) -> Expr a
147unnull nullability a = case nullability of
148 Nullable -> a
149 NonNullable -> unsafeUnnullify a
152-- HACK
153undoGroupBy :: Aggregate (Expr _a) -> Maybe (Expr a)
154undoGroupBy = getFirst . foldInputs go
155 where
156 go Nothing a = pure (Expr a)
157 go _ _ = First empty
160nameFromLabel :: forall labels necessity db a.
161 KnownLabels labels => Col Name ('Spec labels necessity db a)
162nameFromLabel = case labelsSing @labels of
163 labels -> Col (Name (NonEmpty.last (renderLabels labels)))