{-# OPTIONS_HADDOCK not-home #-}
{-# LANGUAGE MultiParamTypeClasses, FlexibleContexts #-}
module Opaleye.Internal.Binary where
import Opaleye.Internal.Column (Field_(Column), unColumn)
import qualified Opaleye.Internal.Tag as T
import qualified Opaleye.Internal.PackMap as PM
import qualified Opaleye.Internal.QueryArr as Q
import qualified Opaleye.Internal.PrimQuery as PQ
import qualified Opaleye.Internal.HaskellDB.PrimQuery as HPQ
import Data.Profunctor (Profunctor, dimap)
import Data.Profunctor.Product (ProductProfunctor)
import qualified Data.Profunctor.Product as PP
import Data.Profunctor.Product.Default (Default, def)
import Control.Applicative (Applicative, pure, (<*>))
import Control.Arrow ((***))
extractBinaryFields :: T.Tag -> (HPQ.PrimExpr, HPQ.PrimExpr)
-> PM.PM [(HPQ.Symbol, (HPQ.PrimExpr, HPQ.PrimExpr))]
HPQ.PrimExpr
= forall primExpr.
String -> Tag -> primExpr -> PM [(Symbol, primExpr)] PrimExpr
PM.extractAttr String
"binary"
newtype Binaryspec fields fields' =
Binaryspec (PM.PackMap (HPQ.PrimExpr, HPQ.PrimExpr) HPQ.PrimExpr
(fields, fields) fields')
runBinaryspec :: Applicative f => Binaryspec columns columns'
-> ((HPQ.PrimExpr, HPQ.PrimExpr) -> f HPQ.PrimExpr)
-> (columns, columns) -> f columns'
runBinaryspec :: forall (f :: * -> *) columns columns'.
Applicative f =>
Binaryspec columns columns'
-> ((PrimExpr, PrimExpr) -> f PrimExpr)
-> (columns, columns)
-> f columns'
runBinaryspec (Binaryspec PackMap (PrimExpr, PrimExpr) PrimExpr (columns, columns) columns'
b) = forall (f :: * -> *) a b s t.
Applicative f =>
PackMap a b s t -> (a -> f b) -> s -> f t
PM.traversePM PackMap (PrimExpr, PrimExpr) PrimExpr (columns, columns) columns'
b
binaryspecColumn :: Binaryspec (Field_ n a) (Field_ n a)
binaryspecColumn :: forall (n :: Nullability) a. Binaryspec (Field_ n a) (Field_ n a)
binaryspecColumn = forall fields fields'.
PackMap (PrimExpr, PrimExpr) PrimExpr (fields, fields) fields'
-> Binaryspec fields fields'
Binaryspec (forall s a b t. (s -> a) -> (b -> t) -> PackMap a b s t
PM.iso (forall {t} {b}. (t -> b) -> (t, t) -> (b, b)
mapBoth forall (n :: Nullability) a. Field_ n a -> PrimExpr
unColumn) forall (n :: Nullability) sqlType. PrimExpr -> Field_ n sqlType
Column)
where mapBoth :: (t -> b) -> (t, t) -> (b, b)
mapBoth t -> b
f (t
s, t
t) = (t -> b
f t
s, t -> b
f t
t)
sameTypeBinOpHelper :: PQ.BinOp -> Binaryspec columns columns'
-> Q.Query columns -> Q.Query columns -> Q.Query columns'
sameTypeBinOpHelper :: forall columns columns'.
BinOp
-> Binaryspec columns columns'
-> Query columns
-> Query columns
-> Query columns'
sameTypeBinOpHelper BinOp
binop Binaryspec columns columns'
binaryspec Query columns
q1 Query columns
q2 = forall a. State Tag (a, PrimQuery) -> Query a
Q.productQueryArr forall a b. (a -> b) -> a -> b
$ do
(columns
columns1, PrimQuery
primQuery1) <- forall a. Select a -> State Tag (a, PrimQuery)
Q.runSimpleSelect Query columns
q1
(columns
columns2, PrimQuery
primQuery2) <- forall a. Select a -> State Tag (a, PrimQuery)
Q.runSimpleSelect Query columns
q2
Tag
endTag <- State Tag Tag
T.fresh
let (columns'
newColumns, [(Symbol, (PrimExpr, PrimExpr))]
pes) =
forall a r. PM [a] r -> (r, [a])
PM.run (forall (f :: * -> *) columns columns'.
Applicative f =>
Binaryspec columns columns'
-> ((PrimExpr, PrimExpr) -> f PrimExpr)
-> (columns, columns)
-> f columns'
runBinaryspec Binaryspec columns columns'
binaryspec (Tag
-> (PrimExpr, PrimExpr)
-> PM [(Symbol, (PrimExpr, PrimExpr))] PrimExpr
extractBinaryFields Tag
endTag)
(columns
columns1, columns
columns2))
newPrimQuery :: PrimQuery
newPrimQuery = forall a. BinOp -> (PrimQuery' a, PrimQuery' a) -> PrimQuery' a
PQ.Binary BinOp
binop
( forall a. Bool -> Bindings PrimExpr -> PrimQuery' a -> PrimQuery' a
PQ.Rebind Bool
False (forall a b. (a -> b) -> [a] -> [b]
map (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> a
fst) [(Symbol, (PrimExpr, PrimExpr))]
pes) PrimQuery
primQuery1
, forall a. Bool -> Bindings PrimExpr -> PrimQuery' a -> PrimQuery' a
PQ.Rebind Bool
False (forall a b. (a -> b) -> [a] -> [b]
map (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> b
snd) [(Symbol, (PrimExpr, PrimExpr))]
pes) PrimQuery
primQuery2
)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (columns'
newColumns, PrimQuery
newPrimQuery)
instance Default Binaryspec (Field_ n a) (Field_ n a) where
def :: Binaryspec (Field_ n a) (Field_ n a)
def = forall (n :: Nullability) a. Binaryspec (Field_ n a) (Field_ n a)
binaryspecColumn
instance Functor (Binaryspec a) where
fmap :: forall a b. (a -> b) -> Binaryspec a a -> Binaryspec a b
fmap a -> b
f (Binaryspec PackMap (PrimExpr, PrimExpr) PrimExpr (a, a) a
g) = forall fields fields'.
PackMap (PrimExpr, PrimExpr) PrimExpr (fields, fields) fields'
-> Binaryspec fields fields'
Binaryspec (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f PackMap (PrimExpr, PrimExpr) PrimExpr (a, a) a
g)
instance Applicative (Binaryspec a) where
pure :: forall a. a -> Binaryspec a a
pure = forall fields fields'.
PackMap (PrimExpr, PrimExpr) PrimExpr (fields, fields) fields'
-> Binaryspec fields fields'
Binaryspec forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Applicative f => a -> f a
pure
Binaryspec PackMap (PrimExpr, PrimExpr) PrimExpr (a, a) (a -> b)
f <*> :: forall a b.
Binaryspec a (a -> b) -> Binaryspec a a -> Binaryspec a b
<*> Binaryspec PackMap (PrimExpr, PrimExpr) PrimExpr (a, a) a
x = forall fields fields'.
PackMap (PrimExpr, PrimExpr) PrimExpr (fields, fields) fields'
-> Binaryspec fields fields'
Binaryspec (PackMap (PrimExpr, PrimExpr) PrimExpr (a, a) (a -> b)
f forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> PackMap (PrimExpr, PrimExpr) PrimExpr (a, a) a
x)
instance Profunctor Binaryspec where
dimap :: forall a b c d.
(a -> b) -> (c -> d) -> Binaryspec b c -> Binaryspec a d
dimap a -> b
f c -> d
g (Binaryspec PackMap (PrimExpr, PrimExpr) PrimExpr (b, b) c
b) = forall fields fields'.
PackMap (PrimExpr, PrimExpr) PrimExpr (fields, fields) fields'
-> Binaryspec fields fields'
Binaryspec (forall (p :: * -> * -> *) a b c d.
Profunctor p =>
(a -> b) -> (c -> d) -> p b c -> p a d
dimap (a -> b
f forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** a -> b
f) c -> d
g PackMap (PrimExpr, PrimExpr) PrimExpr (b, b) c
b)
instance ProductProfunctor Binaryspec where
purePP :: forall b a. b -> Binaryspec a b
purePP = forall (f :: * -> *) a. Applicative f => a -> f a
pure
**** :: forall a a b.
Binaryspec a (a -> b) -> Binaryspec a a -> Binaryspec a b
(****) = forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
(<*>)