{-# 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
extractBinaryFields :: Tag
-> (PrimExpr, PrimExpr)
-> PM [(Symbol, (PrimExpr, PrimExpr))] PrimExpr
extractBinaryFields = 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

-- {

-- Boilerplate instance definitions.  Theoretically, these are derivable.

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
(<*>)

-- }