git.iko.soy/rel8
on cf03bcd help sign in
rel8/src/Rel8/Schema/Context/Nullify.hs
165 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
39 ( Aggregation( Aggregation )
40 , DB( DB )
41 , Insertion( RequiredInsert, OptionalInsert )
42 , Name( Name )
43 )
44import Rel8.Schema.Nullability
45 ( Nullability( Nullable, NonNullable )
46 , Nullabilizes
47 )
48import Rel8.Schema.Spec ( Context, Spec( Spec ), SSpec(..) )
49import Rel8.Type.Eq ( DBEq )
50import Rel8.Type.Monoid ( DBMonoid )
53type Nullifiable :: Context -> Constraint
54class Nullifiable context where
55 encodeTag :: (DBEq db, Nullabilizes db a, KnownLabels labels)
56 => Expr a
57 -> context ('Spec labels 'Required db a)
59 decodeTag :: (DBMonoid db, Nullabilizes db a)
60 => context ('Spec labels 'Required db a)
61 -> Expr a
63 nullifier :: ()
64 => Expr Bool
65 -> SSpec ('Spec labels necessity db a)
66 -> context ('Spec labels necessity db a)
67 -> context ('Spec labels necessity db (Maybe db))
69 unnullifier :: ()
70 => Expr Bool
71 -> SSpec ('Spec labels necessity db a)
72 -> context ('Spec labels necessity db (Maybe db))
73 -> context ('Spec labels necessity db a)
76instance Nullifiable Aggregation where
77 encodeTag = Aggregation . groupByExpr
78 decodeTag (Aggregation aggregate) = fold $ undoGroupBy aggregate
80 nullifier tag SSpec {nullability} (Aggregation aggregate) = Aggregation $
81 mapInputs (toPrimExpr . runTag nullability tag . fromPrimExpr) $
82 runTag nullability tag <$> aggregate
84 unnullifier _ SSpec {nullability} (Aggregation aggregate) =
85 Aggregation $ unnull nullability <$> aggregate
87 {-# INLINABLE encodeTag #-}
88 {-# INLINABLE decodeTag #-}
89 {-# INLINABLE nullifier #-}
90 {-# INLINABLE unnullifier #-}
93instance Nullifiable DB where
94 encodeTag = DB
95 decodeTag (DB a) = a
96 nullifier tag SSpec {nullability} (DB a) = DB $ runTag nullability tag a
97 unnullifier _ SSpec {nullability} (DB a) = DB $ unnull nullability a
99 {-# INLINABLE encodeTag #-}
100 {-# INLINABLE decodeTag #-}
101 {-# INLINABLE nullifier #-}
102 {-# INLINABLE unnullifier #-}
105instance Nullifiable Insertion where
106 encodeTag = RequiredInsert
107 decodeTag (RequiredInsert a) = a
109 nullifier tag SSpec {nullability} = \case
110 RequiredInsert a -> RequiredInsert $ runTag nullability tag a
111 OptionalInsert ma -> OptionalInsert $ runTag nullability tag <$> ma
113 unnullifier _ SSpec {nullability} = \case
114 RequiredInsert a -> RequiredInsert $ unnull nullability a
115 OptionalInsert ma -> OptionalInsert $ unnull nullability <$> ma
117 {-# INLINABLE encodeTag #-}
118 {-# INLINABLE decodeTag #-}
119 {-# INLINABLE nullifier #-}
120 {-# INLINABLE unnullifier #-}
123instance Nullifiable Name where
124 encodeTag _ = nameFromLabel
125 decodeTag _ = mempty
126 nullifier _ _ (Name name) = Name name
127 unnullifier _ _ (Name name) = Name name
129 {-# INLINABLE encodeTag #-}
130 {-# INLINABLE decodeTag #-}
131 {-# INLINABLE nullifier #-}
132 {-# INLINABLE unnullifier #-}
135type NullifiableEq :: Context -> Context -> Constraint
136class (a ~ b, Nullifiable b) => NullifiableEq a b
137instance (a ~ b, Nullifiable b) => NullifiableEq a b
140runTag :: Nullability db a -> Expr Bool -> Expr a -> Expr (Maybe db)
141runTag nullability tag a = case nullability of
142 Nullable -> boolExpr null a tag
143 NonNullable -> boolExpr null (nullify a) tag
144 where
145 null = Expr (Opaleye.ConstExpr Opaleye.NullLit)
148unnull :: Nullability db a -> Expr (Maybe db) -> Expr a
149unnull nullability a = case nullability of
150 Nullable -> a
151 NonNullable -> unsafeUnnullify a
154-- HACK
155undoGroupBy :: Aggregate (Expr _a) -> Maybe (Expr a)
156undoGroupBy = getFirst . foldInputs go
157 where
158 go Nothing a = pure (Expr a)
159 go _ _ = First empty
162nameFromLabel :: forall labels necessity db a.
163 KnownLabels labels => Name ('Spec labels necessity db a)
164nameFromLabel = case labelsSing @labels of
165 labels -> Name (NonEmpty.last (renderLabels labels))