{-# 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
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 .&&
(.&&) :: 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
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
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)))