{-# language DataKinds #-}
{-# language FlexibleContexts #-}
{-# language FlexibleInstances #-}
{-# language InstanceSigs #-}
{-# language MultiParamTypeClasses #-}
{-# language NamedFieldPuns #-}
{-# language ScopedTypeVariables #-}
{-# language StandaloneKindSignatures #-}
{-# language TypeFamilies #-}

module Rel8.Schema.Context.Nullify
  ( Nullifiable( ConstrainTag, encodeTag, decodeTag, nullifier, unnullifier )
  , HNullifiable( HConstrainTag, hencodeTag, hdecodeTag, hnullifier, hunnullifier )
  , runTag, unnull
  )
where

-- base
import Data.Kind ( Constraint, Type )
import GHC.TypeLits ( KnownSymbol )
import Prelude hiding ( null )

-- opaleye
import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye

-- rel8
import Rel8.Aggregate
  ( Aggregate( Aggregate ), Col( A )
  , mapInputs
  , unsafeMakeAggregate
  )
import Rel8.Expr ( Expr, Col( E ) )
import Rel8.Expr.Bool ( boolExpr )
import Rel8.Expr.Null ( nullify, unsafeUnnullify )
import Rel8.Expr.Opaleye ( fromPrimExpr, toPrimExpr )
import Rel8.Kind.Necessity ( Necessity( Required ) )
import Rel8.Schema.Context ( Interpretation )
import qualified Rel8.Schema.Kind as K
import Rel8.Schema.Name ( Name( Name ), Col( N ) )
import Rel8.Schema.Null ( Nullify, Nullity( Null, NotNull ), Sql )
import Rel8.Schema.Dict ( Dict( Dict ) )
import Rel8.Schema.Spec ( Spec( Spec ), SSpec(..) )
import Rel8.Schema.Spec.ConstrainDBType ( ConstrainDBType )
import qualified Rel8.Schema.Spec.ConstrainDBType as ConstrainDBType
import Rel8.Table.Tag ( Tag(..), Taggable, fromAggregate, fromExpr, fromName )


type Nullifiable :: K.Context -> Constraint
class Interpretation context => Nullifiable context where
  type ConstrainTag context :: Type -> Constraint
  type ConstrainTag _context = DefaultConstrainTag

  encodeTag ::
    ( Sql (ConstrainTag context) a
    , KnownSymbol label
    , Taggable a
    )
    => Tag label a
    -> Col context ('Spec labels 'Required a)

  decodeTag ::
    ( Sql (ConstrainTag context) a
    , KnownSymbol label
    , Taggable a
    )
    => Col context ('Spec labels 'Required a)
    -> Tag label a

  nullifier :: ()
    => Tag label a
    -> (Expr a -> Expr Bool)
    -> SSpec ('Spec labels necessity x)
    -> Col context ('Spec labels necessity x)
    -> Col context ('Spec labels necessity (Nullify x))

  unnullifier :: ()
    => SSpec ('Spec labels necessity x)
    -> Col context ('Spec labels necessity (Nullify x))
    -> Col context ('Spec labels necessity x)


instance Nullifiable Aggregate where
  encodeTag :: Tag label a -> Col Aggregate ('Spec labels 'Required a)
encodeTag Tag {Maybe Aggregator
aggregator :: forall (label :: Symbol) a. Tag label a -> Maybe Aggregator
aggregator :: Maybe Aggregator
aggregator, Expr a
expr :: forall (label :: Symbol) a. Tag label a -> Expr a
expr :: Expr a
expr} =
    Aggregate a -> Col Aggregate ('Spec labels 'Required a)
forall a (labels :: Labels) (necessity :: Necessity).
Aggregate a -> Col Aggregate ('Spec labels necessity a)
A (Aggregate a -> Col Aggregate ('Spec labels 'Required a))
-> Aggregate a -> Col Aggregate ('Spec labels 'Required a)
forall a b. (a -> b) -> a -> b
$ (Expr a -> PrimExpr)
-> (PrimExpr -> Expr a)
-> Maybe Aggregator
-> Expr a
-> Aggregate a
forall k1 k2 (input :: k1) (output :: k2).
(Expr input -> PrimExpr)
-> (PrimExpr -> Expr output)
-> Maybe Aggregator
-> Expr input
-> Aggregate output
unsafeMakeAggregate Expr a -> PrimExpr
forall a. Expr a -> PrimExpr
toPrimExpr PrimExpr -> Expr a
forall a. PrimExpr -> Expr a
fromPrimExpr Maybe Aggregator
aggregator Expr a
expr

  decodeTag :: Col Aggregate ('Spec labels 'Required a) -> Tag label a
decodeTag (A aggregate) = Aggregate a -> Tag label a
forall a (label :: Symbol).
(KnownSymbol label, Taggable a) =>
Aggregate a -> Tag label a
fromAggregate Aggregate a
aggregate

  nullifier :: Tag label a
-> (Expr a -> Expr Bool)
-> SSpec ('Spec labels necessity x)
-> Col Aggregate ('Spec labels necessity x)
-> Col Aggregate ('Spec labels necessity (Nullify x))
nullifier Tag {Expr a
expr :: Expr a
expr :: forall (label :: Symbol) a. Tag label a -> Expr a
expr} Expr a -> Expr Bool
test SSpec {Nullity a
nullity :: forall (labels :: Labels) (necessity :: Necessity) a.
SSpec ('Spec labels necessity a) -> Nullity a
nullity :: Nullity a
nullity} (A (Aggregate a)) =
    Aggregate (Nullify x)
-> Col Aggregate ('Spec labels necessity (Nullify x))
forall a (labels :: Labels) (necessity :: Necessity).
Aggregate a -> Col Aggregate ('Spec labels necessity a)
A (Aggregate (Nullify x)
 -> Col Aggregate ('Spec labels necessity (Nullify x)))
-> Aggregate (Nullify x)
-> Col Aggregate ('Spec labels necessity (Nullify x))
forall a b. (a -> b) -> a -> b
$
    (PrimExpr -> PrimExpr)
-> Aggregate (Nullify x) -> Aggregate (Nullify x)
forall k (a :: k).
(PrimExpr -> PrimExpr) -> Aggregate a -> Aggregate a
mapInputs (Expr (Nullify x) -> PrimExpr
forall a. Expr a -> PrimExpr
toPrimExpr (Expr (Nullify x) -> PrimExpr)
-> (PrimExpr -> Expr (Nullify x)) -> PrimExpr -> PrimExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Nullity a -> Expr Bool -> Expr a -> Expr (Nullify a)
forall a. Nullity a -> Expr Bool -> Expr a -> Expr (Nullify a)
runTag Nullity a
nullity Expr Bool
condition (Expr a -> Expr (Nullify x))
-> (PrimExpr -> Expr a) -> PrimExpr -> Expr (Nullify x)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PrimExpr -> Expr a
forall a. PrimExpr -> Expr a
fromPrimExpr) (Aggregate (Nullify x) -> Aggregate (Nullify x))
-> Aggregate (Nullify x) -> Aggregate (Nullify x)
forall a b. (a -> b) -> a -> b
$
    Aggregator () (Expr (Nullify x)) -> Aggregate (Nullify x)
forall k (a :: k). Aggregator () (Expr a) -> Aggregate a
Aggregate (Aggregator () (Expr (Nullify x)) -> Aggregate (Nullify x))
-> Aggregator () (Expr (Nullify x)) -> Aggregate (Nullify x)
forall a b. (a -> b) -> a -> b
$
    Nullity a -> Expr Bool -> Expr a -> Expr (Nullify a)
forall a. Nullity a -> Expr Bool -> Expr a -> Expr (Nullify a)
runTag Nullity a
nullity Expr Bool
condition (Expr a -> Expr (Nullify x))
-> Aggregator () (Expr a) -> Aggregator () (Expr (Nullify x))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Aggregator () (Expr a)
Aggregator () (Expr a)
a
    where
      condition :: Expr Bool
condition = Expr a -> Expr Bool
test Expr a
expr

  unnullifier :: SSpec ('Spec labels necessity x)
-> Col Aggregate ('Spec labels necessity (Nullify x))
-> Col Aggregate ('Spec labels necessity x)
unnullifier SSpec {Nullity a
nullity :: Nullity a
nullity :: forall (labels :: Labels) (necessity :: Necessity) a.
SSpec ('Spec labels necessity a) -> Nullity a
nullity} (A (Aggregate a)) =
    Aggregate a -> Col Aggregate ('Spec labels necessity a)
forall a (labels :: Labels) (necessity :: Necessity).
Aggregate a -> Col Aggregate ('Spec labels necessity a)
A (Aggregator () (Expr a) -> Aggregate a
forall k (a :: k). Aggregator () (Expr a) -> Aggregate a
Aggregate (Nullity a -> Expr (Nullify a) -> Expr a
forall a. Nullity a -> Expr (Nullify a) -> Expr a
unnull Nullity a
nullity (Expr a -> Expr a)
-> Aggregator () (Expr a) -> Aggregator () (Expr a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Aggregator () (Expr a)
a))

  {-# INLINABLE encodeTag #-}
  {-# INLINABLE decodeTag #-}
  {-# INLINABLE nullifier #-}
  {-# INLINABLE unnullifier #-}


instance Nullifiable Expr where
  encodeTag :: Tag label a -> Col Expr ('Spec labels 'Required a)
encodeTag Tag {Expr a
expr :: Expr a
expr :: forall (label :: Symbol) a. Tag label a -> Expr a
expr} = Expr a -> Col Expr ('Spec labels 'Required a)
forall a (labels :: Labels) (necessity :: Necessity).
Expr a -> Col Expr ('Spec labels necessity a)
E Expr a
expr
  decodeTag :: Col Expr ('Spec labels 'Required a) -> Tag label a
decodeTag (E a) = Expr a -> Tag label a
forall (label :: Symbol) a.
(KnownSymbol label, Taggable a) =>
Expr a -> Tag label a
fromExpr Expr a
a
  nullifier :: Tag label a
-> (Expr a -> Expr Bool)
-> SSpec ('Spec labels necessity x)
-> Col Expr ('Spec labels necessity x)
-> Col Expr ('Spec labels necessity (Nullify x))
nullifier Tag {Expr a
expr :: Expr a
expr :: forall (label :: Symbol) a. Tag label a -> Expr a
expr} Expr a -> Expr Bool
test SSpec {Nullity a
nullity :: Nullity a
nullity :: forall (labels :: Labels) (necessity :: Necessity) a.
SSpec ('Spec labels necessity a) -> Nullity a
nullity} (E a) =
    Expr (Nullify x) -> Col Expr ('Spec labels necessity (Nullify x))
forall a (labels :: Labels) (necessity :: Necessity).
Expr a -> Col Expr ('Spec labels necessity a)
E (Expr (Nullify x) -> Col Expr ('Spec labels necessity (Nullify x)))
-> Expr (Nullify x)
-> Col Expr ('Spec labels necessity (Nullify x))
forall a b. (a -> b) -> a -> b
$ Nullity a -> Expr Bool -> Expr a -> Expr (Nullify a)
forall a. Nullity a -> Expr Bool -> Expr a -> Expr (Nullify a)
runTag Nullity a
nullity (Expr a -> Expr Bool
test Expr a
expr) Expr a
Expr a
a
  unnullifier :: SSpec ('Spec labels necessity x)
-> Col Expr ('Spec labels necessity (Nullify x))
-> Col Expr ('Spec labels necessity x)
unnullifier SSpec {Nullity a
nullity :: Nullity a
nullity :: forall (labels :: Labels) (necessity :: Necessity) a.
SSpec ('Spec labels necessity a) -> Nullity a
nullity} (E a) = Expr a -> Col Expr ('Spec labels necessity a)
forall a (labels :: Labels) (necessity :: Necessity).
Expr a -> Col Expr ('Spec labels necessity a)
E (Expr a -> Col Expr ('Spec labels necessity a))
-> Expr a -> Col Expr ('Spec labels necessity a)
forall a b. (a -> b) -> a -> b
$ Nullity a -> Expr (Nullify a) -> Expr a
forall a. Nullity a -> Expr (Nullify a) -> Expr a
unnull Nullity a
nullity Expr a
Expr (Nullify a)
a

  {-# INLINABLE encodeTag #-}
  {-# INLINABLE decodeTag #-}
  {-# INLINABLE nullifier #-}
  {-# INLINABLE unnullifier #-}


instance Nullifiable Name where
  encodeTag :: Tag label a -> Col Name ('Spec labels 'Required a)
encodeTag Tag {Name a
name :: forall (label :: Symbol) a. Tag label a -> Name a
name :: Name a
name} = Name a -> Col Name ('Spec labels 'Required a)
forall a (labels :: Labels) (necessity :: Necessity).
Name a -> Col Name ('Spec labels necessity a)
N Name a
name
  decodeTag :: Col Name ('Spec labels 'Required a) -> Tag label a
decodeTag (N name) = Name a -> Tag label a
forall a (label :: Symbol). Taggable a => Name a -> Tag label a
fromName Name a
name
  nullifier :: Tag label a
-> (Expr a -> Expr Bool)
-> SSpec ('Spec labels necessity x)
-> Col Name ('Spec labels necessity x)
-> Col Name ('Spec labels necessity (Nullify x))
nullifier Tag label a
_ Expr a -> Expr Bool
_ SSpec ('Spec labels necessity x)
_ (N (Name name)) = Name (Nullify x) -> Col Name ('Spec labels necessity (Nullify x))
forall a (labels :: Labels) (necessity :: Necessity).
Name a -> Col Name ('Spec labels necessity a)
N (String -> Name (Nullify x)
forall k (a :: k). (k ~ *) => String -> Name a
Name String
name)
  unnullifier :: SSpec ('Spec labels necessity x)
-> Col Name ('Spec labels necessity (Nullify x))
-> Col Name ('Spec labels necessity x)
unnullifier SSpec ('Spec labels necessity x)
_ (N (Name name)) = Name x -> Col Name ('Spec labels necessity x)
forall a (labels :: Labels) (necessity :: Necessity).
Name a -> Col Name ('Spec labels necessity a)
N (String -> Name x
forall k (a :: k). (k ~ *) => String -> Name a
Name String
name)

  {-# INLINABLE encodeTag #-}
  {-# INLINABLE decodeTag #-}
  {-# INLINABLE nullifier #-}
  {-# INLINABLE unnullifier #-}


runTag :: Nullity a -> Expr Bool -> Expr a -> Expr (Nullify a)
runTag :: Nullity a -> Expr Bool -> Expr a -> Expr (Nullify a)
runTag Nullity a
nullity Expr Bool
tag Expr a
a = case Nullity a
nullity of
  Nullity a
Null -> Expr a -> Expr a -> Expr Bool -> Expr a
forall a. Expr a -> Expr a -> Expr Bool -> Expr a
boolExpr Expr a
forall a. Expr a
null Expr a
a Expr Bool
tag
  Nullity a
NotNull -> 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 a -> Expr (Maybe a)
forall a. NotNull a => Expr a -> Expr (Maybe a)
nullify Expr a
a) Expr Bool
tag
  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


unnull :: Nullity a -> Expr (Nullify a) -> Expr a
unnull :: Nullity a -> Expr (Nullify a) -> Expr a
unnull 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


type HNullifiable :: K.HContext -> Constraint
class HNullifiable context where
  type HConstrainTag context :: Type -> Constraint
  type HConstrainTag _context = DefaultConstrainTag

  hencodeTag :: (Sql (HConstrainTag context) a, KnownSymbol label, Taggable a)
    => Tag label a
    -> context ('Spec labels 'Required a)

  hdecodeTag :: (Sql (HConstrainTag context) a, KnownSymbol label, Taggable a)
    => context ('Spec labels 'Required a)
    -> Tag label a

  hnullifier :: ()
    => Tag label a
    -> (Expr a -> Expr Bool)
    -> SSpec ('Spec labels necessity x)
    -> context ('Spec labels necessity x)
    -> context ('Spec labels necessity (Nullify x))

  hunnullifier :: ()
    => SSpec ('Spec labels necessity x)
    -> context ('Spec labels necessity (Nullify x))
    -> context ('Spec labels necessity x)


instance Nullifiable context => HNullifiable (Col context) where
  type HConstrainTag (Col context) = ConstrainTag context
  hencodeTag :: Tag label a -> Col context ('Spec labels 'Required a)
hencodeTag = Tag label a -> Col context ('Spec labels 'Required a)
forall (context :: Context) a (label :: Symbol) (labels :: Labels).
(Nullifiable context, Sql (ConstrainTag context) a,
 KnownSymbol label, Taggable a) =>
Tag label a -> Col context ('Spec labels 'Required a)
encodeTag
  hdecodeTag :: Col context ('Spec labels 'Required a) -> Tag label a
hdecodeTag = Col context ('Spec labels 'Required a) -> Tag label a
forall (context :: Context) a (label :: Symbol) (labels :: Labels).
(Nullifiable context, Sql (ConstrainTag context) a,
 KnownSymbol label, Taggable a) =>
Col context ('Spec labels 'Required a) -> Tag label a
decodeTag
  hnullifier :: Tag label a
-> (Expr a -> Expr Bool)
-> SSpec ('Spec labels necessity x)
-> Col context ('Spec labels necessity x)
-> Col context ('Spec labels necessity (Nullify x))
hnullifier = Tag label a
-> (Expr a -> Expr Bool)
-> SSpec ('Spec labels necessity x)
-> Col context ('Spec labels necessity x)
-> Col context ('Spec labels necessity (Nullify x))
forall (context :: Context) (label :: Symbol) a (labels :: Labels)
       (necessity :: Necessity) x.
Nullifiable context =>
Tag label a
-> (Expr a -> Expr Bool)
-> SSpec ('Spec labels necessity x)
-> Col context ('Spec labels necessity x)
-> Col context ('Spec labels necessity (Nullify x))
nullifier
  hunnullifier :: SSpec ('Spec labels necessity x)
-> Col context ('Spec labels necessity (Nullify x))
-> Col context ('Spec labels necessity x)
hunnullifier = SSpec ('Spec labels necessity x)
-> Col context ('Spec labels necessity (Nullify x))
-> Col context ('Spec labels necessity x)
forall (context :: Context) (labels :: Labels)
       (necessity :: Necessity) x.
Nullifiable context =>
SSpec ('Spec labels necessity x)
-> Col context ('Spec labels necessity (Nullify x))
-> Col context ('Spec labels necessity x)
unnullifier


instance HNullifiable (Dict (ConstrainDBType constraint)) where
  type HConstrainTag (Dict (ConstrainDBType constraint)) = constraint

  hencodeTag :: Tag label a
-> Dict (ConstrainDBType constraint) ('Spec labels 'Required a)
hencodeTag Tag label a
_ = Dict (ConstrainDBType constraint) ('Spec labels 'Required a)
forall a (c :: a -> Constraint) (a :: a). c a => Dict c a
Dict
  hdecodeTag :: Dict (ConstrainDBType constraint) ('Spec labels 'Required a)
-> Tag label a
hdecodeTag = Dict (ConstrainDBType constraint) ('Spec labels 'Required a)
-> Tag label a
forall a. Monoid a => a
mempty
  hnullifier :: Tag label a
-> (Expr a -> Expr Bool)
-> SSpec ('Spec labels necessity x)
-> Dict (ConstrainDBType constraint) ('Spec labels necessity x)
-> Dict
     (ConstrainDBType constraint) ('Spec labels necessity (Nullify x))
hnullifier Tag label a
_ Expr a -> Expr Bool
_ = SSpec ('Spec labels necessity x)
-> Dict (ConstrainDBType constraint) ('Spec labels necessity x)
-> Dict
     (ConstrainDBType constraint) ('Spec labels necessity (Nullify x))
forall (labels :: Labels) (necessity :: Necessity) a
       (c :: * -> Constraint).
SSpec ('Spec labels necessity a)
-> Dict (ConstrainDBType c) ('Spec labels necessity a)
-> Dict (ConstrainDBType c) ('Spec labels necessity (Nullify a))
ConstrainDBType.nullifier
  hunnullifier :: SSpec ('Spec labels necessity x)
-> Dict
     (ConstrainDBType constraint) ('Spec labels necessity (Nullify x))
-> Dict (ConstrainDBType constraint) ('Spec labels necessity x)
hunnullifier = SSpec ('Spec labels necessity x)
-> Dict
     (ConstrainDBType constraint) ('Spec labels necessity (Nullify x))
-> Dict (ConstrainDBType constraint) ('Spec labels necessity x)
forall (labels :: Labels) (necessity :: Necessity) a
       (c :: * -> Constraint).
SSpec ('Spec labels necessity a)
-> Dict (ConstrainDBType c) ('Spec labels necessity (Nullify a))
-> Dict (ConstrainDBType c) ('Spec labels necessity a)
ConstrainDBType.unnullifier


type DefaultConstrainTag :: Type -> Constraint
class DefaultConstrainTag a
instance DefaultConstrainTag a