-- | Alternative APIs to inner, left, right, and full outer joins.
-- See "Opaleye.Join" for details on the best way to do joins in
-- Opaleye.

{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE MultiParamTypeClasses #-}

module Opaleye.FunctionalJoin (
  joinF,
  leftJoinF,
  rightJoinF,
  fullJoinF,
  ) where

import           Control.Applicative             ((<$>), (<*>))
import           Control.Arrow                   ((<<<))

import qualified Data.Profunctor.Product.Default as D
import qualified Data.Profunctor.Product         as PP

import qualified Opaleye.Field                   as C
import qualified Opaleye.Field                   as F
import qualified Opaleye.Internal.Join           as IJ
import qualified Opaleye.Internal.Operators      as IO
import qualified Opaleye.Internal.Unpackspec     as IU
import qualified Opaleye.Join                    as J
import qualified Opaleye.Select                  as S
import qualified Opaleye.SqlTypes                as T
import qualified Opaleye.Operators               as O

joinF :: (fieldsL -> fieldsR -> fieldsResult)
      -- ^ Calculate result fields from input fields
      -> (fieldsL -> fieldsR -> F.Field T.SqlBool)
      -- ^ Condition on which to join
      -> S.Select fieldsL
      -- ^ Left query
      -> S.Select fieldsR
      -- ^ Right query
      -> S.Select fieldsResult
joinF :: (fieldsL -> fieldsR -> fieldsResult)
-> (fieldsL -> fieldsR -> Field SqlBool)
-> Select fieldsL
-> Select fieldsR
-> Select fieldsResult
joinF fieldsL -> fieldsR -> fieldsResult
f fieldsL -> fieldsR -> Field SqlBool
cond Select fieldsL
l Select fieldsR
r =
  ((fieldsL, fieldsR) -> fieldsResult)
-> SelectArr () (fieldsL, fieldsR) -> Select fieldsResult
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((fieldsL -> fieldsR -> fieldsResult)
-> (fieldsL, fieldsR) -> fieldsResult
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry fieldsL -> fieldsR -> fieldsResult
f) (((fieldsL, fieldsR) -> Field SqlBool)
-> SelectArr (fieldsL, fieldsR) (fieldsL, fieldsR)
forall a. (a -> Field SqlBool) -> SelectArr a a
O.keepWhen ((fieldsL -> fieldsR -> Column SqlBool)
-> (fieldsL, fieldsR) -> Column SqlBool
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry fieldsL -> fieldsR -> Column SqlBool
fieldsL -> fieldsR -> Field SqlBool
cond) SelectArr (fieldsL, fieldsR) (fieldsL, fieldsR)
-> SelectArr () (fieldsL, fieldsR)
-> SelectArr () (fieldsL, fieldsR)
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
<<< ((,) (fieldsL -> fieldsR -> (fieldsL, fieldsR))
-> Select fieldsL -> SelectArr () (fieldsR -> (fieldsL, fieldsR))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Select fieldsL
l SelectArr () (fieldsR -> (fieldsL, fieldsR))
-> Select fieldsR -> SelectArr () (fieldsL, fieldsR)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Select fieldsR
r))

leftJoinF :: (D.Default IO.IfPP fieldsResult fieldsResult,
              D.Default IU.Unpackspec fieldsL fieldsL,
              D.Default IU.Unpackspec fieldsR fieldsR)
          => (fieldsL -> fieldsR -> fieldsResult)
          -- ^ Calculate result row from input rows for rows in the
          -- right query satisfying the join condition
          -> (fieldsL -> fieldsResult)
          -- ^ Calculate result row from input row when there are /no/
          -- rows in the right query satisfying the join condition
          -> (fieldsL -> fieldsR -> F.Field T.SqlBool)
          -- ^ Condition on which to join
          -> S.Select fieldsL
          -- ^ Left query
          -> S.Select fieldsR
          -- ^ Right query
          -> S.Select fieldsResult
leftJoinF :: (fieldsL -> fieldsR -> fieldsResult)
-> (fieldsL -> fieldsResult)
-> (fieldsL -> fieldsR -> Field SqlBool)
-> Select fieldsL
-> Select fieldsR
-> Select fieldsResult
leftJoinF fieldsL -> fieldsR -> fieldsResult
f fieldsL -> fieldsResult
fL fieldsL -> fieldsR -> Field SqlBool
cond Select fieldsL
l Select fieldsR
r = ((fieldsL, (fieldsR, Column (Nullable SqlBool))) -> fieldsResult)
-> SelectArr () (fieldsL, (fieldsR, Column (Nullable SqlBool)))
-> Select fieldsResult
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (fieldsL, (fieldsR, Column (Nullable SqlBool))) -> fieldsResult
forall a. (fieldsL, (fieldsR, Column (Nullable a))) -> fieldsResult
ret SelectArr () (fieldsL, (fieldsR, Column (Nullable SqlBool)))
j
  where a1 :: SelectArr () a -> SelectArr () (a, Column SqlBool)
a1 = (a -> (a, Column SqlBool))
-> SelectArr () a -> SelectArr () (a, Column SqlBool)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\a
x -> (a
x, Bool -> Field SqlBool
T.sqlBool Bool
True))
        j :: SelectArr () (fieldsL, (fieldsR, Column (Nullable SqlBool)))
j  = Unpackspec fieldsL fieldsL
-> Unpackspec (fieldsR, Column SqlBool) (fieldsR, Column SqlBool)
-> NullMaker
     (fieldsR, Column SqlBool) (fieldsR, Column (Nullable SqlBool))
-> Select fieldsL
-> Select (fieldsR, Column SqlBool)
-> ((fieldsL, (fieldsR, Column SqlBool)) -> Field SqlBool)
-> SelectArr () (fieldsL, (fieldsR, Column (Nullable SqlBool)))
forall fieldsL fieldsR nullableFieldsR.
Unpackspec fieldsL fieldsL
-> Unpackspec fieldsR fieldsR
-> NullMaker fieldsR nullableFieldsR
-> Select fieldsL
-> Select fieldsR
-> ((fieldsL, fieldsR) -> Field SqlBool)
-> Select (fieldsL, nullableFieldsR)
J.leftJoinExplicit Unpackspec fieldsL fieldsL
forall (p :: * -> * -> *) a b. Default p a b => p a b
D.def
                                Unpackspec (fieldsR, Column SqlBool) (fieldsR, Column SqlBool)
forall (p :: * -> * -> *) a b. Default p a b => p a b
D.def
                                ((NullMaker fieldsR fieldsR,
 NullMaker (Column SqlBool) (Column (Nullable SqlBool)))
-> NullMaker
     (fieldsR, Column SqlBool) (fieldsR, Column (Nullable SqlBool))
forall (p :: * -> * -> *) a0 a1 b0 b1.
ProductProfunctor p =>
(p a0 b0, p a1 b1) -> p (a0, a1) (b0, b1)
PP.p2 ((fieldsR -> fieldsR) -> NullMaker fieldsR fieldsR
forall a b. (a -> b) -> NullMaker a b
IJ.NullMaker fieldsR -> fieldsR
forall a. a -> a
id, NullMaker (Column SqlBool) (Column (Nullable SqlBool))
NullMaker (Field SqlBool) (FieldNullable SqlBool)
nullmakerBool))
                                Select fieldsL
l
                                (Select fieldsR -> Select (fieldsR, Column SqlBool)
forall a. SelectArr () a -> SelectArr () (a, Column SqlBool)
a1 Select fieldsR
r)
                                (\(fieldsL
l', (fieldsR
r', Column SqlBool
_)) -> fieldsL -> fieldsR -> Field SqlBool
cond fieldsL
l' fieldsR
r')

        ret :: (fieldsL, (fieldsR, Column (Nullable a))) -> fieldsResult
ret (fieldsL
lr, (fieldsR
rr, Column (Nullable a)
rc)) = Field SqlBool -> fieldsResult -> fieldsResult -> fieldsResult
forall fields.
Default IfPP fields fields =>
Field SqlBool -> fields -> fields -> fields
O.ifThenElseMany (FieldNullable a -> Field SqlBool
forall a. FieldNullable a -> Field SqlBool
C.isNull Column (Nullable a)
FieldNullable a
rc) (fieldsL -> fieldsResult
fL fieldsL
lr) (fieldsL -> fieldsR -> fieldsResult
f fieldsL
lr fieldsR
rr)

        nullmakerBool :: IJ.NullMaker (F.Field T.SqlBool)
                                      (F.FieldNullable T.SqlBool)
        nullmakerBool :: NullMaker (Field SqlBool) (FieldNullable SqlBool)
nullmakerBool = NullMaker (Field SqlBool) (FieldNullable SqlBool)
forall (p :: * -> * -> *) a b. Default p a b => p a b
D.def

rightJoinF :: (D.Default IO.IfPP fieldsResult fieldsResult,
               D.Default IU.Unpackspec fieldsL fieldsL,
               D.Default IU.Unpackspec fieldsR fieldsR)
           => (fieldsL -> fieldsR -> fieldsResult)
           -- ^ Calculate result row from input rows for rows in the
           -- left query satisfying the join condition
           -> (fieldsR -> fieldsResult)
           -- ^ Calculate result row from input row when there are /no/
           -- rows in the left query satisfying the join condition
           -> (fieldsL -> fieldsR -> F.Field T.SqlBool)
           -- ^ Condition on which to join
           -> S.Select fieldsL
           -- ^ Left query
           -> S.Select fieldsR
           -- ^ Right query
           -> S.Select fieldsResult
rightJoinF :: (fieldsL -> fieldsR -> fieldsResult)
-> (fieldsR -> fieldsResult)
-> (fieldsL -> fieldsR -> Field SqlBool)
-> Select fieldsL
-> Select fieldsR
-> Select fieldsResult
rightJoinF fieldsL -> fieldsR -> fieldsResult
f fieldsR -> fieldsResult
fR fieldsL -> fieldsR -> Field SqlBool
cond Select fieldsL
l Select fieldsR
r = (((fieldsL, Column (Nullable SqlBool)), fieldsR) -> fieldsResult)
-> SelectArr () ((fieldsL, Column (Nullable SqlBool)), fieldsR)
-> Select fieldsResult
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((fieldsL, Column (Nullable SqlBool)), fieldsR) -> fieldsResult
forall a. ((fieldsL, Column (Nullable a)), fieldsR) -> fieldsResult
ret SelectArr () ((fieldsL, Column (Nullable SqlBool)), fieldsR)
j
  where a1 :: SelectArr () a -> SelectArr () (a, Column SqlBool)
a1 = (a -> (a, Column SqlBool))
-> SelectArr () a -> SelectArr () (a, Column SqlBool)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\a
x -> (a
x, Bool -> Field SqlBool
T.sqlBool Bool
True))
        j :: SelectArr () ((fieldsL, Column (Nullable SqlBool)), fieldsR)
j  = Unpackspec (fieldsL, Column SqlBool) (fieldsL, Column SqlBool)
-> Unpackspec fieldsR fieldsR
-> NullMaker
     (fieldsL, Column SqlBool) (fieldsL, Column (Nullable SqlBool))
-> Select (fieldsL, Column SqlBool)
-> Select fieldsR
-> (((fieldsL, Column SqlBool), fieldsR) -> Field SqlBool)
-> SelectArr () ((fieldsL, Column (Nullable SqlBool)), fieldsR)
forall fieldsL fieldsR nullableFieldsL.
Unpackspec fieldsL fieldsL
-> Unpackspec fieldsR fieldsR
-> NullMaker fieldsL nullableFieldsL
-> Select fieldsL
-> Select fieldsR
-> ((fieldsL, fieldsR) -> Field SqlBool)
-> Select (nullableFieldsL, fieldsR)
J.rightJoinExplicit Unpackspec (fieldsL, Column SqlBool) (fieldsL, Column SqlBool)
forall (p :: * -> * -> *) a b. Default p a b => p a b
D.def
                                 Unpackspec fieldsR fieldsR
forall (p :: * -> * -> *) a b. Default p a b => p a b
D.def
                                 ((NullMaker fieldsL fieldsL,
 NullMaker (Column SqlBool) (Column (Nullable SqlBool)))
-> NullMaker
     (fieldsL, Column SqlBool) (fieldsL, Column (Nullable SqlBool))
forall (p :: * -> * -> *) a0 a1 b0 b1.
ProductProfunctor p =>
(p a0 b0, p a1 b1) -> p (a0, a1) (b0, b1)
PP.p2 ((fieldsL -> fieldsL) -> NullMaker fieldsL fieldsL
forall a b. (a -> b) -> NullMaker a b
IJ.NullMaker fieldsL -> fieldsL
forall a. a -> a
id, NullMaker (Column SqlBool) (Column (Nullable SqlBool))
NullMaker (Field SqlBool) (FieldNullable SqlBool)
nullmakerBool))
                                 (Select fieldsL -> Select (fieldsL, Column SqlBool)
forall a. SelectArr () a -> SelectArr () (a, Column SqlBool)
a1 Select fieldsL
l)
                                 Select fieldsR
r
                                 (\((fieldsL
l', Column SqlBool
_), fieldsR
r') -> fieldsL -> fieldsR -> Field SqlBool
cond fieldsL
l' fieldsR
r')

        ret :: ((fieldsL, Column (Nullable a)), fieldsR) -> fieldsResult
ret ((fieldsL
lr, Column (Nullable a)
lc), fieldsR
rr) = Field SqlBool -> fieldsResult -> fieldsResult -> fieldsResult
forall fields.
Default IfPP fields fields =>
Field SqlBool -> fields -> fields -> fields
O.ifThenElseMany (FieldNullable a -> Field SqlBool
forall a. FieldNullable a -> Field SqlBool
C.isNull Column (Nullable a)
FieldNullable a
lc) (fieldsR -> fieldsResult
fR fieldsR
rr) (fieldsL -> fieldsR -> fieldsResult
f fieldsL
lr fieldsR
rr)

        nullmakerBool :: IJ.NullMaker (F.Field T.SqlBool)
                                      (F.FieldNullable T.SqlBool)
        nullmakerBool :: NullMaker (Field SqlBool) (FieldNullable SqlBool)
nullmakerBool = NullMaker (Field SqlBool) (FieldNullable SqlBool)
forall (p :: * -> * -> *) a b. Default p a b => p a b
D.def

fullJoinF :: (D.Default IO.IfPP fieldsResult fieldsResult,
              D.Default IU.Unpackspec fieldsL fieldsL,
              D.Default IU.Unpackspec fieldsR fieldsR)
          => (fieldsL -> fieldsR -> fieldsResult)
           -- ^ Calculate result row from input rows for rows in the
           -- left and right query satisfying the join condition
          -> (fieldsL -> fieldsResult)
           -- ^ Calculate result row from left input row when there
           -- are /no/ rows in the right query satisfying the join
           -- condition
          -> (fieldsR -> fieldsResult)
           -- ^ Calculate result row from right input row when there
           -- are /no/ rows in the left query satisfying the join
           -- condition
          -> (fieldsL -> fieldsR -> F.Field T.SqlBool)
          -- ^ Condition on which to join
          -> S.Select fieldsL
          -- ^ Left query
          -> S.Select fieldsR
          -- ^ Right query
          -> S.Select fieldsResult
fullJoinF :: (fieldsL -> fieldsR -> fieldsResult)
-> (fieldsL -> fieldsResult)
-> (fieldsR -> fieldsResult)
-> (fieldsL -> fieldsR -> Field SqlBool)
-> Select fieldsL
-> Select fieldsR
-> Select fieldsResult
fullJoinF fieldsL -> fieldsR -> fieldsResult
f fieldsL -> fieldsResult
fL fieldsR -> fieldsResult
fR fieldsL -> fieldsR -> Field SqlBool
cond Select fieldsL
l Select fieldsR
r = (((fieldsL, Column (Nullable SqlBool)),
  (fieldsR, Column (Nullable SqlBool)))
 -> fieldsResult)
-> SelectArr
     ()
     ((fieldsL, Column (Nullable SqlBool)),
      (fieldsR, Column (Nullable SqlBool)))
-> Select fieldsResult
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((fieldsL, Column (Nullable SqlBool)),
 (fieldsR, Column (Nullable SqlBool)))
-> fieldsResult
forall a a.
((fieldsL, Column (Nullable a)), (fieldsR, Column (Nullable a)))
-> fieldsResult
ret SelectArr
  ()
  ((fieldsL, Column (Nullable SqlBool)),
   (fieldsR, Column (Nullable SqlBool)))
j
  where a1 :: SelectArr () a -> SelectArr () (a, Column SqlBool)
a1 = (a -> (a, Column SqlBool))
-> SelectArr () a -> SelectArr () (a, Column SqlBool)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\a
x -> (a
x, Bool -> Field SqlBool
T.sqlBool Bool
True))
        j :: SelectArr
  ()
  ((fieldsL, Column (Nullable SqlBool)),
   (fieldsR, Column (Nullable SqlBool)))
j  = Unpackspec (fieldsL, Column SqlBool) (fieldsL, Column SqlBool)
-> Unpackspec (fieldsR, Column SqlBool) (fieldsR, Column SqlBool)
-> NullMaker
     (fieldsL, Column SqlBool) (fieldsL, Column (Nullable SqlBool))
-> NullMaker
     (fieldsR, Column SqlBool) (fieldsR, Column (Nullable SqlBool))
-> Select (fieldsL, Column SqlBool)
-> Select (fieldsR, Column SqlBool)
-> (((fieldsL, Column SqlBool), (fieldsR, Column SqlBool))
    -> Field SqlBool)
-> SelectArr
     ()
     ((fieldsL, Column (Nullable SqlBool)),
      (fieldsR, Column (Nullable SqlBool)))
forall fieldsL fieldsR nullableFieldsL nullableFieldsR.
Unpackspec fieldsL fieldsL
-> Unpackspec fieldsR fieldsR
-> NullMaker fieldsL nullableFieldsL
-> NullMaker fieldsR nullableFieldsR
-> Select fieldsL
-> Select fieldsR
-> ((fieldsL, fieldsR) -> Field SqlBool)
-> Select (nullableFieldsL, nullableFieldsR)
J.fullJoinExplicit Unpackspec (fieldsL, Column SqlBool) (fieldsL, Column SqlBool)
forall (p :: * -> * -> *) a b. Default p a b => p a b
D.def
                                Unpackspec (fieldsR, Column SqlBool) (fieldsR, Column SqlBool)
forall (p :: * -> * -> *) a b. Default p a b => p a b
D.def
                                ((NullMaker fieldsL fieldsL,
 NullMaker (Column SqlBool) (Column (Nullable SqlBool)))
-> NullMaker
     (fieldsL, Column SqlBool) (fieldsL, Column (Nullable SqlBool))
forall (p :: * -> * -> *) a0 a1 b0 b1.
ProductProfunctor p =>
(p a0 b0, p a1 b1) -> p (a0, a1) (b0, b1)
PP.p2 ((fieldsL -> fieldsL) -> NullMaker fieldsL fieldsL
forall a b. (a -> b) -> NullMaker a b
IJ.NullMaker fieldsL -> fieldsL
forall a. a -> a
id, NullMaker (Column SqlBool) (Column (Nullable SqlBool))
NullMaker (Field SqlBool) (FieldNullable SqlBool)
nullmakerBool))
                                ((NullMaker fieldsR fieldsR,
 NullMaker (Column SqlBool) (Column (Nullable SqlBool)))
-> NullMaker
     (fieldsR, Column SqlBool) (fieldsR, Column (Nullable SqlBool))
forall (p :: * -> * -> *) a0 a1 b0 b1.
ProductProfunctor p =>
(p a0 b0, p a1 b1) -> p (a0, a1) (b0, b1)
PP.p2 ((fieldsR -> fieldsR) -> NullMaker fieldsR fieldsR
forall a b. (a -> b) -> NullMaker a b
IJ.NullMaker fieldsR -> fieldsR
forall a. a -> a
id, NullMaker (Column SqlBool) (Column (Nullable SqlBool))
NullMaker (Field SqlBool) (FieldNullable SqlBool)
nullmakerBool))
                                (Select fieldsL -> Select (fieldsL, Column SqlBool)
forall a. SelectArr () a -> SelectArr () (a, Column SqlBool)
a1 Select fieldsL
l)
                                (Select fieldsR -> Select (fieldsR, Column SqlBool)
forall a. SelectArr () a -> SelectArr () (a, Column SqlBool)
a1 Select fieldsR
r)
                                (\((fieldsL
l', Column SqlBool
_), (fieldsR
r', Column SqlBool
_)) -> fieldsL -> fieldsR -> Field SqlBool
cond fieldsL
l' fieldsR
r')

        ret :: ((fieldsL, Column (Nullable a)), (fieldsR, Column (Nullable a)))
-> fieldsResult
ret ((fieldsL
lr, Column (Nullable a)
lc), (fieldsR
rr, Column (Nullable a)
rc)) = Field SqlBool -> fieldsResult -> fieldsResult -> fieldsResult
forall fields.
Default IfPP fields fields =>
Field SqlBool -> fields -> fields -> fields
O.ifThenElseMany (FieldNullable a -> Field SqlBool
forall a. FieldNullable a -> Field SqlBool
C.isNull Column (Nullable a)
FieldNullable a
lc)
                                     (fieldsR -> fieldsResult
fR fieldsR
rr)
                                     (Field SqlBool -> fieldsResult -> fieldsResult -> fieldsResult
forall fields.
Default IfPP fields fields =>
Field SqlBool -> fields -> fields -> fields
O.ifThenElseMany (FieldNullable a -> Field SqlBool
forall a. FieldNullable a -> Field SqlBool
C.isNull Column (Nullable a)
FieldNullable a
rc)
                                        (fieldsL -> fieldsResult
fL fieldsL
lr)
                                        (fieldsL -> fieldsR -> fieldsResult
f fieldsL
lr fieldsR
rr))

        nullmakerBool :: IJ.NullMaker (F.Field T.SqlBool)
                                      (F.FieldNullable T.SqlBool)
        nullmakerBool :: NullMaker (Field SqlBool) (FieldNullable SqlBool)
nullmakerBool = NullMaker (Field SqlBool) (FieldNullable SqlBool)
forall (p :: * -> * -> *) a b. Default p a b => p a b
D.def