{-# language FlexibleContexts #-}
{-# language GADTs #-}
module Rel8.Query.These
( alignBy
, keepHereTable, loseHereTable
, keepThereTable, loseThereTable
, keepThisTable, loseThisTable
, keepThatTable, loseThatTable
, keepThoseTable, loseThoseTable
, bitraverseTheseTable
)
where
import Prelude
import Control.Comonad ( extract )
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
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 ) )
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, Lateral -> PrimQuery -> PrimQuery, Tag))
-> Select (TheseTable Expr a b)
forall a b.
((a, Tag) -> (b, Lateral -> PrimQuery -> PrimQuery, Tag))
-> SelectArr a b
Opaleye.QueryArr ((((), Tag)
-> (TheseTable Expr a b, Lateral -> PrimQuery -> PrimQuery, Tag))
-> Select (TheseTable Expr a b))
-> (((), Tag)
-> (TheseTable Expr a b, Lateral -> PrimQuery -> PrimQuery, Tag))
-> Select (TheseTable Expr a b)
forall a b. (a -> b) -> a -> b
$ \((), Tag)
i -> case ((), Tag)
i of
(()
_, Tag
tag) -> (TheseTable Expr a b
tab, Lateral -> PrimQuery -> PrimQuery
join', Tag
tag''')
where
(MaybeTable Expr a
ma, PrimQuery
left', Tag
tag') = QueryArr () (MaybeTable Expr a)
-> ((), Tag) -> (MaybeTable Expr a, PrimQuery, Tag)
forall a b. QueryArr a b -> (a, Tag) -> (b, PrimQuery, Tag)
Opaleye.runSimpleQueryArr (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, PrimQuery
right', Tag
tag'') = QueryArr () (MaybeTable Expr b)
-> ((), Tag) -> (MaybeTable Expr b, PrimQuery, Tag)
forall a b. QueryArr a b -> (a, Tag) -> (b, PrimQuery, Tag)
Opaleye.runSimpleQueryArr (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 :: Lateral -> PrimQuery
join Lateral
lateral = 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
lateral, Bool -> [(Symbol, PrimExpr)] -> PrimQuery -> PrimQuery
forall a.
Bool -> [(Symbol, PrimExpr)] -> PrimQuery' a -> PrimQuery' a
Opaleye.Rebind Bool
True [(Symbol, PrimExpr)]
lbindings PrimQuery
left')
right'' :: (Lateral, PrimQuery)
right'' = (Lateral
lateral, Bool -> [(Symbol, PrimExpr)] -> PrimQuery -> PrimQuery
forall a.
Bool -> [(Symbol, PrimExpr)] -> PrimQuery' a -> PrimQuery' a
Opaleye.Rebind Bool
True [(Symbol, PrimExpr)]
rbindings PrimQuery
right')
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' :: Lateral -> PrimQuery -> PrimQuery
join' Lateral
lateral PrimQuery
input = Lateral -> PrimQuery -> PrimQuery -> PrimQuery
Opaleye.times Lateral
lateral PrimQuery
input (Lateral -> PrimQuery
join Lateral
lateral)
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