{-# language GADTs #-}
{-# language LambdaCase #-}
{-# language NamedFieldPuns #-}
module Rel8.Query.Maybe
( optional
, catMaybeTable
, traverseMaybeTable
)
where
import Prelude
import Control.Comonad ( extract )
import qualified Opaleye.Internal.MaybeFields as Opaleye
import Rel8.Expr ( Expr )
import Rel8.Expr.Eq ( (==.) )
import Rel8.Expr.Opaleye ( fromColumn, fromPrimExpr )
import Rel8.Query ( Query )
import Rel8.Query.Filter ( where_ )
import Rel8.Query.Opaleye ( mapOpaleye )
import Rel8.Table.Maybe ( MaybeTable(..), isJustTable )
optional :: Query a -> Query (MaybeTable Expr a)
optional :: Query a -> Query (MaybeTable Expr a)
optional = (Select a -> Select (MaybeTable Expr a))
-> Query a -> Query (MaybeTable Expr a)
forall a b. (Select a -> Select b) -> Query a -> Query b
mapOpaleye ((Select a -> Select (MaybeTable Expr a))
-> Query a -> Query (MaybeTable Expr a))
-> (Select a -> Select (MaybeTable Expr a))
-> Query a
-> Query (MaybeTable Expr a)
forall a b. (a -> b) -> a -> b
$ (Field (Nullable SqlBool) -> a -> MaybeTable Expr a)
-> Select a -> Select (MaybeTable Expr a)
forall a r.
(Field (Nullable SqlBool) -> a -> r) -> Select a -> Select r
Opaleye.optionalInternal ((Field (Nullable SqlBool) -> a -> MaybeTable Expr a)
-> Select a -> Select (MaybeTable Expr a))
-> (Field (Nullable SqlBool) -> a -> MaybeTable Expr a)
-> Select a
-> Select (MaybeTable Expr a)
forall a b. (a -> b) -> a -> b
$ \Field (Nullable SqlBool)
tag a
a -> MaybeTable :: forall (context :: Context) a.
context (Maybe MaybeTag)
-> Nullify context a -> MaybeTable context a
MaybeTable
{ tag :: Expr (Maybe MaybeTag)
tag = PrimExpr -> Expr (Maybe MaybeTag)
forall a. PrimExpr -> Expr a
fromPrimExpr (PrimExpr -> Expr (Maybe MaybeTag))
-> PrimExpr -> Expr (Maybe MaybeTag)
forall a b. (a -> b) -> a -> b
$ Column (Nullable SqlBool) -> PrimExpr
forall b. Column b -> PrimExpr
fromColumn Field (Nullable SqlBool)
Column (Nullable SqlBool)
tag
, just :: Nullify Expr a
just = a -> Nullify Expr a
forall (f :: Context) a. Applicative f => a -> f a
pure a
a
}
catMaybeTable :: MaybeTable Expr a -> Query a
catMaybeTable :: MaybeTable Expr a -> Query a
catMaybeTable ma :: MaybeTable Expr a
ma@(MaybeTable Expr (Maybe MaybeTag)
_ Nullify Expr a
a) = do
Expr Bool -> Query ()
where_ (Expr Bool -> Query ()) -> Expr Bool -> Query ()
forall a b. (a -> b) -> a -> b
$ MaybeTable Expr a -> Expr Bool
forall a. MaybeTable Expr a -> Expr Bool
isJustTable MaybeTable Expr a
ma
a -> Query a
forall (f :: Context) a. Applicative f => a -> f a
pure (Nullify Expr a -> a
forall (w :: Context) a. Comonad w => w a -> a
extract Nullify Expr a
a)
traverseMaybeTable :: (a -> Query b) -> MaybeTable Expr a -> Query (MaybeTable Expr b)
traverseMaybeTable :: (a -> Query b) -> MaybeTable Expr a -> Query (MaybeTable Expr b)
traverseMaybeTable a -> Query b
query ma :: MaybeTable Expr a
ma@(MaybeTable Expr (Maybe MaybeTag)
input Nullify Expr a
_) = do
Query b -> Query (MaybeTable Expr b)
forall a. Query a -> Query (MaybeTable Expr a)
optional (a -> Query b
query (a -> Query b) -> Query a -> Query b
forall (m :: Context) a b. Monad m => (a -> m b) -> m a -> m b
=<< MaybeTable Expr a -> Query a
forall a. MaybeTable Expr a -> Query a
catMaybeTable MaybeTable Expr a
ma) Query (MaybeTable Expr b)
-> (MaybeTable Expr b -> Query (MaybeTable Expr b))
-> Query (MaybeTable Expr b)
forall (m :: Context) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
MaybeTable Expr (Maybe MaybeTag)
output Nullify Expr b
b -> do
Expr Bool -> Query ()
where_ (Expr Bool -> Query ()) -> Expr Bool -> Query ()
forall a b. (a -> b) -> a -> b
$ Expr (Maybe MaybeTag)
output Expr (Maybe MaybeTag) -> Expr (Maybe MaybeTag) -> Expr Bool
forall a. Sql DBEq a => Expr a -> Expr a -> Expr Bool
==. Expr (Maybe MaybeTag)
input
MaybeTable Expr b -> Query (MaybeTable Expr b)
forall (f :: Context) a. Applicative f => a -> f a
pure (MaybeTable Expr b -> Query (MaybeTable Expr b))
-> MaybeTable Expr b -> Query (MaybeTable Expr b)
forall a b. (a -> b) -> a -> b
$ Expr (Maybe MaybeTag) -> Nullify Expr b -> MaybeTable Expr b
forall (context :: Context) a.
context (Maybe MaybeTag)
-> Nullify context a -> MaybeTable context a
MaybeTable Expr (Maybe MaybeTag)
input Nullify Expr b
b