{-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE Arrows #-}

module Opaleye.Internal.Join where

import qualified Opaleye.Internal.HaskellDB.PrimQuery as HPQ
import qualified Opaleye.Internal.PackMap             as PM
import qualified Opaleye.Internal.Tag                 as T
import qualified Opaleye.Internal.Unpackspec          as U
import           Opaleye.Internal.Column (Column(Column), Nullable)
import qualified Opaleye.Internal.QueryArr as Q
import qualified Opaleye.Internal.Operators as Op
import qualified Opaleye.Internal.PrimQuery as PQ
import qualified Opaleye.Internal.PGTypesExternal as T
import qualified Opaleye.SqlTypes as T
import qualified Opaleye.Column as C
import           Opaleye.Field   (Field)
import qualified Opaleye.Internal.Map as Map
import           Opaleye.Internal.MaybeFields (MaybeFields(MaybeFields),
                                               mfPresent, mfFields)
import qualified Opaleye.Select  as S
import qualified Opaleye.Internal.TypeFamilies as TF

import qualified Control.Applicative as A
import qualified Control.Arrow

import           Data.Profunctor (Profunctor, dimap)
import qualified Data.Profunctor.Product as PP
import qualified Data.Profunctor.Product.Default as D

newtype NullMaker a b = NullMaker (a -> b)

toNullable :: NullMaker a b -> a -> b
toNullable :: NullMaker a b -> a -> b
toNullable (NullMaker a -> b
f) = a -> b
f

instance D.Default NullMaker (Column a) (Column (Nullable a)) where
  def :: NullMaker (Column a) (Column (Nullable a))
def = (Column a -> Column (Nullable a))
-> NullMaker (Column a) (Column (Nullable a))
forall a b. (a -> b) -> NullMaker a b
NullMaker Column a -> Column (Nullable a)
forall a. Column a -> Column (Nullable a)
C.toNullable

instance D.Default NullMaker (Column (Nullable a)) (Column (Nullable a)) where
  def :: NullMaker (Column (Nullable a)) (Column (Nullable a))
def = (Column (Nullable a) -> Column (Nullable a))
-> NullMaker (Column (Nullable a)) (Column (Nullable a))
forall a b. (a -> b) -> NullMaker a b
NullMaker Column (Nullable a) -> Column (Nullable a)
forall a. a -> a
id

joinExplicit :: U.Unpackspec columnsA columnsA
             -> U.Unpackspec columnsB columnsB
             -> (columnsA -> returnedColumnsA)
             -> (columnsB -> returnedColumnsB)
             -> PQ.JoinType
             -> Q.Query columnsA -> Q.Query columnsB
             -> ((columnsA, columnsB) -> Column T.PGBool)
             -> Q.Query (returnedColumnsA, returnedColumnsB)
joinExplicit :: Unpackspec columnsA columnsA
-> Unpackspec columnsB columnsB
-> (columnsA -> returnedColumnsA)
-> (columnsB -> returnedColumnsB)
-> JoinType
-> Query columnsA
-> Query columnsB
-> ((columnsA, columnsB) -> Column PGBool)
-> Query (returnedColumnsA, returnedColumnsB)
joinExplicit Unpackspec columnsA columnsA
uA Unpackspec columnsB columnsB
uB columnsA -> returnedColumnsA
returnColumnsA columnsB -> returnedColumnsB
returnColumnsB JoinType
joinType
             Query columnsA
qA Query columnsB
qB (columnsA, columnsB) -> Column PGBool
cond = (((), Tag)
 -> ((returnedColumnsA, returnedColumnsB), PrimQuery, Tag))
-> Query (returnedColumnsA, returnedColumnsB)
forall a b. ((a, Tag) -> (b, PrimQuery, Tag)) -> QueryArr a b
Q.productQueryArr ((), Tag) -> ((returnedColumnsA, returnedColumnsB), PrimQuery, Tag)
q where
  q :: ((), Tag) -> ((returnedColumnsA, returnedColumnsB), PrimQuery, Tag)
q ((), Tag
startTag) = ((returnedColumnsA
nullableColumnsA, returnedColumnsB
nullableColumnsB), PrimQuery
primQueryR, Tag -> Tag
T.next Tag
endTag)
    where (columnsA
columnsA, PrimQuery
primQueryA, Tag
midTag) = Query columnsA -> ((), Tag) -> (columnsA, PrimQuery, Tag)
forall a b. QueryArr a b -> (a, Tag) -> (b, PrimQuery, Tag)
Q.runSimpleQueryArr Query columnsA
qA ((), Tag
startTag)
          (columnsB
columnsB, PrimQuery
primQueryB, Tag
endTag) = Query columnsB -> ((), Tag) -> (columnsB, PrimQuery, Tag)
forall a b. QueryArr a b -> (a, Tag) -> (b, PrimQuery, Tag)
Q.runSimpleQueryArr Query columnsB
qB ((), Tag
midTag)

          (columnsA
newColumnsA, [(Symbol, PrimExpr)]
ljPEsA) =
            PM [(Symbol, PrimExpr)] columnsA
-> (columnsA, [(Symbol, PrimExpr)])
forall a r. PM [a] r -> (r, [a])
PM.run (Unpackspec columnsA columnsA
-> (PrimExpr
    -> StateT ([(Symbol, PrimExpr)], Int) Identity PrimExpr)
-> columnsA
-> PM [(Symbol, PrimExpr)] columnsA
forall (f :: * -> *) columns b.
Applicative f =>
Unpackspec columns b -> (PrimExpr -> f PrimExpr) -> columns -> f b
U.runUnpackspec Unpackspec columnsA columnsA
uA (Int
-> Tag
-> PrimExpr
-> StateT ([(Symbol, PrimExpr)], Int) Identity PrimExpr
extractLeftJoinFields Int
1 Tag
endTag) columnsA
columnsA)
          (columnsB
newColumnsB, [(Symbol, PrimExpr)]
ljPEsB) =
            PM [(Symbol, PrimExpr)] columnsB
-> (columnsB, [(Symbol, PrimExpr)])
forall a r. PM [a] r -> (r, [a])
PM.run (Unpackspec columnsB columnsB
-> (PrimExpr
    -> StateT ([(Symbol, PrimExpr)], Int) Identity PrimExpr)
-> columnsB
-> PM [(Symbol, PrimExpr)] columnsB
forall (f :: * -> *) columns b.
Applicative f =>
Unpackspec columns b -> (PrimExpr -> f PrimExpr) -> columns -> f b
U.runUnpackspec Unpackspec columnsB columnsB
uB (Int
-> Tag
-> PrimExpr
-> StateT ([(Symbol, PrimExpr)], Int) Identity PrimExpr
extractLeftJoinFields Int
2 Tag
endTag) columnsB
columnsB)

          nullableColumnsA :: returnedColumnsA
nullableColumnsA = columnsA -> returnedColumnsA
returnColumnsA columnsA
newColumnsA
          nullableColumnsB :: returnedColumnsB
nullableColumnsB = columnsB -> returnedColumnsB
returnColumnsB columnsB
newColumnsB

          Column PrimExpr
cond' = (columnsA, columnsB) -> Column PGBool
cond (columnsA
columnsA, columnsB
columnsB)
          primQueryR :: PrimQuery
primQueryR = JoinType
-> PrimExpr
-> (Lateral, PrimQuery)
-> (Lateral, PrimQuery)
-> PrimQuery
forall a.
JoinType
-> PrimExpr
-> (Lateral, PrimQuery' a)
-> (Lateral, PrimQuery' a)
-> PrimQuery' a
PQ.Join JoinType
joinType PrimExpr
cond'
                               (Lateral
PQ.NonLateral, (Bool -> [(Symbol, PrimExpr)] -> PrimQuery -> PrimQuery
forall a.
Bool -> [(Symbol, PrimExpr)] -> PrimQuery' a -> PrimQuery' a
PQ.Rebind Bool
True [(Symbol, PrimExpr)]
ljPEsA PrimQuery
primQueryA))
                               (Lateral
PQ.NonLateral, (Bool -> [(Symbol, PrimExpr)] -> PrimQuery -> PrimQuery
forall a.
Bool -> [(Symbol, PrimExpr)] -> PrimQuery' a -> PrimQuery' a
PQ.Rebind Bool
True [(Symbol, PrimExpr)]
ljPEsB PrimQuery
primQueryB))

leftJoinAExplicit :: U.Unpackspec a a
                  -> NullMaker a nullableA
                  -> Q.Query a
                  -> Q.QueryArr (a -> Column T.PGBool) nullableA
leftJoinAExplicit :: Unpackspec a a
-> NullMaker a nullableA
-> Query a
-> QueryArr (a -> Column PGBool) nullableA
leftJoinAExplicit Unpackspec a a
uA NullMaker a nullableA
nullmaker Query a
rq =
  ((a -> Column PGBool, Tag)
 -> (nullableA, Lateral -> PrimQuery -> PrimQuery, Tag))
-> QueryArr (a -> Column PGBool) nullableA
forall a b.
((a, Tag) -> (b, Lateral -> PrimQuery -> PrimQuery, Tag))
-> SelectArr a b
Q.QueryArr (((a -> Column PGBool, Tag)
  -> (nullableA, Lateral -> PrimQuery -> PrimQuery, Tag))
 -> QueryArr (a -> Column PGBool) nullableA)
-> ((a -> Column PGBool, Tag)
    -> (nullableA, Lateral -> PrimQuery -> PrimQuery, Tag))
-> QueryArr (a -> Column PGBool) nullableA
forall a b. (a -> b) -> a -> b
$ \(a -> Column PGBool
p, Tag
t1) ->
    let (a
columnsR, PrimQuery
primQueryR, Tag
t2) = Query a -> ((), Tag) -> (a, PrimQuery, Tag)
forall a b. QueryArr a b -> (a, Tag) -> (b, PrimQuery, Tag)
Q.runSimpleQueryArr Query a
rq ((), Tag
t1)
        (a
newColumnsR, [(Symbol, PrimExpr)]
ljPEsR) = PM [(Symbol, PrimExpr)] a -> (a, [(Symbol, PrimExpr)])
forall a r. PM [a] r -> (r, [a])
PM.run (PM [(Symbol, PrimExpr)] a -> (a, [(Symbol, PrimExpr)]))
-> PM [(Symbol, PrimExpr)] a -> (a, [(Symbol, PrimExpr)])
forall a b. (a -> b) -> a -> b
$ Unpackspec a a
-> (PrimExpr
    -> StateT ([(Symbol, PrimExpr)], Int) Identity PrimExpr)
-> a
-> PM [(Symbol, PrimExpr)] a
forall (f :: * -> *) columns b.
Applicative f =>
Unpackspec columns b -> (PrimExpr -> f PrimExpr) -> columns -> f b
U.runUnpackspec Unpackspec a a
uA (Int
-> Tag
-> PrimExpr
-> StateT ([(Symbol, PrimExpr)], Int) Identity PrimExpr
extractLeftJoinFields Int
2 Tag
t2) a
columnsR
        renamedNullable :: nullableA
renamedNullable = NullMaker a nullableA -> a -> nullableA
forall a b. NullMaker a b -> a -> b
toNullable NullMaker a nullableA
nullmaker a
newColumnsR
        Column PrimExpr
cond = a -> Column PGBool
p a
newColumnsR
    in ( nullableA
renamedNullable
       , \Lateral
lat PrimQuery
primQueryL -> JoinType
-> PrimExpr
-> (Lateral, PrimQuery)
-> (Lateral, PrimQuery)
-> PrimQuery
forall a.
JoinType
-> PrimExpr
-> (Lateral, PrimQuery' a)
-> (Lateral, PrimQuery' a)
-> PrimQuery' a
PQ.Join
           JoinType
PQ.LeftJoin
           PrimExpr
cond
           (Lateral
PQ.NonLateral, PrimQuery
primQueryL)
           --- ^ I am reasonably confident that we don't need to rebind any
           --- column names here.  Columns that can become NULL need
           --- to be written here so that we can wrap them.  If we
           --- don't constant columns can avoid becoming NULL.
           --- However, these are the left columns and cannot become
           --- NULL in a left join, so we are fine.
           ---
           --- Report about the "avoiding NULL" bug:
           ---
           ---     https://github.com/tomjaguarpaw/haskell-opaleye/issues/223
           (Lateral
lat, (Bool -> [(Symbol, PrimExpr)] -> PrimQuery -> PrimQuery
forall a.
Bool -> [(Symbol, PrimExpr)] -> PrimQuery' a -> PrimQuery' a
PQ.Rebind Bool
True [(Symbol, PrimExpr)]
ljPEsR PrimQuery
primQueryR))
       , Tag -> Tag
T.next Tag
t2)

optionalRestrict :: D.Default U.Unpackspec a a
                 => S.Select a
                 -> S.SelectArr (a -> Field T.SqlBool) (MaybeFields a)
optionalRestrict :: Select a -> SelectArr (a -> Field PGBool) (MaybeFields a)
optionalRestrict = Unpackspec a a
-> Select a -> SelectArr (a -> Field PGBool) (MaybeFields a)
forall a.
Unpackspec a a
-> Select a -> SelectArr (a -> Field PGBool) (MaybeFields a)
optionalRestrictExplicit Unpackspec a a
forall (p :: * -> * -> *) a b. Default p a b => p a b
D.def

optionalRestrictExplicit :: U.Unpackspec a a
                         -> S.Select a
                         -> S.SelectArr (a -> Field T.SqlBool) (MaybeFields a)
optionalRestrictExplicit :: Unpackspec a a
-> Select a -> SelectArr (a -> Field PGBool) (MaybeFields a)
optionalRestrictExplicit Unpackspec a a
uA Select a
q =
  ((a -> Column PGBool) -> (Column PGBool, a) -> Column PGBool)
-> ((Column PGBool, a) -> MaybeFields a)
-> SelectArr
     ((Column PGBool, a) -> Column PGBool) (Column PGBool, a)
-> SelectArr (a -> Column PGBool) (MaybeFields a)
forall (p :: * -> * -> *) a b c d.
Profunctor p =>
(a -> b) -> (c -> d) -> p b c -> p a d
dimap ((a -> Column PGBool)
-> ((Column PGBool, a) -> a) -> (Column PGBool, a) -> Column PGBool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Column PGBool, a) -> a
forall a b. (a, b) -> b
snd) (\(Column PGBool
nonNullIfPresent, a
rest) ->
      let present :: Field PGBool
present = Field PGBool -> Field PGBool
Op.not (Column (Nullable Any) -> Column PGBool
forall a. Column (Nullable a) -> Column PGBool
C.isNull (Column PGBool -> Column (Nullable Any)
forall a b. Column a -> Column b
C.unsafeCoerceColumn Column PGBool
nonNullIfPresent))
      in MaybeFields :: forall fields. Column PGBool -> fields -> MaybeFields fields
MaybeFields { mfPresent :: Column PGBool
mfPresent = Column PGBool
Field PGBool
present
                     , mfFields :: a
mfFields  = a
rest
                     }) (SelectArr ((Column PGBool, a) -> Column PGBool) (Column PGBool, a)
 -> SelectArr (a -> Column PGBool) (MaybeFields a))
-> SelectArr
     ((Column PGBool, a) -> Column PGBool) (Column PGBool, a)
-> SelectArr (a -> Column PGBool) (MaybeFields a)
forall a b. (a -> b) -> a -> b
$
  Unpackspec (Column PGBool, a) (Column PGBool, a)
-> NullMaker (Column PGBool, a) (Column PGBool, a)
-> Query (Column PGBool, a)
-> SelectArr
     ((Column PGBool, a) -> Column PGBool) (Column PGBool, a)
forall a nullableA.
Unpackspec a a
-> NullMaker a nullableA
-> Query a
-> QueryArr (a -> Column PGBool) nullableA
leftJoinAExplicit ((Unpackspec (Column PGBool) (Column PGBool), Unpackspec a a)
-> Unpackspec (Column PGBool, a) (Column PGBool, a)
forall (p :: * -> * -> *) a0 a1 b0 b1.
ProductProfunctor p =>
(p a0 b0, p a1 b1) -> p (a0, a1) (b0, b1)
PP.p2 (Unpackspec (Column PGBool) (Column PGBool)
forall a. Unpackspec (Column a) (Column a)
U.unpackspecField, Unpackspec a a
uA))
                    (((Column PGBool, a) -> (Column PGBool, a))
-> NullMaker (Column PGBool, a) (Column PGBool, a)
forall a b. (a -> b) -> NullMaker a b
Opaleye.Internal.Join.NullMaker (Column PGBool, a) -> (Column PGBool, a)
forall a. a -> a
id)
                    ((a -> (Column PGBool, a)) -> Select a -> Query (Column PGBool, a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\a
x -> (Bool -> Field PGBool
T.sqlBool Bool
True, a
x)) Select a
q)

-- | An example to demonstrate how the functionality of @LEFT JOIN@
-- can be recovered using 'optionalRestrict'.
leftJoinInTermsOfOptionalRestrict :: D.Default U.Unpackspec fieldsR fieldsR
                                  => S.Select fieldsL
                                  -> S.Select fieldsR
                                  -> ((fieldsL, fieldsR) -> Field T.SqlBool)
                                  -> S.Select (fieldsL, MaybeFields fieldsR)
leftJoinInTermsOfOptionalRestrict :: Select fieldsL
-> Select fieldsR
-> ((fieldsL, fieldsR) -> Field PGBool)
-> Select (fieldsL, MaybeFields fieldsR)
leftJoinInTermsOfOptionalRestrict Select fieldsL
qL Select fieldsR
qR (fieldsL, fieldsR) -> Field PGBool
cond = proc () -> do
  fieldsL
fieldsL <- Select fieldsL
qL -< ()
  MaybeFields fieldsR
maybeFieldsR <- Select fieldsR
-> SelectArr (fieldsR -> Field PGBool) (MaybeFields fieldsR)
forall a.
Default Unpackspec a a =>
Select a -> SelectArr (a -> Field PGBool) (MaybeFields a)
optionalRestrict Select fieldsR
qR -< ((fieldsL, fieldsR) -> Column PGBool)
-> fieldsL -> fieldsR -> Column PGBool
forall a b c. ((a, b) -> c) -> a -> b -> c
curry (fieldsL, fieldsR) -> Column PGBool
(fieldsL, fieldsR) -> Field PGBool
cond fieldsL
fieldsL
  SelectArr
  (fieldsL, MaybeFields fieldsR) (fieldsL, MaybeFields fieldsR)
forall (a :: * -> * -> *) b. Arrow a => a b b
Control.Arrow.returnA -< (fieldsL
fieldsL, MaybeFields fieldsR
maybeFieldsR)

extractLeftJoinFields :: Int
                      -> T.Tag
                      -> HPQ.PrimExpr
                      -> PM.PM [(HPQ.Symbol, HPQ.PrimExpr)] HPQ.PrimExpr
extractLeftJoinFields :: Int
-> Tag
-> PrimExpr
-> StateT ([(Symbol, PrimExpr)], Int) Identity PrimExpr
extractLeftJoinFields Int
n = String
-> Tag
-> PrimExpr
-> StateT ([(Symbol, PrimExpr)], Int) Identity PrimExpr
forall primExpr.
String -> Tag -> primExpr -> PM [(Symbol, primExpr)] PrimExpr
PM.extractAttr (String
"result" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"_")

-- { Boilerplate instances

instance Functor (NullMaker a) where
  fmap :: (a -> b) -> NullMaker a a -> NullMaker a b
fmap a -> b
f (NullMaker a -> a
g) = (a -> b) -> NullMaker a b
forall a b. (a -> b) -> NullMaker a b
NullMaker ((a -> b) -> (a -> a) -> a -> b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f a -> a
g)

instance A.Applicative (NullMaker a) where
  pure :: a -> NullMaker a a
pure = (a -> a) -> NullMaker a a
forall a b. (a -> b) -> NullMaker a b
NullMaker ((a -> a) -> NullMaker a a) -> (a -> a -> a) -> a -> NullMaker a a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> a -> a
forall (f :: * -> *) a. Applicative f => a -> f a
A.pure
  NullMaker a -> a -> b
f <*> :: NullMaker a (a -> b) -> NullMaker a a -> NullMaker a b
<*> NullMaker a -> a
x = (a -> b) -> NullMaker a b
forall a b. (a -> b) -> NullMaker a b
NullMaker (a -> a -> b
f (a -> a -> b) -> (a -> a) -> a -> b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
A.<*> a -> a
x)

instance Profunctor NullMaker where
  dimap :: (a -> b) -> (c -> d) -> NullMaker b c -> NullMaker a d
dimap a -> b
f c -> d
g (NullMaker b -> c
h) = (a -> d) -> NullMaker a d
forall a b. (a -> b) -> NullMaker a b
NullMaker ((a -> b) -> (c -> d) -> (b -> c) -> a -> d
forall (p :: * -> * -> *) a b c d.
Profunctor p =>
(a -> b) -> (c -> d) -> p b c -> p a d
dimap a -> b
f c -> d
g b -> c
h)

instance PP.ProductProfunctor NullMaker where
  purePP :: b -> NullMaker a b
purePP = b -> NullMaker a b
forall (f :: * -> *) a. Applicative f => a -> f a
pure
  **** :: NullMaker a (b -> c) -> NullMaker a b -> NullMaker a c
(****) = NullMaker a (b -> c) -> NullMaker a b -> NullMaker a c
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
(<*>)

--

{-# DEPRECATED Nulled "Will be removed in version 0.8" #-}
data Nulled

type instance TF.IMap Nulled TF.OT     = TF.NullsT
type instance TF.IMap Nulled TF.NullsT = TF.NullsT

-- It's quite unfortunate that we have to write these out by hand
-- until we probably do nullability as a distinction between
--
-- Column (Nullable a)
-- Column (NonNullable a)

type instance Map.Map Nulled (Column (Nullable a)) = Column (Nullable a)

type instance Map.Map Nulled (Column T.PGInt4) = Column (Nullable T.PGInt4)
type instance Map.Map Nulled (Column T.PGInt8) = Column (Nullable T.PGInt8)
type instance Map.Map Nulled (Column T.PGText) = Column (Nullable T.PGText)
type instance Map.Map Nulled (Column T.PGFloat8) = Column (Nullable T.PGFloat8)
type instance Map.Map Nulled (Column T.PGBool) = Column (Nullable T.PGBool)
type instance Map.Map Nulled (Column T.PGUuid) = Column (Nullable T.PGUuid)
type instance Map.Map Nulled (Column T.PGBytea) = Column (Nullable T.PGBytea)
type instance Map.Map Nulled (Column T.PGText) = Column (Nullable T.PGText)
type instance Map.Map Nulled (Column T.PGDate) = Column (Nullable T.PGDate)
type instance Map.Map Nulled (Column T.PGTimestamp) = Column (Nullable T.PGTimestamp)
type instance Map.Map Nulled (Column T.PGTimestamptz) = Column (Nullable T.PGTimestamptz)
type instance Map.Map Nulled (Column T.PGTime) = Column (Nullable T.PGTime)
type instance Map.Map Nulled (Column T.PGCitext) = Column (Nullable T.PGCitext)
type instance Map.Map Nulled (Column T.PGJson) = Column (Nullable T.PGJson)
type instance Map.Map Nulled (Column T.PGJsonb) = Column (Nullable T.PGJsonb)