git.iko.soy/rel8
on bb078d2 help sign in
rel8/src/Rel8/Schema/Context/Nullify.hs
162 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 ( Nullability( Nullable, NonNullable ), Sql )
45import Rel8.Schema.Spec ( Context, Spec( Spec ), SSpec(..) )
46import Rel8.Type.Eq ( DBEq )
47import Rel8.Type.Monoid ( DBMonoid )
50type Nullifiable :: Context -> Constraint
51class Nullifiable context where
52 encodeTag :: (Sql DBEq a, KnownLabels labels)
53 => Expr a
54 -> context ('Spec labels 'Required db a)
56 decodeTag :: Sql DBMonoid a
57 => context ('Spec labels 'Required db a)
58 -> Expr a
60 nullifier :: ()
61 => Expr Bool
62 -> SSpec ('Spec labels necessity db a)
63 -> context ('Spec labels necessity db a)
64 -> context ('Spec labels necessity db (Maybe db))
66 unnullifier :: ()
67 => Expr Bool
68 -> SSpec ('Spec labels necessity db a)
69 -> context ('Spec labels necessity db (Maybe db))
70 -> context ('Spec labels necessity db a)
73instance Nullifiable Aggregation where
74 encodeTag = Aggregation . groupByExpr
75 decodeTag (Aggregation aggregate) = fold $ undoGroupBy aggregate
77 nullifier tag SSpec {nullability} (Aggregation aggregate) = Aggregation $
78 mapInputs (toPrimExpr . runTag nullability tag . fromPrimExpr) $
79 runTag nullability tag <$> aggregate
81 unnullifier _ SSpec {nullability} (Aggregation aggregate) =
82 Aggregation $ unnull nullability <$> aggregate
84 {-# INLINABLE encodeTag #-}
85 {-# INLINABLE decodeTag #-}
86 {-# INLINABLE nullifier #-}
87 {-# INLINABLE unnullifier #-}
90instance Nullifiable DB where
91 encodeTag = DB
92 decodeTag (DB a) = a
93 nullifier tag SSpec {nullability} (DB a) = DB $ runTag nullability tag a
94 unnullifier _ SSpec {nullability} (DB a) = DB $ unnull nullability a
96 {-# INLINABLE encodeTag #-}
97 {-# INLINABLE decodeTag #-}
98 {-# INLINABLE nullifier #-}
99 {-# INLINABLE unnullifier #-}
102instance Nullifiable Insertion where
103 encodeTag = RequiredInsert
104 decodeTag (RequiredInsert a) = a
106 nullifier tag SSpec {nullability} = \case
107 RequiredInsert a -> RequiredInsert $ runTag nullability tag a
108 OptionalInsert ma -> OptionalInsert $ runTag nullability tag <$> ma
110 unnullifier _ SSpec {nullability} = \case
111 RequiredInsert a -> RequiredInsert $ unnull nullability a
112 OptionalInsert ma -> OptionalInsert $ unnull nullability <$> ma
114 {-# INLINABLE encodeTag #-}
115 {-# INLINABLE decodeTag #-}
116 {-# INLINABLE nullifier #-}
117 {-# INLINABLE unnullifier #-}
120instance Nullifiable Name where
121 encodeTag _ = nameFromLabel
122 decodeTag _ = mempty
123 nullifier _ _ (Name name) = Name name
124 unnullifier _ _ (Name name) = Name name
126 {-# INLINABLE encodeTag #-}
127 {-# INLINABLE decodeTag #-}
128 {-# INLINABLE nullifier #-}
129 {-# INLINABLE unnullifier #-}
132type NullifiableEq :: Context -> Context -> Constraint
133class (a ~ b, Nullifiable b) => NullifiableEq a b
134instance (a ~ b, Nullifiable b) => NullifiableEq a b
137runTag :: Nullability db a -> Expr Bool -> Expr a -> Expr (Maybe db)
138runTag nullability tag a = case nullability of
139 Nullable -> boolExpr null a tag
140 NonNullable -> boolExpr null (nullify a) tag
141 where
142 null = Expr (Opaleye.ConstExpr Opaleye.NullLit)
145unnull :: Nullability db a -> Expr (Maybe db) -> Expr a
146unnull nullability a = case nullability of
147 Nullable -> a
148 NonNullable -> unsafeUnnullify a
151-- HACK
152undoGroupBy :: Aggregate (Expr _a) -> Maybe (Expr a)
153undoGroupBy = getFirst . foldInputs go
154 where
155 go Nothing a = pure (Expr a)
156 go _ _ = First empty
159nameFromLabel :: forall labels necessity db a.
160 KnownLabels labels => Name ('Spec labels necessity db a)
161nameFromLabel = case labelsSing @labels of
162 labels -> Name (NonEmpty.last (renderLabels labels))