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

module Opaleye.Internal.Operators where

import           Opaleye.Internal.Column (Column(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 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 = ((Column SqlBool, PrimQuery, Tag) -> ((), PrimQuery, Tag))
-> SelectArr (Column SqlBool) ()
forall a b.
((a, PrimQuery, Tag) -> (b, PrimQuery, Tag)) -> SelectArr a b
QA.QueryArr (Column SqlBool, PrimQuery, Tag) -> ((), PrimQuery, Tag)
forall pgType c.
(Column pgType, PrimQuery, c) -> ((), PrimQuery, c)
f where
  f :: (Column pgType, PrimQuery, c) -> ((), PrimQuery, c)
f (Column PrimExpr
predicate, PrimQuery
primQ, c
t0) = ((), PrimExpr -> PrimQuery -> PrimQuery
PQ.restrict PrimExpr
predicate PrimQuery
primQ, c
t0)

infix 4 .==
(.==) :: forall columns. D.Default EqPP columns columns
      => columns -> columns -> Column T.PGBool
.== :: columns -> columns -> Column SqlBool
(.==) = EqPP columns columns -> columns -> columns -> Column SqlBool
forall columns a.
EqPP columns a -> columns -> columns -> Column 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 -> Column SqlBool -> Column SqlBool -> Column SqlBool
forall a b c. BinOp -> Column a -> Column b -> Column c
C.binOp BinOp
HPQ.OpOr

infixr 3 .&&

-- | Boolean and
(.&&) :: Column T.PGBool -> Column T.PGBool -> Column T.PGBool
.&& :: Column SqlBool -> Column SqlBool -> Column SqlBool
(.&&) = BinOp -> Column SqlBool -> Column SqlBool -> Column SqlBool
forall a b c. BinOp -> Column a -> Column b -> Column c
C.binOp BinOp
HPQ.OpAnd

not :: F.Field T.SqlBool -> F.Field T.SqlBool
not :: Field SqlBool -> Field SqlBool
not = UnOp -> Column SqlBool -> Column SqlBool
forall a b. UnOp -> Column a -> Column b
C.unOp UnOp
HPQ.OpNot

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

eqPPField :: EqPP (Column a) ignored
eqPPField :: EqPP (Column a) ignored
eqPPField = (Column a -> Column a -> Column SqlBool) -> EqPP (Column a) ignored
forall a b. (a -> a -> Column SqlBool) -> EqPP a b
EqPP Column a -> Column a -> Column SqlBool
forall a pgBool. Column a -> Column a -> Column pgBool
C.unsafeEq

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

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


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

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

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

instance D.Default IfPP (Column a) (Column a) where
  def :: IfPP (Column a) (Column a)
def = (Column SqlBool -> Column a -> Column a -> Column a)
-> IfPP (Column a) (Column a)
forall a b. (Column SqlBool -> a -> a -> b) -> IfPP a b
IfPP Column SqlBool -> Column a -> Column a -> Column a
forall pgBool a. Column pgBool -> Column a -> Column a -> Column 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 (Column a)
relExprColumn :: RelExprMaker String (Column a)
relExprColumn = ViewColumnMaker String (Column a)
-> Unpackspec (Column a) (Column a)
-> RelExprMaker String (Column a)
forall a b c.
ViewColumnMaker a c -> Unpackspec c b -> RelExprMaker a b
RelExprMaker ViewColumnMaker String (Column a)
forall a. ViewColumnMaker String (Column a)
TM.tableColumn Unpackspec (Column a) (Column a)
forall a. Unpackspec (Column a) (Column a)
U.unpackspecField

instance D.Default RelExprMaker String (Column a) where
  def :: RelExprMaker String (Column a)
def = RelExprMaker String (Column a)
forall a. RelExprMaker String (Column a)
relExprColumn

runRelExprMaker :: RelExprMaker strings columns
                -> Tag.Tag
                -> strings
                -> (columns, [(HPQ.Symbol, HPQ.PrimExpr)])
runRelExprMaker :: 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 -> Unpackspec c columns -> Tag -> c -> (columns, [(Symbol, PrimExpr)])
forall tablecolumns columns.
Unpackspec tablecolumns columns
-> Tag -> tablecolumns -> (columns, [(Symbol, PrimExpr)])
Table.runColumnMaker Unpackspec c columns
cm Tag
tag
                                    (c -> (columns, [(Symbol, PrimExpr)]))
-> (strings -> c) -> strings -> (columns, [(Symbol, PrimExpr)])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ViewColumnMaker strings c -> strings -> 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 :: RelExprMaker strings columns
-> strings -> (a -> PrimExpr) -> QueryArr a columns
relationValuedExprExplicit RelExprMaker strings columns
rem_ strings
strings a -> PrimExpr
pe =
  ((a, Tag) -> (columns, PrimQuery, Tag)) -> QueryArr a columns
forall a b. ((a, Tag) -> (b, PrimQuery, Tag)) -> QueryArr a b
QA.productQueryArr (((a, Tag) -> (columns, PrimQuery, Tag)) -> QueryArr a columns)
-> ((a, Tag) -> (columns, PrimQuery, Tag)) -> QueryArr a columns
forall a b. (a -> b) -> a -> b
$ \(a
a, Tag
tag) ->
    let (columns
primExprs, [(Symbol, PrimExpr)]
projcols) = RelExprMaker strings columns
-> Tag -> strings -> (columns, [(Symbol, PrimExpr)])
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 = PrimExpr -> [(Symbol, PrimExpr)] -> PrimQuery
forall a. PrimExpr -> [(Symbol, PrimExpr)] -> PrimQuery' a
PQ.RelExpr (a -> PrimExpr
pe a
a) [(Symbol, PrimExpr)]
projcols
    in (columns
primExprs, PrimQuery
primQ, Tag -> Tag
Tag.next Tag
tag)

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

-- { Boilerplate instances

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

instance ProductProfunctor EqPP where
  empty :: EqPP () ()
empty = (() -> () -> Column SqlBool) -> EqPP () ()
forall a b. (a -> a -> Column SqlBool) -> EqPP a b
EqPP (\() () -> Bool -> Column SqlBool
T.pgBool Bool
True)
  EqPP a -> a -> Column SqlBool
f ***! :: EqPP a b -> EqPP a' b' -> EqPP (a, a') (b, b')
***! EqPP a' -> a' -> Column SqlBool
f' = ((a, a') -> (a, a') -> Column SqlBool) -> EqPP (a, a') (b, b')
forall a b. (a -> a -> Column SqlBool) -> EqPP a b
EqPP (\(a, a')
a (a, a')
a' ->
                               a -> a -> Column 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') Column SqlBool -> Column SqlBool -> Column SqlBool
.&& a' -> a' -> Column 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 RelExprMaker where
  dimap :: (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) = ViewColumnMaker a c -> Unpackspec c d -> RelExprMaker a d
forall a b c.
ViewColumnMaker a c -> Unpackspec c b -> RelExprMaker a b
RelExprMaker ((a -> b) -> ViewColumnMaker b c -> ViewColumnMaker a c
forall (p :: * -> * -> *) a b c.
Profunctor p =>
(a -> b) -> p b c -> p a c
lmap a -> b
f ViewColumnMaker b c
a) ((c -> d) -> Unpackspec c c -> Unpackspec c d
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 = ViewColumnMaker () () -> Unpackspec () () -> RelExprMaker () ()
forall a b c.
ViewColumnMaker a c -> Unpackspec c b -> RelExprMaker a b
RelExprMaker ViewColumnMaker () ()
forall (p :: * -> * -> *). ProductProfunctor p => p () ()
empty Unpackspec () ()
forall (p :: * -> * -> *). ProductProfunctor p => p () ()
empty
  RelExprMaker a b
f ***! :: 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 ->
                                    ViewColumnMaker a c
-> ViewColumnMaker a' c
-> Unpackspec c b
-> Unpackspec c b'
-> RelExprMaker (a, a') (b, b')
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 = ViewColumnMaker (a, a') (b, b')
-> Unpackspec (b, b') (b, b') -> RelExprMaker (a, a') (b, b')
forall a b c.
ViewColumnMaker a c -> Unpackspec c b -> RelExprMaker a b
RelExprMaker (ViewColumnMaker a b
vcmg ViewColumnMaker a b
-> ViewColumnMaker a' b' -> ViewColumnMaker (a, a') (b, b')
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  Unpackspec b b -> Unpackspec b' b' -> Unpackspec (b, b') (b, b')
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 :: (a -> b) -> (c -> d) -> IfPP b c -> IfPP a d
dimap a -> b
f c -> d
g (IfPP Column SqlBool -> b -> b -> c
h) = (Column SqlBool -> a -> a -> d) -> IfPP a d
forall a b. (Column SqlBool -> a -> a -> b) -> IfPP a b
IfPP (\Column SqlBool
b a
a a
a' -> c -> d
g (Column SqlBool -> b -> b -> c
h Column SqlBool
b (a -> b
f a
a) (a -> b
f a
a')))

instance ProductProfunctor IfPP where
  empty :: IfPP () ()
empty = (Column SqlBool -> () -> () -> ()) -> IfPP () ()
forall a b. (Column SqlBool -> a -> a -> b) -> IfPP a b
IfPP (\Column SqlBool
_ () () -> ())
  IfPP Column SqlBool -> a -> a -> b
f ***! :: IfPP a b -> IfPP a' b' -> IfPP (a, a') (b, b')
***! IfPP Column SqlBool -> a' -> a' -> b'
f' = (Column SqlBool -> (a, a') -> (a, a') -> (b, b'))
-> IfPP (a, a') (b, b')
forall a b. (Column SqlBool -> a -> a -> b) -> IfPP a b
IfPP (\Column SqlBool
b (a, a')
a (a, a')
a1 ->
                               (Column SqlBool -> a -> a -> b
f Column 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), Column SqlBool -> a' -> a' -> b'
f' Column 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)))

-- }