{-# 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 = (Field SqlBool -> State Tag ((), PrimQueryArr))
-> SelectArr (Field SqlBool) ()
forall a b. (a -> State Tag (b, PrimQueryArr)) -> SelectArr a b
QA.QueryArr Field SqlBool -> State Tag ((), PrimQueryArr)
forall (f :: * -> *) (n :: Nullability) sqlType.
Applicative f =>
Field_ n sqlType -> f ((), PrimQueryArr)
f where
f :: Field_ n sqlType -> f ((), PrimQueryArr)
f (Column PrimExpr
predicate) = ((), PrimQueryArr) -> f ((), PrimQueryArr)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((), PrimExpr -> PrimQueryArr
PQ.aRestrict PrimExpr
predicate)
infix 4 .==
(.==) :: forall columns. D.Default EqPP columns columns
=> columns -> columns -> Field T.PGBool
.== :: 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 .&&
(.&&) :: 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 :: 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 :: 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 :: 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 :: 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
data RelExprMaker a b =
forall c. RelExprMaker {
()
relExprVCM :: TM.ViewColumnMaker a c
, ()
relExprCM :: U.Unpackspec c b
}
relExprColumn :: RelExprMaker String (Field_ n a)
relExprColumn :: RelExprMaker String (Field_ n a)
relExprColumn = ViewColumnMaker String (Field_ n a)
-> Unpackspec (Field_ n a) (Field_ n a)
-> RelExprMaker String (Field_ n a)
forall a b c.
ViewColumnMaker a c -> Unpackspec c b -> RelExprMaker a b
RelExprMaker ViewColumnMaker String (Field_ n a)
forall (n :: Nullability) a. ViewColumnMaker String (Field_ n a)
TM.tableColumn Unpackspec (Field_ n a) (Field_ n a)
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 = RelExprMaker String (Field_ n a)
forall (n :: Nullability) a. RelExprMaker String (Field_ n 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 -> State Tag (columns, PrimQuery)) -> QueryArr a columns
forall a b. (a -> State Tag (b, PrimQuery)) -> QueryArr a b
QA.productQueryArr' ((a -> State Tag (columns, PrimQuery)) -> QueryArr a columns)
-> (a -> State Tag (columns, PrimQuery)) -> QueryArr a columns
forall a b. (a -> b) -> a -> b
$ \a
a -> do
Tag
tag <- State Tag Tag
Tag.fresh
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
(columns, PrimQuery) -> State Tag (columns, PrimQuery)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (columns
primExprs, PrimQuery
primQ)
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
instance Profunctor EqPP where
dimap :: (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 ***! :: 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 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 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 ***! :: 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)))