Nullify.hs

{-# 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
  )
where

-- base
import Data.Bool ( bool )
import Data.Functor.Identity ( Identity( Identity ) )
import Data.Kind ( Constraint, Type )
import Prelude hiding ( null )

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

-- rel8
import Rel8.Expr ( Expr )
import Rel8.Expr.Bool ( boolExpr )
import Rel8.Expr.Null ( nullify, unsafeUnnullify )
import Rel8.Expr.Opaleye ( fromPrimExpr )
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
  NExpr :: Nullifiability Expr
  NName :: Nullifiability Name


type Nullifiable :: K.Context -> Constraint
class Nullifiable context where
  nullifiability :: Nullifiability context


instance Nullifiable Expr where
  nullifiability = NExpr


instance Nullifiable Name where
  nullifiability = 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 = \case
  SExpr -> Right NExpr
  SField -> Left NField
  SName -> Right NName
  SResult -> Left NResult


absurd :: Nullifiability context -> NonNullifiability context -> a
absurd = \case
  NExpr -> \case
  NName -> \case


guarder :: ()
  => SContext context
  -> context tag
  -> (tag -> Bool)
  -> (Expr tag -> Expr Bool)
  -> context (Maybe a)
  -> context (Maybe a)
guarder = \case
  SExpr -> \tag _ isNonNull -> sguard (isNonNull tag)
  SField -> \_ _ _ -> id
  SName -> \_ _ _ -> id
  SResult -> \(Identity tag) isNonNull _ (Identity a) ->
    Identity (bool Nothing a (isNonNull tag))


nullifier :: ()
  => Nullifiability context
  -> Spec a
  -> context a
  -> context (Nullify a)
nullifier = \case
  NExpr -> \Spec {nullity} a -> snullify nullity a
  NName -> \_ (Name a) -> Name a


unnullifier :: ()
  => Nullifiability context
  -> Spec a
  -> context (Nullify a)
  -> context a
unnullifier = \case
  NExpr -> \Spec {nullity} a -> sunnullify nullity a
  NName -> \_ (Name a) -> Name a


sguard :: Expr Bool -> Expr (Maybe a) -> Expr (Maybe a)
sguard condition a = boolExpr null a condition
  where
    null = fromPrimExpr $ Opaleye.ConstExpr Opaleye.NullLit


snullify :: Nullity a -> Expr a -> Expr (Nullify a)
snullify nullity a = case nullity of
  Null -> a
  NotNull -> nullify a


sunnullify :: Nullity a -> Expr (Nullify a) -> Expr a
sunnullify nullity a = case nullity of
  Null -> a
  NotNull -> unsafeUnnullify a