These.hs

{-# 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 condition = zipOpaleyeWith $ \left right -> Opaleye.stateQueryArr $ \_ t -> case t of
  tag -> (tab, join', tag''')
    where
      (ma, left', tag') = Opaleye.runStateQueryArr (pure <$> left) () tag
      (mb, right', tag'') = Opaleye.runStateQueryArr (pure <$> right) () tag'
      MaybeTable hasHere a = ma
      MaybeTable hasThere b = mb
      (hasHere', lbindings) = Opaleye.run $ do
        traversePrimExpr (Opaleye.extractAttr "hasHere" tag'') hasHere
      (hasThere', rbindings) = Opaleye.run $ do
        traversePrimExpr (Opaleye.extractAttr "hasThere" tag'') hasThere
      tag''' = Opaleye.next tag''
      join = Opaleye.Join Opaleye.FullJoin on left'' right''
        where
          on = toPrimExpr $ condition (extract a) (extract b)
          left'' = (Opaleye.NonLateral, Opaleye.toPrimQuery (left' <> Opaleye.aRebind lbindings))
          right'' = (Opaleye.NonLateral, Opaleye.toPrimQuery (right' <> Opaleye.aRebind rbindings))
      ma' = MaybeTable hasHere' a
      mb' = MaybeTable hasThere' b
      tab = TheseTable {here = ma', there = mb'}
      join' = Opaleye.aProduct join


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


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


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


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


keepThisTable :: TheseTable Expr a b -> Query a
keepThisTable t@(TheseTable (MaybeTable _ a) _) = do
  where_ $ isThisTable t
  pure (extract a)


loseThisTable :: TheseTable Expr a b -> Query (MaybeTable Expr a, b)
loseThisTable t@(TheseTable ma (MaybeTable _ b)) = do
  where_ $ not_ $ isThisTable t
  pure (ma, extract b)


keepThatTable :: TheseTable Expr a b -> Query b
keepThatTable t@(TheseTable _ (MaybeTable _ b)) = do
  where_ $ isThatTable t
  pure (extract b)


loseThatTable :: TheseTable Expr a b -> Query (a, MaybeTable Expr b)
loseThatTable t@(TheseTable (MaybeTable _ a) mb) = do
  where_ $ not_ $ isThatTable t
  pure (extract a, mb)


keepThoseTable :: TheseTable Expr a b -> Query (a, b)
keepThoseTable t@(TheseTable (MaybeTable _ a) (MaybeTable _ b)) = do
  where_ $ isThoseTable t
  pure (extract a, extract b)


loseThoseTable :: TheseTable Expr a b -> Query (EitherTable Expr a b)
loseThoseTable t@(TheseTable (MaybeTable _ a) (MaybeTable _ b)) = do
  where_ $ not_ $ isThoseTable t
  pure $ EitherTable tag a b
  where
    tag = boolExpr (litExpr IsLeft) (litExpr IsRight) (isThatTable t)


bitraverseTheseTable :: ()
  => (a -> Query c)
  -> (b -> Query d)
  -> TheseTable Expr a b
  -> Query (TheseTable Expr c d)
bitraverseTheseTable f g t = do
  mc <- optional (f . fst =<< keepHereTable t)
  md <- optional (g . snd =<< keepThereTable t)
  where_ $ isJustTable mc ==. hasHereTable t
  where_ $ isJustTable md ==. hasThereTable t
  pure $ TheseTable mc md