{-# language FlexibleContexts #-}
{-# language GADTs #-}

module Rel8.Query.These
  ( alignBy
  , keepHereTable, loseHereTable
  , keepThereTable, loseThereTable
  , keepThisTable, loseThisTable
  , keepThatTable, loseThatTable
  , keepThoseTable, loseThoseTable
  , bitraverseTheseTable
  )
where

-- base
import Prelude

-- comonad
import Control.Comonad ( extract )

-- opaleye
import qualified Opaleye.Internal.PackMap as Opaleye
import qualified Opaleye.Internal.PrimQuery as Opaleye
import qualified Opaleye.Internal.QueryArr as Opaleye
import qualified Opaleye.Internal.Tag as Opaleye

-- rel8
import Rel8.Expr ( Expr )
import Rel8.Expr.Bool ( boolExpr, not_ )
import Rel8.Expr.Eq ( (==.) )
import Rel8.Expr.Opaleye ( toPrimExpr, traversePrimExpr )
import Rel8.Expr.Serialize ( litExpr )
import Rel8.Query ( Query )
import Rel8.Query.Filter ( where_ )
import Rel8.Query.Maybe ( optional )
import Rel8.Query.Opaleye ( zipOpaleyeWith )
import Rel8.Table.Either ( EitherTable( EitherTable ) )
import Rel8.Table.Maybe ( MaybeTable( MaybeTable ), isJustTable )
import Rel8.Table.These
  ( TheseTable( TheseTable, here, there )
  , hasHereTable, hasThereTable
  , isThisTable, isThatTable, isThoseTable
  )
import Rel8.Type.Tag ( EitherTag( IsLeft, IsRight ) )


-- | Corresponds to a @FULL OUTER JOIN@ between two queries.
alignBy :: ()
  => (a -> b -> Expr Bool)
  -> Query a -> Query b -> Query (TheseTable Expr a b)
alignBy :: (a -> b -> Expr Bool)
-> Query a -> Query b -> Query (TheseTable Expr a b)
alignBy a -> b -> Expr Bool
condition = (Select a -> Select b -> Select (TheseTable Expr a b))
-> Query a -> Query b -> Query (TheseTable Expr a b)
forall a b c.
(Select a -> Select b -> Select c) -> Query a -> Query b -> Query c
zipOpaleyeWith ((Select a -> Select b -> Select (TheseTable Expr a b))
 -> Query a -> Query b -> Query (TheseTable Expr a b))
-> (Select a -> Select b -> Select (TheseTable Expr a b))
-> Query a
-> Query b
-> Query (TheseTable Expr a b)
forall a b. (a -> b) -> a -> b
$ \Select a
left Select b
right -> (() -> Tag -> (TheseTable Expr a b, PrimQueryArr, Tag))
-> Select (TheseTable Expr a b)
forall a b. (a -> Tag -> (b, PrimQueryArr, Tag)) -> QueryArr a b
Opaleye.stateQueryArr ((() -> Tag -> (TheseTable Expr a b, PrimQueryArr, Tag))
 -> Select (TheseTable Expr a b))
-> (() -> Tag -> (TheseTable Expr a b, PrimQueryArr, Tag))
-> Select (TheseTable Expr a b)
forall a b. (a -> b) -> a -> b
$ \()
_ Tag
t -> case Tag
t of
  Tag
tag -> (TheseTable Expr a b
tab, PrimQueryArr
join', Tag
tag''')
    where
      (MaybeTable Expr a
ma, PrimQueryArr
left', Tag
tag') = QueryArr () (MaybeTable Expr a)
-> () -> Tag -> (MaybeTable Expr a, PrimQueryArr, Tag)
forall a b. QueryArr a b -> a -> Tag -> (b, PrimQueryArr, Tag)
Opaleye.runStateQueryArr (a -> MaybeTable Expr a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> MaybeTable Expr a)
-> Select a -> QueryArr () (MaybeTable Expr a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Select a
left) () Tag
tag
      (MaybeTable Expr b
mb, PrimQueryArr
right', Tag
tag'') = QueryArr () (MaybeTable Expr b)
-> () -> Tag -> (MaybeTable Expr b, PrimQueryArr, Tag)
forall a b. QueryArr a b -> a -> Tag -> (b, PrimQueryArr, Tag)
Opaleye.runStateQueryArr (b -> MaybeTable Expr b
forall (f :: * -> *) a. Applicative f => a -> f a
pure (b -> MaybeTable Expr b)
-> Select b -> QueryArr () (MaybeTable Expr b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Select b
right) () Tag
tag'
      MaybeTable Expr (Maybe MaybeTag)
hasHere Nullify Expr a
a = MaybeTable Expr a
ma
      MaybeTable Expr (Maybe MaybeTag)
hasThere Nullify Expr b
b = MaybeTable Expr b
mb
      (Expr (Maybe MaybeTag)
hasHere', [(Symbol, PrimExpr)]
lbindings) = PM [(Symbol, PrimExpr)] (Expr (Maybe MaybeTag))
-> (Expr (Maybe MaybeTag), [(Symbol, PrimExpr)])
forall a r. PM [a] r -> (r, [a])
Opaleye.run (PM [(Symbol, PrimExpr)] (Expr (Maybe MaybeTag))
 -> (Expr (Maybe MaybeTag), [(Symbol, PrimExpr)]))
-> PM [(Symbol, PrimExpr)] (Expr (Maybe MaybeTag))
-> (Expr (Maybe MaybeTag), [(Symbol, PrimExpr)])
forall a b. (a -> b) -> a -> b
$ do
        (PrimExpr -> StateT ([(Symbol, PrimExpr)], Int) Identity PrimExpr)
-> Expr (Maybe MaybeTag)
-> PM [(Symbol, PrimExpr)] (Expr (Maybe MaybeTag))
forall (f :: * -> *) a b.
Functor f =>
(PrimExpr -> f PrimExpr) -> Expr a -> f (Expr b)
traversePrimExpr (String
-> Tag
-> PrimExpr
-> StateT ([(Symbol, PrimExpr)], Int) Identity PrimExpr
forall primExpr.
String -> Tag -> primExpr -> PM [(Symbol, primExpr)] PrimExpr
Opaleye.extractAttr String
"hasHere" Tag
tag'') Expr (Maybe MaybeTag)
hasHere
      (Expr (Maybe MaybeTag)
hasThere', [(Symbol, PrimExpr)]
rbindings) = PM [(Symbol, PrimExpr)] (Expr (Maybe MaybeTag))
-> (Expr (Maybe MaybeTag), [(Symbol, PrimExpr)])
forall a r. PM [a] r -> (r, [a])
Opaleye.run (PM [(Symbol, PrimExpr)] (Expr (Maybe MaybeTag))
 -> (Expr (Maybe MaybeTag), [(Symbol, PrimExpr)]))
-> PM [(Symbol, PrimExpr)] (Expr (Maybe MaybeTag))
-> (Expr (Maybe MaybeTag), [(Symbol, PrimExpr)])
forall a b. (a -> b) -> a -> b
$ do
        (PrimExpr -> StateT ([(Symbol, PrimExpr)], Int) Identity PrimExpr)
-> Expr (Maybe MaybeTag)
-> PM [(Symbol, PrimExpr)] (Expr (Maybe MaybeTag))
forall (f :: * -> *) a b.
Functor f =>
(PrimExpr -> f PrimExpr) -> Expr a -> f (Expr b)
traversePrimExpr (String
-> Tag
-> PrimExpr
-> StateT ([(Symbol, PrimExpr)], Int) Identity PrimExpr
forall primExpr.
String -> Tag -> primExpr -> PM [(Symbol, primExpr)] PrimExpr
Opaleye.extractAttr String
"hasThere" Tag
tag'') Expr (Maybe MaybeTag)
hasThere
      tag''' :: Tag
tag''' = Tag -> Tag
Opaleye.next Tag
tag''
      join :: PrimQuery' ()
join = JoinType
-> PrimExpr
-> (Lateral, PrimQuery' ())
-> (Lateral, PrimQuery' ())
-> PrimQuery' ()
forall a.
JoinType
-> PrimExpr
-> (Lateral, PrimQuery' a)
-> (Lateral, PrimQuery' a)
-> PrimQuery' a
Opaleye.Join JoinType
Opaleye.FullJoin PrimExpr
on (Lateral, PrimQuery' ())
left'' (Lateral, PrimQuery' ())
right''
        where
          on :: PrimExpr
on = Expr Bool -> PrimExpr
forall a. Expr a -> PrimExpr
toPrimExpr (Expr Bool -> PrimExpr) -> Expr Bool -> PrimExpr
forall a b. (a -> b) -> a -> b
$ a -> b -> Expr Bool
condition (Nullify Expr a -> a
forall (w :: * -> *) a. Comonad w => w a -> a
extract Nullify Expr a
a) (Nullify Expr b -> b
forall (w :: * -> *) a. Comonad w => w a -> a
extract Nullify Expr b
b)
          left'' :: (Lateral, PrimQuery' ())
left'' = (Lateral
Opaleye.NonLateral, PrimQueryArr -> PrimQuery' ()
Opaleye.toPrimQuery (PrimQueryArr
left' PrimQueryArr -> PrimQueryArr -> PrimQueryArr
forall a. Semigroup a => a -> a -> a
<> [(Symbol, PrimExpr)] -> PrimQueryArr
Opaleye.aRebind [(Symbol, PrimExpr)]
lbindings))
          right'' :: (Lateral, PrimQuery' ())
right'' = (Lateral
Opaleye.NonLateral, PrimQueryArr -> PrimQuery' ()
Opaleye.toPrimQuery (PrimQueryArr
right' PrimQueryArr -> PrimQueryArr -> PrimQueryArr
forall a. Semigroup a => a -> a -> a
<> [(Symbol, PrimExpr)] -> PrimQueryArr
Opaleye.aRebind [(Symbol, PrimExpr)]
rbindings))
      ma' :: MaybeTable Expr a
ma' = Expr (Maybe MaybeTag) -> Nullify Expr a -> MaybeTable Expr a
forall (context :: * -> *) a.
context (Maybe MaybeTag)
-> Nullify context a -> MaybeTable context a
MaybeTable Expr (Maybe MaybeTag)
hasHere' Nullify Expr a
a
      mb' :: MaybeTable Expr b
mb' = Expr (Maybe MaybeTag) -> Nullify Expr b -> MaybeTable Expr b
forall (context :: * -> *) a.
context (Maybe MaybeTag)
-> Nullify context a -> MaybeTable context a
MaybeTable Expr (Maybe MaybeTag)
hasThere' Nullify Expr b
b
      tab :: TheseTable Expr a b
tab = TheseTable :: forall (context :: * -> *) a b.
MaybeTable context a
-> MaybeTable context b -> TheseTable context a b
TheseTable {here :: MaybeTable Expr a
here = MaybeTable Expr a
ma', there :: MaybeTable Expr b
there = MaybeTable Expr b
mb'}
      join' :: PrimQueryArr
join' = PrimQuery' () -> PrimQueryArr
Opaleye.aProduct PrimQuery' ()
join


keepHereTable :: TheseTable Expr a b -> Query (a, MaybeTable Expr b)
keepHereTable :: TheseTable Expr a b -> Query (a, MaybeTable Expr b)
keepHereTable = TheseTable Expr a b -> Query (a, MaybeTable Expr b)
forall a b. TheseTable Expr a b -> Query (a, MaybeTable Expr b)
loseThatTable


loseHereTable :: TheseTable Expr a b -> Query b
loseHereTable :: TheseTable Expr a b -> Query b
loseHereTable = TheseTable Expr a b -> Query b
forall a b. TheseTable Expr a b -> Query b
keepThatTable


keepThereTable :: TheseTable Expr a b -> Query (MaybeTable Expr a, b)
keepThereTable :: TheseTable Expr a b -> Query (MaybeTable Expr a, b)
keepThereTable = TheseTable Expr a b -> Query (MaybeTable Expr a, b)
forall a b. TheseTable Expr a b -> Query (MaybeTable Expr a, b)
loseThisTable


loseThereTable :: TheseTable Expr a b -> Query a
loseThereTable :: TheseTable Expr a b -> Query a
loseThereTable = TheseTable Expr a b -> Query a
forall a b. TheseTable Expr a b -> Query a
keepThisTable


keepThisTable :: TheseTable Expr a b -> Query a
keepThisTable :: TheseTable Expr a b -> Query a
keepThisTable t :: TheseTable Expr a b
t@(TheseTable (MaybeTable Expr (Maybe MaybeTag)
_ Nullify Expr a
a) MaybeTable Expr b
_) = do
  Expr Bool -> Query ()
where_ (Expr Bool -> Query ()) -> Expr Bool -> Query ()
forall a b. (a -> b) -> a -> b
$ TheseTable Expr a b -> Expr Bool
forall a b. TheseTable Expr a b -> Expr Bool
isThisTable TheseTable Expr a b
t
  a -> Query a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Nullify Expr a -> a
forall (w :: * -> *) a. Comonad w => w a -> a
extract Nullify Expr a
a)


loseThisTable :: TheseTable Expr a b -> Query (MaybeTable Expr a, b)
loseThisTable :: TheseTable Expr a b -> Query (MaybeTable Expr a, b)
loseThisTable t :: TheseTable Expr a b
t@(TheseTable MaybeTable Expr a
ma (MaybeTable Expr (Maybe MaybeTag)
_ Nullify Expr b
b)) = do
  Expr Bool -> Query ()
where_ (Expr Bool -> Query ()) -> Expr Bool -> Query ()
forall a b. (a -> b) -> a -> b
$ Expr Bool -> Expr Bool
not_ (Expr Bool -> Expr Bool) -> Expr Bool -> Expr Bool
forall a b. (a -> b) -> a -> b
$ TheseTable Expr a b -> Expr Bool
forall a b. TheseTable Expr a b -> Expr Bool
isThisTable TheseTable Expr a b
t
  (MaybeTable Expr a, b) -> Query (MaybeTable Expr a, b)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (MaybeTable Expr a
ma, Nullify Expr b -> b
forall (w :: * -> *) a. Comonad w => w a -> a
extract Nullify Expr b
b)


keepThatTable :: TheseTable Expr a b -> Query b
keepThatTable :: TheseTable Expr a b -> Query b
keepThatTable t :: TheseTable Expr a b
t@(TheseTable MaybeTable Expr a
_ (MaybeTable Expr (Maybe MaybeTag)
_ Nullify Expr b
b)) = do
  Expr Bool -> Query ()
where_ (Expr Bool -> Query ()) -> Expr Bool -> Query ()
forall a b. (a -> b) -> a -> b
$ TheseTable Expr a b -> Expr Bool
forall a b. TheseTable Expr a b -> Expr Bool
isThatTable TheseTable Expr a b
t
  b -> Query b
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Nullify Expr b -> b
forall (w :: * -> *) a. Comonad w => w a -> a
extract Nullify Expr b
b)


loseThatTable :: TheseTable Expr a b -> Query (a, MaybeTable Expr b)
loseThatTable :: TheseTable Expr a b -> Query (a, MaybeTable Expr b)
loseThatTable t :: TheseTable Expr a b
t@(TheseTable (MaybeTable Expr (Maybe MaybeTag)
_ Nullify Expr a
a) MaybeTable Expr b
mb) = do
  Expr Bool -> Query ()
where_ (Expr Bool -> Query ()) -> Expr Bool -> Query ()
forall a b. (a -> b) -> a -> b
$ Expr Bool -> Expr Bool
not_ (Expr Bool -> Expr Bool) -> Expr Bool -> Expr Bool
forall a b. (a -> b) -> a -> b
$ TheseTable Expr a b -> Expr Bool
forall a b. TheseTable Expr a b -> Expr Bool
isThatTable TheseTable Expr a b
t
  (a, MaybeTable Expr b) -> Query (a, MaybeTable Expr b)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Nullify Expr a -> a
forall (w :: * -> *) a. Comonad w => w a -> a
extract Nullify Expr a
a, MaybeTable Expr b
mb)


keepThoseTable :: TheseTable Expr a b -> Query (a, b)
keepThoseTable :: TheseTable Expr a b -> Query (a, b)
keepThoseTable t :: TheseTable Expr a b
t@(TheseTable (MaybeTable Expr (Maybe MaybeTag)
_ Nullify Expr a
a) (MaybeTable Expr (Maybe MaybeTag)
_ Nullify Expr b
b)) = do
  Expr Bool -> Query ()
where_ (Expr Bool -> Query ()) -> Expr Bool -> Query ()
forall a b. (a -> b) -> a -> b
$ TheseTable Expr a b -> Expr Bool
forall a b. TheseTable Expr a b -> Expr Bool
isThoseTable TheseTable Expr a b
t
  (a, b) -> Query (a, b)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Nullify Expr a -> a
forall (w :: * -> *) a. Comonad w => w a -> a
extract Nullify Expr a
a, Nullify Expr b -> b
forall (w :: * -> *) a. Comonad w => w a -> a
extract Nullify Expr b
b)


loseThoseTable :: TheseTable Expr a b -> Query (EitherTable Expr a b)
loseThoseTable :: TheseTable Expr a b -> Query (EitherTable Expr a b)
loseThoseTable t :: TheseTable Expr a b
t@(TheseTable (MaybeTable Expr (Maybe MaybeTag)
_ Nullify Expr a
a) (MaybeTable Expr (Maybe MaybeTag)
_ Nullify Expr b
b)) = do
  Expr Bool -> Query ()
where_ (Expr Bool -> Query ()) -> Expr Bool -> Query ()
forall a b. (a -> b) -> a -> b
$ Expr Bool -> Expr Bool
not_ (Expr Bool -> Expr Bool) -> Expr Bool -> Expr Bool
forall a b. (a -> b) -> a -> b
$ TheseTable Expr a b -> Expr Bool
forall a b. TheseTable Expr a b -> Expr Bool
isThoseTable TheseTable Expr a b
t
  EitherTable Expr a b -> Query (EitherTable Expr a b)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (EitherTable Expr a b -> Query (EitherTable Expr a b))
-> EitherTable Expr a b -> Query (EitherTable Expr a b)
forall a b. (a -> b) -> a -> b
$ Expr EitherTag
-> Nullify Expr a -> Nullify Expr b -> EitherTable Expr a b
forall (context :: * -> *) a b.
context EitherTag
-> Nullify context a
-> Nullify context b
-> EitherTable context a b
EitherTable Expr EitherTag
tag Nullify Expr a
a Nullify Expr b
b
  where
    tag :: Expr EitherTag
tag = Expr EitherTag -> Expr EitherTag -> Expr Bool -> Expr EitherTag
forall a. Expr a -> Expr a -> Expr Bool -> Expr a
boolExpr (EitherTag -> Expr EitherTag
forall a. Sql DBType a => a -> Expr a
litExpr EitherTag
IsLeft) (EitherTag -> Expr EitherTag
forall a. Sql DBType a => a -> Expr a
litExpr EitherTag
IsRight) (TheseTable Expr a b -> Expr Bool
forall a b. TheseTable Expr a b -> Expr Bool
isThatTable TheseTable Expr a b
t)


bitraverseTheseTable :: ()
  => (a -> Query c)
  -> (b -> Query d)
  -> TheseTable Expr a b
  -> Query (TheseTable Expr c d)
bitraverseTheseTable :: (a -> Query c)
-> (b -> Query d)
-> TheseTable Expr a b
-> Query (TheseTable Expr c d)
bitraverseTheseTable a -> Query c
f b -> Query d
g TheseTable Expr a b
t = do
  MaybeTable Expr c
mc <- Query c -> Query (MaybeTable Expr c)
forall a. Query a -> Query (MaybeTable Expr a)
optional (a -> Query c
f (a -> Query c)
-> ((a, MaybeTable Expr b) -> a)
-> (a, MaybeTable Expr b)
-> Query c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a, MaybeTable Expr b) -> a
forall a b. (a, b) -> a
fst ((a, MaybeTable Expr b) -> Query c)
-> Query (a, MaybeTable Expr b) -> Query c
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< TheseTable Expr a b -> Query (a, MaybeTable Expr b)
forall a b. TheseTable Expr a b -> Query (a, MaybeTable Expr b)
keepHereTable TheseTable Expr a b
t)
  MaybeTable Expr d
md <- Query d -> Query (MaybeTable Expr d)
forall a. Query a -> Query (MaybeTable Expr a)
optional (b -> Query d
g (b -> Query d)
-> ((MaybeTable Expr a, b) -> b)
-> (MaybeTable Expr a, b)
-> Query d
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (MaybeTable Expr a, b) -> b
forall a b. (a, b) -> b
snd ((MaybeTable Expr a, b) -> Query d)
-> Query (MaybeTable Expr a, b) -> Query d
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< TheseTable Expr a b -> Query (MaybeTable Expr a, b)
forall a b. TheseTable Expr a b -> Query (MaybeTable Expr a, b)
keepThereTable TheseTable Expr a b
t)
  Expr Bool -> Query ()
where_ (Expr Bool -> Query ()) -> Expr Bool -> Query ()
forall a b. (a -> b) -> a -> b
$ MaybeTable Expr c -> Expr Bool
forall a. MaybeTable Expr a -> Expr Bool
isJustTable MaybeTable Expr c
mc Expr Bool -> Expr Bool -> Expr Bool
forall a. Sql DBEq a => Expr a -> Expr a -> Expr Bool
==. TheseTable Expr a b -> Expr Bool
forall a b. TheseTable Expr a b -> Expr Bool
hasHereTable TheseTable Expr a b
t
  Expr Bool -> Query ()
where_ (Expr Bool -> Query ()) -> Expr Bool -> Query ()
forall a b. (a -> b) -> a -> b
$ MaybeTable Expr d -> Expr Bool
forall a. MaybeTable Expr a -> Expr Bool
isJustTable MaybeTable Expr d
md Expr Bool -> Expr Bool -> Expr Bool
forall a. Sql DBEq a => Expr a -> Expr a -> Expr Bool
==. TheseTable Expr a b -> Expr Bool
forall a b. TheseTable Expr a b -> Expr Bool
hasThereTable TheseTable Expr a b
t
  TheseTable Expr c d -> Query (TheseTable Expr c d)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TheseTable Expr c d -> Query (TheseTable Expr c d))
-> TheseTable Expr c d -> Query (TheseTable Expr c d)
forall a b. (a -> b) -> a -> b
$ MaybeTable Expr c -> MaybeTable Expr d -> TheseTable Expr c d
forall (context :: * -> *) a b.
MaybeTable context a
-> MaybeTable context b -> TheseTable context a b
TheseTable MaybeTable Expr c
mc MaybeTable Expr d
md