{-# OPTIONS_HADDOCK not-home #-}

{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Opaleye.Internal.Operators where

import           Opaleye.Internal.Column (Field_(Column))
import qualified Opaleye.Internal.Column as C
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.Table as Table
import qualified Opaleye.Internal.TableMaker as TM
import qualified Opaleye.Internal.Tag as Tag
import qualified Opaleye.Internal.Unpackspec as U
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, lmap, rmap)
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 = forall a b. State Tag (a -> (b, PrimQueryArr)) -> SelectArr a b
QA.selectArr 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 = 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
(.==) = forall columns a.
EqPP columns a -> columns -> columns -> Field SqlBool
eqExplicit (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
(.||) = 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
(.&&) = 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 = 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 = forall a b. (a -> a -> Field SqlBool) -> EqPP a b
EqPP 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 = 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 = 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 = forall a b. (Field SqlBool -> a -> a -> b) -> IfPP a b
IfPP forall (n' :: Nullability) pgBool (n :: Nullability) a.
Field_ n' pgBool -> Field_ n a -> Field_ n a -> Field_ n a
C.unsafeIfThenElse


-- This seems to be the only place we use ViewColumnMaker now.
data RelExprMaker a b =
  forall c. RelExprMaker {
      ()
relExprVCM :: TM.ViewColumnMaker a c
    , ()
relExprCM  :: U.Unpackspec c b
    }

relExprColumn :: RelExprMaker String (Field_ n a)
relExprColumn :: forall (n :: Nullability) a. RelExprMaker String (Field_ n a)
relExprColumn = forall a b c.
ViewColumnMaker a c -> Unpackspec c b -> RelExprMaker a b
RelExprMaker forall (n :: Nullability) a. ViewColumnMaker String (Field_ n a)
TM.tableColumn forall (n :: Nullability) a. Unpackspec (Field_ n a) (Field_ n a)
U.unpackspecField

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

runRelExprMaker :: RelExprMaker strings columns
                -> Tag.Tag
                -> strings
                -> (columns, [(HPQ.Symbol, HPQ.PrimExpr)])
runRelExprMaker :: forall strings columns.
RelExprMaker strings columns
-> Tag -> strings -> (columns, [(Symbol, PrimExpr)])
runRelExprMaker RelExprMaker strings columns
rem_ Tag
tag =
  case RelExprMaker strings columns
rem_ of RelExprMaker ViewColumnMaker strings c
vcm Unpackspec c columns
cm -> forall tablecolumns columns.
Unpackspec tablecolumns columns
-> Tag -> tablecolumns -> (columns, [(Symbol, PrimExpr)])
Table.runColumnMaker Unpackspec c columns
cm Tag
tag
                                    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall strings tablecolumns.
ViewColumnMaker strings tablecolumns -> strings -> tablecolumns
TM.runViewColumnMaker ViewColumnMaker strings c
vcm

relationValuedExprExplicit :: RelExprMaker strings columns
                           -> strings
                           -> (a -> HPQ.PrimExpr)
                           -> QA.QueryArr a columns
relationValuedExprExplicit :: forall strings columns a.
RelExprMaker strings columns
-> strings -> (a -> PrimExpr) -> QueryArr a columns
relationValuedExprExplicit RelExprMaker strings columns
rem_ strings
strings a -> PrimExpr
pe =
  forall a b. State Tag (a -> (b, PrimQuery)) -> QueryArr a b
QA.productQueryArr' forall a b. (a -> b) -> a -> b
$ do
    Tag
tag <- State Tag Tag
Tag.fresh
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ \a
a ->
      let (columns
primExprs, [(Symbol, PrimExpr)]
projcols) = forall strings columns.
RelExprMaker strings columns
-> Tag -> strings -> (columns, [(Symbol, PrimExpr)])
runRelExprMaker RelExprMaker strings columns
rem_ Tag
tag strings
strings
          primQ :: PQ.PrimQuery
          primQ :: PrimQuery
primQ = forall a. PrimExpr -> [(Symbol, PrimExpr)] -> PrimQuery' a
PQ.RelExpr (a -> PrimExpr
pe a
a) [(Symbol, PrimExpr)]
projcols
      in (columns
primExprs, PrimQuery
primQ)

relationValuedExpr :: D.Default RelExprMaker strings columns
                   => strings
                   -> (a -> HPQ.PrimExpr)
                   -> QA.QueryArr a columns
relationValuedExpr :: forall strings columns a.
Default RelExprMaker strings columns =>
strings -> (a -> PrimExpr) -> QueryArr a columns
relationValuedExpr = forall strings columns a.
RelExprMaker strings columns
-> strings -> (a -> PrimExpr) -> QueryArr a columns
relationValuedExprExplicit 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) = 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 = 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' = forall a b. (a -> a -> Field SqlBool) -> EqPP a b
EqPP (\(a, a')
a (a, a')
a' ->
                               a -> a -> Field SqlBool
f (forall a b. (a, b) -> a
fst (a, a')
a) (forall a b. (a, b) -> a
fst (a, a')
a') Field SqlBool -> Field SqlBool -> Field SqlBool
.&& a' -> a' -> Field SqlBool
f' (forall a b. (a, b) -> b
snd (a, a')
a) (forall a b. (a, b) -> b
snd (a, a')
a'))

instance Profunctor RelExprMaker where
  dimap :: forall a b c d.
(a -> b) -> (c -> d) -> RelExprMaker b c -> RelExprMaker a d
dimap a -> b
f c -> d
g (RelExprMaker ViewColumnMaker b c
a Unpackspec c c
b) = forall a b c.
ViewColumnMaker a c -> Unpackspec c b -> RelExprMaker a b
RelExprMaker (forall (p :: * -> * -> *) a b c.
Profunctor p =>
(a -> b) -> p b c -> p a c
lmap a -> b
f ViewColumnMaker b c
a) (forall (p :: * -> * -> *) b c a.
Profunctor p =>
(b -> c) -> p a b -> p a c
rmap c -> d
g Unpackspec c c
b)

instance ProductProfunctor RelExprMaker where
  empty :: RelExprMaker () ()
empty = forall a b c.
ViewColumnMaker a c -> Unpackspec c b -> RelExprMaker a b
RelExprMaker forall (p :: * -> * -> *). ProductProfunctor p => p () ()
empty forall (p :: * -> * -> *). ProductProfunctor p => p () ()
empty
  RelExprMaker a b
f ***! :: forall a b a' b'.
RelExprMaker a b
-> RelExprMaker a' b' -> RelExprMaker (a, a') (b, b')
***! RelExprMaker a' b'
g = case RelExprMaker a b
f of RelExprMaker ViewColumnMaker a c
vcmf Unpackspec c b
cmf ->
                        case RelExprMaker a' b'
g of RelExprMaker ViewColumnMaker a' c
vcmg Unpackspec c b'
cmg ->
                                    forall {a} {b} {a'} {b'} {b} {b'}.
ViewColumnMaker a b
-> ViewColumnMaker a' b'
-> Unpackspec b b
-> Unpackspec b' b'
-> RelExprMaker (a, a') (b, b')
h ViewColumnMaker a c
vcmf ViewColumnMaker a' c
vcmg Unpackspec c b
cmf Unpackspec c b'
cmg
    where h :: ViewColumnMaker a b
-> ViewColumnMaker a' b'
-> Unpackspec b b
-> Unpackspec b' b'
-> RelExprMaker (a, a') (b, b')
h ViewColumnMaker a b
vcmg ViewColumnMaker a' b'
vcmf Unpackspec b b
cmg Unpackspec b' b'
cmf = forall a b c.
ViewColumnMaker a c -> Unpackspec c b -> RelExprMaker a b
RelExprMaker (ViewColumnMaker a b
vcmg forall (p :: * -> * -> *) a b a' b'.
ProductProfunctor p =>
p a b -> p a' b' -> p (a, a') (b, b')
***! ViewColumnMaker a' b'
vcmf)
                                             (Unpackspec b b
cmg  forall (p :: * -> * -> *) a b a' b'.
ProductProfunctor p =>
p a b -> p a' b' -> p (a, a') (b, b')
***! Unpackspec b' b'
cmf)

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) = 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 = 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' = 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 (forall a b. (a, b) -> a
fst (a, a')
a) (forall a b. (a, b) -> a
fst (a, a')
a1), Field SqlBool -> a' -> a' -> b'
f' Field SqlBool
b (forall a b. (a, b) -> b
snd (a, a')
a) (forall a b. (a, b) -> b
snd (a, a')
a1)))

-- }