git.iko.soy/rel8
on 29cdfdb help sign in
rel8/src/Rel8/Schema/Context/Nullify.hs
152 lines 4.0 kB history raw
1{-# language DataKinds #-}
2{-# language EmptyCase #-}
3{-# language FlexibleContexts #-}
4{-# language GADTs #-}
5{-# language LambdaCase #-}
6{-# language NamedFieldPuns #-}
7{-# language StandaloneKindSignatures #-}
9module Rel8.Schema.Context.Nullify
10 ( Nullifiability(..), NonNullifiability(..), nullifiableOrNot, absurd
11 , Nullifiable, nullifiability
12 , guarder, nullifier, unnullifier
13 , sguard, snullify
14 )
15where
17-- base
18import Data.Bool ( bool )
19import Data.Functor.Identity ( Identity( Identity ) )
20import Data.Kind ( Constraint, Type )
21import Data.Monoid ( getFirst )
22import Prelude hiding ( null )
24-- opaleye
25import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
27-- rel8
28import Rel8.Aggregate ( Aggregate( Aggregate ), foldInputs, mapInputs )
29import Rel8.Expr ( Expr )
30import Rel8.Expr.Bool ( boolExpr )
31import Rel8.Expr.Null ( nullify, unsafeUnnullify )
32import Rel8.Expr.Opaleye ( fromPrimExpr, toPrimExpr )
33import Rel8.Kind.Context ( SContext(..) )
34import Rel8.Schema.Field ( Field )
35import qualified Rel8.Schema.Kind as K
36import Rel8.Schema.Name ( Name( Name ) )
37import Rel8.Schema.Null ( Nullify, Nullity( Null, NotNull ) )
38import Rel8.Schema.Result ( Result )
39import Rel8.Schema.Spec ( Spec(..) )
42type Nullifiability :: K.Context -> Type
43data Nullifiability context where
44 NAggregate :: Nullifiability Aggregate
45 NExpr :: Nullifiability Expr
46 NName :: Nullifiability Name
49type Nullifiable :: K.Context -> Constraint
50class Nullifiable context where
51 nullifiability :: Nullifiability context
54instance Nullifiable Aggregate where
55 nullifiability = NAggregate
58instance Nullifiable Expr where
59 nullifiability = NExpr
62instance Nullifiable Name where
63 nullifiability = NName
66type NonNullifiability :: K.Context -> Type
67data NonNullifiability context where
68 NField :: NonNullifiability (Field table)
69 NResult :: NonNullifiability Result
72nullifiableOrNot :: ()
73 => SContext context
74 -> Either (NonNullifiability context) (Nullifiability context)
75nullifiableOrNot = \case
76 SAggregate -> Right NAggregate
77 SExpr -> Right NExpr
78 SField -> Left NField
79 SName -> Right NName
80 SResult -> Left NResult
83absurd :: Nullifiability context -> NonNullifiability context -> a
84absurd = \case
85 NAggregate -> \case
86 NExpr -> \case
87 NName -> \case
90guarder :: ()
91 => SContext context
92 -> context tag
93 -> (tag -> Bool)
94 -> (Expr tag -> Expr Bool)
95 -> context (Maybe a)
96 -> context (Maybe a)
97guarder = \case
98 SAggregate -> \tag _ isNonNull (Aggregate a) ->
99 let
100 mtag = foldInputs (\_ -> pure . fromPrimExpr) tag
101 run = maybe id (sguard . isNonNull) (getFirst mtag)
102 in
103 mapInputs (toPrimExpr . run . fromPrimExpr) $
104 Aggregate $
105 run <$> a
106 SExpr -> \tag _ isNonNull a -> sguard (isNonNull tag) a
107 SField -> \_ _ _ field -> field
108 SName -> \_ _ _ name -> name
109 SResult -> \(Identity tag) isNonNull _ (Identity a) ->
110 Identity (bool Nothing a (isNonNull tag))
113nullifier :: ()
114 => Nullifiability context
115 -> Spec a
116 -> context a
117 -> context (Nullify a)
118nullifier = \case
119 NAggregate -> \Spec {nullity} (Aggregate a) ->
120 Aggregate $ snullify nullity <$> a
121 NExpr -> \Spec {nullity} a -> snullify nullity a
122 NName -> \_ (Name a) -> Name a
125unnullifier :: ()
126 => Nullifiability context
127 -> Spec a
128 -> context (Nullify a)
129 -> context a
130unnullifier = \case
131 NAggregate -> \Spec {nullity} (Aggregate a) ->
132 Aggregate $ sunnullify nullity <$> a
133 NExpr -> \Spec {nullity} a -> sunnullify nullity a
134 NName -> \_ (Name a) -> Name a
137sguard :: Expr Bool -> Expr (Maybe a) -> Expr (Maybe a)
138sguard condition a = boolExpr null a condition
139 where
140 null = fromPrimExpr $ Opaleye.ConstExpr Opaleye.NullLit
143snullify :: Nullity a -> Expr a -> Expr (Nullify a)
144snullify nullity a = case nullity of
145 Null -> a
146 NotNull -> nullify a
149sunnullify :: Nullity a -> Expr (Nullify a) -> Expr a
150sunnullify nullity a = case nullity of
151 Null -> a
152 NotNull -> unsafeUnnullify a