{-# OPTIONS_HADDOCK not-home #-}

{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Opaleye.Internal.Operators where

import Control.Applicative (liftA2)

import           Opaleye.Internal.Column (Field_(Column))
import qualified Opaleye.Internal.Column as C
import qualified Opaleye.Internal.PackMap as PM
import qualified Opaleye.Internal.PrimQuery as PQ
import qualified Opaleye.Internal.HaskellDB.PrimQuery as HPQ
import qualified Opaleye.Internal.QueryArr as QA
import qualified Opaleye.Internal.Tag as Tag
import qualified Opaleye.Internal.PGTypesExternal as T
import qualified Opaleye.Field as F
import           Opaleye.Field (Field)
import qualified Opaleye.Select as S

import           Data.Profunctor (Profunctor, dimap)
import           Data.Profunctor.Product (ProductProfunctor, empty, (***!))
import qualified Data.Profunctor.Product.Default as D

restrict :: S.SelectArr (F.Field T.SqlBool) ()
restrict :: SelectArr (Field SqlBool) ()
restrict = State Tag (Field SqlBool -> ((), PrimQueryArr))
-> SelectArr (Field SqlBool) ()
forall a b. State Tag (a -> (b, PrimQueryArr)) -> SelectArr a b
QA.selectArr State Tag (Field SqlBool -> ((), PrimQueryArr))
forall {n :: Nullability} {sqlType}.
StateT Tag Identity (Field_ n sqlType -> ((), PrimQueryArr))
f where
  -- A where clause can always refer to columns defined by the query
  -- it references so needs no special treatment on LATERAL.
  f :: StateT Tag Identity (Field_ n sqlType -> ((), PrimQueryArr))
f = (Field_ n sqlType -> ((), PrimQueryArr))
-> StateT Tag Identity (Field_ n sqlType -> ((), PrimQueryArr))
forall a. a -> StateT Tag Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (\(Column PrimExpr
predicate) -> ((), PrimExpr -> PrimQueryArr
PQ.aRestrict PrimExpr
predicate))

infix 4 .==
(.==) :: forall columns. D.Default EqPP columns columns
      => columns -> columns -> Field T.PGBool
.== :: forall columns.
Default EqPP columns columns =>
columns -> columns -> Field SqlBool
(.==) = EqPP columns columns -> columns -> columns -> Field SqlBool
forall columns a.
EqPP columns a -> columns -> columns -> Field SqlBool
eqExplicit (EqPP columns columns
forall (p :: * -> * -> *) a b. Default p a b => p a b
D.def :: EqPP columns columns)

infixr 2 .||

(.||) :: F.Field T.SqlBool -> F.Field T.SqlBool -> F.Field T.SqlBool
.|| :: Field SqlBool -> Field SqlBool -> Field SqlBool
(.||) = BinOp -> Field SqlBool -> Field SqlBool -> Field SqlBool
forall (n :: Nullability) a (n' :: Nullability) b
       (n'' :: Nullability) c.
BinOp -> Field_ n a -> Field_ n' b -> Field_ n'' c
C.binOp BinOp
HPQ.OpOr

infixr 3 .&&

-- | Boolean and
(.&&) :: Field T.PGBool -> Field T.PGBool -> Field T.PGBool
.&& :: Field SqlBool -> Field SqlBool -> Field SqlBool
(.&&) = BinOp -> Field SqlBool -> Field SqlBool -> Field SqlBool
forall (n :: Nullability) a (n' :: Nullability) b
       (n'' :: Nullability) c.
BinOp -> Field_ n a -> Field_ n' b -> Field_ n'' c
C.binOp BinOp
HPQ.OpAnd

not :: F.Field T.SqlBool -> F.Field T.SqlBool
not :: Field SqlBool -> Field SqlBool
not = UnOp -> Field SqlBool -> Field SqlBool
forall (n :: Nullability) a (n' :: Nullability) b.
UnOp -> Field_ n a -> Field_ n' b
C.unOp UnOp
HPQ.OpNot

newtype EqPP a b = EqPP (a -> a -> Field T.PGBool)

eqPPField :: EqPP (Field a) ignored
eqPPField :: forall a ignored. EqPP (Field a) ignored
eqPPField = (Field a -> Field a -> Field SqlBool) -> EqPP (Field a) ignored
forall a b. (a -> a -> Field SqlBool) -> EqPP a b
EqPP Field a -> Field a -> Field SqlBool
forall (n :: Nullability) a (n' :: Nullability) pgBool.
Field_ n a -> Field_ n a -> Field_ n' pgBool
C.unsafeEq

eqExplicit :: EqPP columns a -> columns -> columns -> Field T.PGBool
eqExplicit :: forall columns a.
EqPP columns a -> columns -> columns -> Field SqlBool
eqExplicit (EqPP columns -> columns -> Field SqlBool
f) = columns -> columns -> Field SqlBool
f

instance D.Default EqPP (Field a) (Field a) where
  def :: EqPP (Field a) (Field a)
def = EqPP (Field a) (Field a)
forall a ignored. EqPP (Field a) ignored
eqPPField


newtype IfPP a b = IfPP (Field T.PGBool -> a -> a -> b)

ifExplict :: IfPP columns columns'
          -> Field T.PGBool
          -> columns
          -> columns
          -> columns'
ifExplict :: forall columns columns'.
IfPP columns columns'
-> Field SqlBool -> columns -> columns -> columns'
ifExplict (IfPP Field SqlBool -> columns -> columns -> columns'
f) = Field SqlBool -> columns -> columns -> columns'
f

ifPPField :: IfPP (Field_ n a) (Field_ n a)
ifPPField :: forall (n :: Nullability) a. IfPP (Field_ n a) (Field_ n a)
ifPPField = IfPP (Field_ n a) (Field_ n a)
forall (p :: * -> * -> *) a b. Default p a b => p a b
D.def

instance D.Default IfPP (Field_ n a) (Field_ n a) where
  def :: IfPP (Field_ n a) (Field_ n a)
def = (Field SqlBool -> Field_ n a -> Field_ n a -> Field_ n a)
-> IfPP (Field_ n a) (Field_ n a)
forall a b. (Field SqlBool -> a -> a -> b) -> IfPP a b
IfPP Field SqlBool -> Field_ n a -> Field_ n a -> Field_ n a
forall (n' :: Nullability) pgBool (n :: Nullability) a.
Field_ n' pgBool -> Field_ n a -> Field_ n a -> Field_ n a
C.unsafeIfThenElse


newtype RelExprPP a b = RelExprPP (Tag.Tag -> PM.PM [HPQ.Symbol] b)


runRelExprPP :: RelExprPP a b -> Tag.Tag -> (b, [HPQ.Symbol])
runRelExprPP :: forall a b. RelExprPP a b -> Tag -> (b, [Symbol])
runRelExprPP (RelExprPP Tag -> PM [Symbol] b
m) = PM [Symbol] b -> (b, [Symbol])
forall a r. PM [a] r -> (r, [a])
PM.run (PM [Symbol] b -> (b, [Symbol]))
-> (Tag -> PM [Symbol] b) -> Tag -> (b, [Symbol])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tag -> PM [Symbol] b
m


instance D.Default RelExprPP (Field_ n a) (Field_ n a) where
  def :: RelExprPP (Field_ n a) (Field_ n a)
def = RelExprPP (Field_ n a) (Field_ n a)
forall (n :: Nullability) a. RelExprPP (Field_ n a) (Field_ n a)
relExprColumn


relExprColumn :: RelExprPP (Field_ n a) (Field_ n a)
relExprColumn :: forall (n :: Nullability) a. RelExprPP (Field_ n a) (Field_ n a)
relExprColumn = (Tag -> PM [Symbol] (Field_ n a))
-> RelExprPP (Field_ n a) (Field_ n a)
forall a b. (Tag -> PM [Symbol] b) -> RelExprPP a b
RelExprPP ((Tag -> PM [Symbol] (Field_ n a))
 -> RelExprPP (Field_ n a) (Field_ n a))
-> (Tag -> PM [Symbol] (Field_ n a))
-> RelExprPP (Field_ n a) (Field_ n a)
forall a b. (a -> b) -> a -> b
$ (PrimExpr -> Field_ n a)
-> StateT ([Symbol], Int) Identity PrimExpr
-> PM [Symbol] (Field_ n a)
forall a b.
(a -> b)
-> StateT ([Symbol], Int) Identity a
-> StateT ([Symbol], Int) Identity b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PrimExpr -> Field_ n a
forall (n :: Nullability) sqlType. PrimExpr -> Field_ n sqlType
Column (StateT ([Symbol], Int) Identity PrimExpr
 -> PM [Symbol] (Field_ n a))
-> (Tag -> StateT ([Symbol], Int) Identity PrimExpr)
-> Tag
-> PM [Symbol] (Field_ n a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Tag -> StateT ([Symbol], Int) Identity PrimExpr
PM.extract String
"relExpr"


relationValuedExprExplicit :: RelExprPP columns columns
                           -> (a -> HPQ.PrimExpr)
                           -> QA.QueryArr a columns
relationValuedExprExplicit :: forall columns a.
RelExprPP columns columns -> (a -> PrimExpr) -> QueryArr a columns
relationValuedExprExplicit RelExprPP columns columns
relExprPP a -> PrimExpr
pe =
  State Tag (a -> (columns, PrimQuery)) -> QueryArr a columns
forall a b. State Tag (a -> (b, PrimQuery)) -> QueryArr a b
QA.productQueryArr' (State Tag (a -> (columns, PrimQuery)) -> QueryArr a columns)
-> State Tag (a -> (columns, PrimQuery)) -> QueryArr a columns
forall a b. (a -> b) -> a -> b
$ do
    (columns
columns, [Symbol]
symbols) <- RelExprPP columns columns -> Tag -> (columns, [Symbol])
forall a b. RelExprPP a b -> Tag -> (b, [Symbol])
runRelExprPP RelExprPP columns columns
relExprPP (Tag -> (columns, [Symbol]))
-> StateT Tag Identity Tag
-> StateT Tag Identity (columns, [Symbol])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StateT Tag Identity Tag
Tag.fresh
    (a -> (columns, PrimQuery))
-> State Tag (a -> (columns, PrimQuery))
forall a. a -> StateT Tag Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((a -> (columns, PrimQuery))
 -> State Tag (a -> (columns, PrimQuery)))
-> (a -> (columns, PrimQuery))
-> State Tag (a -> (columns, PrimQuery))
forall a b. (a -> b) -> a -> b
$ \a
a -> (columns
columns, PrimExpr -> [Symbol] -> PrimQuery
forall a. PrimExpr -> [Symbol] -> PrimQuery' a
PQ.RelExpr (a -> PrimExpr
pe a
a) [Symbol]
symbols)


relationValuedExpr :: D.Default RelExprPP columns columns
                   => (a -> HPQ.PrimExpr)
                   -> QA.QueryArr a columns
relationValuedExpr :: forall columns a.
Default RelExprPP columns columns =>
(a -> PrimExpr) -> QueryArr a columns
relationValuedExpr = RelExprPP columns columns -> (a -> PrimExpr) -> QueryArr a columns
forall columns a.
RelExprPP columns columns -> (a -> PrimExpr) -> QueryArr a columns
relationValuedExprExplicit RelExprPP columns columns
forall (p :: * -> * -> *) a b. Default p a b => p a b
D.def

-- { Boilerplate instances

instance Profunctor EqPP where
  dimap :: forall a b c d. (a -> b) -> (c -> d) -> EqPP b c -> EqPP a d
dimap a -> b
f c -> d
_ (EqPP b -> b -> Field SqlBool
h) = (a -> a -> Field SqlBool) -> EqPP a d
forall a b. (a -> a -> Field SqlBool) -> EqPP a b
EqPP (\a
a a
a' -> b -> b -> Field SqlBool
h (a -> b
f a
a) (a -> b
f a
a'))

instance ProductProfunctor EqPP where
  empty :: EqPP () ()
empty = (() -> () -> Field SqlBool) -> EqPP () ()
forall a b. (a -> a -> Field SqlBool) -> EqPP a b
EqPP (\() () -> Bool -> Field SqlBool
T.pgBool Bool
True)
  EqPP a -> a -> Field SqlBool
f ***! :: forall a b a' b'. EqPP a b -> EqPP a' b' -> EqPP (a, a') (b, b')
***! EqPP a' -> a' -> Field SqlBool
f' = ((a, a') -> (a, a') -> Field SqlBool) -> EqPP (a, a') (b, b')
forall a b. (a -> a -> Field SqlBool) -> EqPP a b
EqPP (\(a, a')
a (a, a')
a' ->
                               a -> a -> Field SqlBool
f ((a, a') -> a
forall a b. (a, b) -> a
fst (a, a')
a) ((a, a') -> a
forall a b. (a, b) -> a
fst (a, a')
a') Field SqlBool -> Field SqlBool -> Field SqlBool
.&& a' -> a' -> Field SqlBool
f' ((a, a') -> a'
forall a b. (a, b) -> b
snd (a, a')
a) ((a, a') -> a'
forall a b. (a, b) -> b
snd (a, a')
a'))

instance Profunctor RelExprPP where
  dimap :: forall a b c d.
(a -> b) -> (c -> d) -> RelExprPP b c -> RelExprPP a d
dimap a -> b
_ c -> d
f (RelExprPP Tag -> PM [Symbol] c
m) = (Tag -> PM [Symbol] d) -> RelExprPP a d
forall a b. (Tag -> PM [Symbol] b) -> RelExprPP a b
RelExprPP ((PM [Symbol] c -> PM [Symbol] d)
-> (Tag -> PM [Symbol] c) -> Tag -> PM [Symbol] d
forall a b. (a -> b) -> (Tag -> a) -> Tag -> b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((c -> d) -> PM [Symbol] c -> PM [Symbol] d
forall a b.
(a -> b)
-> StateT ([Symbol], Int) Identity a
-> StateT ([Symbol], Int) Identity b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap c -> d
f) Tag -> PM [Symbol] c
m)

instance ProductProfunctor RelExprPP where
  empty :: RelExprPP () ()
empty = (Tag -> PM [Symbol] ()) -> RelExprPP () ()
forall a b. (Tag -> PM [Symbol] b) -> RelExprPP a b
RelExprPP (PM [Symbol] () -> Tag -> PM [Symbol] ()
forall a. a -> Tag -> a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (() -> PM [Symbol] ()
forall a. a -> StateT ([Symbol], Int) Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()))
  RelExprPP Tag -> PM [Symbol] b
f ***! :: forall a b a' b'.
RelExprPP a b -> RelExprPP a' b' -> RelExprPP (a, a') (b, b')
***! RelExprPP Tag -> PM [Symbol] b'
g =
    (Tag -> PM [Symbol] (b, b')) -> RelExprPP (a, a') (b, b')
forall a b. (Tag -> PM [Symbol] b) -> RelExprPP a b
RelExprPP ((Tag -> PM [Symbol] (b, b')) -> RelExprPP (a, a') (b, b'))
-> (Tag -> PM [Symbol] (b, b')) -> RelExprPP (a, a') (b, b')
forall a b. (a -> b) -> a -> b
$ (PM [Symbol] b -> PM [Symbol] b' -> PM [Symbol] (b, b'))
-> (Tag -> PM [Symbol] b)
-> (Tag -> PM [Symbol] b')
-> Tag
-> PM [Symbol] (b, b')
forall a b c. (a -> b -> c) -> (Tag -> a) -> (Tag -> b) -> Tag -> c
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 ((b -> b' -> (b, b'))
-> PM [Symbol] b -> PM [Symbol] b' -> PM [Symbol] (b, b')
forall a b c.
(a -> b -> c)
-> StateT ([Symbol], Int) Identity a
-> StateT ([Symbol], Int) Identity b
-> StateT ([Symbol], Int) Identity c
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 (,)) Tag -> PM [Symbol] b
f Tag -> PM [Symbol] b'
g

instance Profunctor IfPP where
  dimap :: forall a b c d. (a -> b) -> (c -> d) -> IfPP b c -> IfPP a d
dimap a -> b
f c -> d
g (IfPP Field SqlBool -> b -> b -> c
h) = (Field SqlBool -> a -> a -> d) -> IfPP a d
forall a b. (Field SqlBool -> a -> a -> b) -> IfPP a b
IfPP (\Field SqlBool
b a
a a
a' -> c -> d
g (Field SqlBool -> b -> b -> c
h Field SqlBool
b (a -> b
f a
a) (a -> b
f a
a')))

instance ProductProfunctor IfPP where
  empty :: IfPP () ()
empty = (Field SqlBool -> () -> () -> ()) -> IfPP () ()
forall a b. (Field SqlBool -> a -> a -> b) -> IfPP a b
IfPP (\Field SqlBool
_ () () -> ())
  IfPP Field SqlBool -> a -> a -> b
f ***! :: forall a b a' b'. IfPP a b -> IfPP a' b' -> IfPP (a, a') (b, b')
***! IfPP Field SqlBool -> a' -> a' -> b'
f' = (Field SqlBool -> (a, a') -> (a, a') -> (b, b'))
-> IfPP (a, a') (b, b')
forall a b. (Field SqlBool -> a -> a -> b) -> IfPP a b
IfPP (\Field SqlBool
b (a, a')
a (a, a')
a1 ->
                               (Field SqlBool -> a -> a -> b
f Field SqlBool
b ((a, a') -> a
forall a b. (a, b) -> a
fst (a, a')
a) ((a, a') -> a
forall a b. (a, b) -> a
fst (a, a')
a1), Field SqlBool -> a' -> a' -> b'
f' Field SqlBool
b ((a, a') -> a'
forall a b. (a, b) -> b
snd (a, a')
a) ((a, a') -> a'
forall a b. (a, b) -> b
snd (a, a')
a1)))

-- }