{-# language DataKinds #-}
{-# language EmptyCase #-}
{-# language FlexibleContexts #-}
{-# language GADTs #-}
{-# language LambdaCase #-}
{-# language NamedFieldPuns #-}
{-# language StandaloneKindSignatures #-}
module Rel8.Schema.Context.Nullify
( Nullifiability(..), NonNullifiability(..), nullifiableOrNot, absurd
, Nullifiable, nullifiability
, guarder, nullifier, unnullifier
, sguard, snullify
)
where
import Data.Bool ( bool )
import Data.Functor.Identity ( Identity( Identity ) )
import Data.Kind ( Constraint, Type )
import Data.Monoid ( getFirst )
import Prelude hiding ( null )
import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
import Rel8.Aggregate ( Aggregate( Aggregate ), foldInputs, mapInputs )
import Rel8.Expr ( Expr )
import Rel8.Expr.Bool ( boolExpr )
import Rel8.Expr.Null ( nullify, unsafeUnnullify )
import Rel8.Expr.Opaleye ( fromPrimExpr, toPrimExpr )
import Rel8.Kind.Context ( SContext(..) )
import Rel8.Schema.Field ( Field )
import qualified Rel8.Schema.Kind as K
import Rel8.Schema.Name ( Name( Name ) )
import Rel8.Schema.Null ( Nullify, Nullity( Null, NotNull ) )
import Rel8.Schema.Result ( Result )
import Rel8.Schema.Spec ( Spec(..) )
type Nullifiability :: K.Context -> Type
data Nullifiability context where
NAggregate :: Nullifiability Aggregate
NExpr :: Nullifiability Expr
NName :: Nullifiability Name
type Nullifiable :: K.Context -> Constraint
class Nullifiable context where
nullifiability :: Nullifiability context
instance Nullifiable Aggregate where
nullifiability :: Nullifiability Aggregate
nullifiability = Nullifiability Aggregate
NAggregate
instance Nullifiable Expr where
nullifiability :: Nullifiability Expr
nullifiability = Nullifiability Expr
NExpr
instance Nullifiable Name where
nullifiability :: Nullifiability Name
nullifiability = Nullifiability Name
NName
type NonNullifiability :: K.Context -> Type
data NonNullifiability context where
NField :: NonNullifiability (Field table)
NResult :: NonNullifiability Result
nullifiableOrNot :: ()
=> SContext context
-> Either (NonNullifiability context) (Nullifiability context)
nullifiableOrNot :: SContext context
-> Either (NonNullifiability context) (Nullifiability context)
nullifiableOrNot = \case
SContext context
SAggregate -> Nullifiability Aggregate
-> Either (NonNullifiability context) (Nullifiability Aggregate)
forall a b. b -> Either a b
Right Nullifiability Aggregate
NAggregate
SContext context
SExpr -> Nullifiability Expr
-> Either (NonNullifiability context) (Nullifiability Expr)
forall a b. b -> Either a b
Right Nullifiability Expr
NExpr
SContext context
SField -> NonNullifiability (Field table)
-> Either
(NonNullifiability (Field table)) (Nullifiability context)
forall a b. a -> Either a b
Left NonNullifiability (Field table)
forall table. NonNullifiability (Field table)
NField
SContext context
SName -> Nullifiability Name
-> Either (NonNullifiability context) (Nullifiability Name)
forall a b. b -> Either a b
Right Nullifiability Name
NName
SContext context
SResult -> NonNullifiability Result
-> Either (NonNullifiability Result) (Nullifiability context)
forall a b. a -> Either a b
Left NonNullifiability Result
NResult
absurd :: Nullifiability context -> NonNullifiability context -> a
absurd :: Nullifiability context -> NonNullifiability context -> a
absurd = \case
Nullifiability context
NAggregate -> NonNullifiability context -> a
\case
Nullifiability context
NExpr -> NonNullifiability context -> a
\case
Nullifiability context
NName -> NonNullifiability context -> a
\case
guarder :: ()
=> SContext context
-> context tag
-> (tag -> Bool)
-> (Expr tag -> Expr Bool)
-> context (Maybe a)
-> context (Maybe a)
guarder :: SContext context
-> context tag
-> (tag -> Bool)
-> (Expr tag -> Expr Bool)
-> context (Maybe a)
-> context (Maybe a)
guarder = \case
SContext context
SAggregate -> \context tag
tag tag -> Bool
_ Expr tag -> Expr Bool
isNonNull (Aggregate a) ->
let
mtag :: First (Expr tag)
mtag = (Maybe Aggregator -> PrimExpr -> First (Expr tag))
-> Aggregate tag -> First (Expr tag)
forall a b.
Monoid b =>
(Maybe Aggregator -> PrimExpr -> b) -> Aggregate a -> b
foldInputs (\Maybe Aggregator
_ -> Expr tag -> First (Expr tag)
forall (f :: Context) a. Applicative f => a -> f a
pure (Expr tag -> First (Expr tag))
-> (PrimExpr -> Expr tag) -> PrimExpr -> First (Expr tag)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PrimExpr -> Expr tag
forall a. PrimExpr -> Expr a
fromPrimExpr) context tag
Aggregate tag
tag
run :: Expr (Maybe a) -> Expr (Maybe a)
run = (Expr (Maybe a) -> Expr (Maybe a))
-> (Expr tag -> Expr (Maybe a) -> Expr (Maybe a))
-> Maybe (Expr tag)
-> Expr (Maybe a)
-> Expr (Maybe a)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Expr (Maybe a) -> Expr (Maybe a)
forall a. a -> a
id (Expr Bool -> Expr (Maybe a) -> Expr (Maybe a)
forall a. Expr Bool -> Expr (Maybe a) -> Expr (Maybe a)
sguard (Expr Bool -> Expr (Maybe a) -> Expr (Maybe a))
-> (Expr tag -> Expr Bool)
-> Expr tag
-> Expr (Maybe a)
-> Expr (Maybe a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Expr tag -> Expr Bool
isNonNull) (First (Expr tag) -> Maybe (Expr tag)
forall a. First a -> Maybe a
getFirst First (Expr tag)
mtag)
in
(PrimExpr -> PrimExpr)
-> Aggregate (Maybe a) -> Aggregate (Maybe a)
forall a. (PrimExpr -> PrimExpr) -> Aggregate a -> Aggregate a
mapInputs (Expr (Maybe a) -> PrimExpr
forall a. Expr a -> PrimExpr
toPrimExpr (Expr (Maybe a) -> PrimExpr)
-> (PrimExpr -> Expr (Maybe a)) -> PrimExpr -> PrimExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Expr (Maybe a) -> Expr (Maybe a)
run (Expr (Maybe a) -> Expr (Maybe a))
-> (PrimExpr -> Expr (Maybe a)) -> PrimExpr -> Expr (Maybe a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PrimExpr -> Expr (Maybe a)
forall a. PrimExpr -> Expr a
fromPrimExpr) (Aggregate (Maybe a) -> Aggregate (Maybe a))
-> Aggregate (Maybe a) -> Aggregate (Maybe a)
forall a b. (a -> b) -> a -> b
$
Aggregator () (Expr (Maybe a)) -> Aggregate (Maybe a)
forall a. Aggregator () (Expr a) -> Aggregate a
Aggregate (Aggregator () (Expr (Maybe a)) -> Aggregate (Maybe a))
-> Aggregator () (Expr (Maybe a)) -> Aggregate (Maybe a)
forall a b. (a -> b) -> a -> b
$
Expr (Maybe a) -> Expr (Maybe a)
run (Expr (Maybe a) -> Expr (Maybe a))
-> Aggregator () (Expr (Maybe a)) -> Aggregator () (Expr (Maybe a))
forall (f :: Context) a b. Functor f => (a -> b) -> f a -> f b
<$> Aggregator () (Expr (Maybe a))
a
SContext context
SExpr -> \context tag
tag tag -> Bool
_ Expr tag -> Expr Bool
isNonNull context (Maybe a)
a -> Expr Bool -> Expr (Maybe a) -> Expr (Maybe a)
forall a. Expr Bool -> Expr (Maybe a) -> Expr (Maybe a)
sguard (Expr tag -> Expr Bool
isNonNull context tag
Expr tag
tag) context (Maybe a)
Expr (Maybe a)
a
SContext context
SField -> \context tag
_ tag -> Bool
_ Expr tag -> Expr Bool
_ context (Maybe a)
field -> context (Maybe a)
field
SContext context
SName -> \context tag
_ tag -> Bool
_ Expr tag -> Expr Bool
_ context (Maybe a)
name -> context (Maybe a)
name
SContext context
SResult -> \(Identity tag) tag -> Bool
isNonNull Expr tag -> Expr Bool
_ (Identity a) ->
Maybe a -> Identity (Maybe a)
forall a. a -> Identity a
Identity (Maybe a -> Maybe a -> Bool -> Maybe a
forall a. a -> a -> Bool -> a
bool Maybe a
forall a. Maybe a
Nothing Maybe a
a (tag -> Bool
isNonNull tag
tag))
nullifier :: ()
=> Nullifiability context
-> Spec a
-> context a
-> context (Nullify a)
nullifier :: Nullifiability context
-> Spec a -> context a -> context (Nullify a)
nullifier = \case
Nullifiability context
NAggregate -> \Spec {Nullity a
nullity :: forall a. Spec a -> Nullity a
nullity :: Nullity a
nullity} (Aggregate a) ->
Aggregator () (Expr (Nullify a)) -> Aggregate (Nullify a)
forall a. Aggregator () (Expr a) -> Aggregate a
Aggregate (Aggregator () (Expr (Nullify a)) -> Aggregate (Nullify a))
-> Aggregator () (Expr (Nullify a)) -> Aggregate (Nullify a)
forall a b. (a -> b) -> a -> b
$ Nullity a -> Expr a -> Expr (Nullify a)
forall a. Nullity a -> Expr a -> Expr (Nullify a)
snullify Nullity a
nullity (Expr a -> Expr (Nullify a))
-> Aggregator () (Expr a) -> Aggregator () (Expr (Nullify a))
forall (f :: Context) a b. Functor f => (a -> b) -> f a -> f b
<$> Aggregator () (Expr a)
a
Nullifiability context
NExpr -> \Spec {Nullity a
nullity :: Nullity a
nullity :: forall a. Spec a -> Nullity a
nullity} context a
a -> Nullity a -> Expr a -> Expr (Nullify a)
forall a. Nullity a -> Expr a -> Expr (Nullify a)
snullify Nullity a
nullity context a
Expr a
a
Nullifiability context
NName -> \Spec a
_ (Name a) -> String -> Name (Nullify a)
forall a. String -> Name a
Name String
a
unnullifier :: ()
=> Nullifiability context
-> Spec a
-> context (Nullify a)
-> context a
unnullifier :: Nullifiability context
-> Spec a -> context (Nullify a) -> context a
unnullifier = \case
Nullifiability context
NAggregate -> \Spec {Nullity a
nullity :: Nullity a
nullity :: forall a. Spec a -> Nullity a
nullity} (Aggregate a) ->
Aggregator () (Expr a) -> Aggregate a
forall a. Aggregator () (Expr a) -> Aggregate a
Aggregate (Aggregator () (Expr a) -> Aggregate a)
-> Aggregator () (Expr a) -> Aggregate a
forall a b. (a -> b) -> a -> b
$ Nullity a -> Expr (Nullify a) -> Expr a
forall a. Nullity a -> Expr (Nullify a) -> Expr a
sunnullify Nullity a
nullity (Expr (Nullify a) -> Expr a)
-> Aggregator () (Expr (Nullify a)) -> Aggregator () (Expr a)
forall (f :: Context) a b. Functor f => (a -> b) -> f a -> f b
<$> Aggregator () (Expr (Nullify a))
a
Nullifiability context
NExpr -> \Spec {Nullity a
nullity :: Nullity a
nullity :: forall a. Spec a -> Nullity a
nullity} context (Nullify a)
a -> Nullity a -> Expr (Nullify a) -> Expr a
forall a. Nullity a -> Expr (Nullify a) -> Expr a
sunnullify Nullity a
nullity context (Nullify a)
Expr (Nullify a)
a
Nullifiability context
NName -> \Spec a
_ (Name a) -> String -> Name a
forall a. String -> Name a
Name String
a
sguard :: Expr Bool -> Expr (Maybe a) -> Expr (Maybe a)
sguard :: Expr Bool -> Expr (Maybe a) -> Expr (Maybe a)
sguard Expr Bool
condition Expr (Maybe a)
a = Expr (Maybe a) -> Expr (Maybe a) -> Expr Bool -> Expr (Maybe a)
forall a. Expr a -> Expr a -> Expr Bool -> Expr a
boolExpr Expr (Maybe a)
forall a. Expr a
null Expr (Maybe a)
a Expr Bool
condition
where
null :: Expr a
null = PrimExpr -> Expr a
forall a. PrimExpr -> Expr a
fromPrimExpr (PrimExpr -> Expr a) -> PrimExpr -> Expr a
forall a b. (a -> b) -> a -> b
$ Literal -> PrimExpr
Opaleye.ConstExpr Literal
Opaleye.NullLit
snullify :: Nullity a -> Expr a -> Expr (Nullify a)
snullify :: Nullity a -> Expr a -> Expr (Nullify a)
snullify Nullity a
nullity Expr a
a = case Nullity a
nullity of
Nullity a
Null -> Expr a
Expr (Nullify a)
a
Nullity a
NotNull -> Expr a -> Expr (Maybe a)
forall a. NotNull a => Expr a -> Expr (Maybe a)
nullify Expr a
a
sunnullify :: Nullity a -> Expr (Nullify a) -> Expr a
sunnullify :: Nullity a -> Expr (Nullify a) -> Expr a
sunnullify Nullity a
nullity Expr (Nullify a)
a = case Nullity a
nullity of
Nullity a
Null -> Expr a
Expr (Nullify a)
a
Nullity a
NotNull -> Expr (Maybe a) -> Expr a
forall a. Expr (Maybe a) -> Expr a
unsafeUnnullify Expr (Maybe a)
Expr (Nullify a)
a