{-# OPTIONS_HADDOCK not-home #-}

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.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 = String
-> Tag
-> (PrimExpr, PrimExpr)
-> PM [(Symbol, (PrimExpr, PrimExpr))] 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) = PackMap (PrimExpr, PrimExpr) PrimExpr (columns, columns) columns'
-> ((PrimExpr, PrimExpr) -> f PrimExpr)
-> (columns, columns)
-> f columns'
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 = (Field_ n a -> PrimExpr)
-> (PrimExpr -> Field_ n a)
-> Binaryspec PrimExpr PrimExpr
-> Binaryspec (Field_ n a) (Field_ n a)
forall a b c d.
(a -> b) -> (c -> d) -> Binaryspec b c -> Binaryspec a d
forall (p :: * -> * -> *) a b c d.
Profunctor p =>
(a -> b) -> (c -> d) -> p b c -> p a d
dimap Field_ n a -> PrimExpr
forall (n :: Nullability) a. Field_ n a -> PrimExpr
unColumn PrimExpr -> Field_ n a
forall (n :: Nullability) sqlType. PrimExpr -> Field_ n sqlType
Column (PackMap (PrimExpr, PrimExpr) PrimExpr (PrimExpr, PrimExpr) PrimExpr
-> Binaryspec PrimExpr PrimExpr
forall fields fields'.
PackMap (PrimExpr, PrimExpr) PrimExpr (fields, fields) fields'
-> Binaryspec fields fields'
Binaryspec ((forall (f :: * -> *).
 Applicative f =>
 ((PrimExpr, PrimExpr) -> f PrimExpr)
 -> (PrimExpr, PrimExpr) -> f PrimExpr)
-> PackMap
     (PrimExpr, PrimExpr) PrimExpr (PrimExpr, PrimExpr) PrimExpr
forall a b s t.
(forall (f :: * -> *). Applicative f => (a -> f b) -> s -> f t)
-> PackMap a b s t
PM.PackMap ((PrimExpr, PrimExpr) -> f PrimExpr)
-> (PrimExpr, PrimExpr) -> f PrimExpr
forall a. a -> a
forall (f :: * -> *).
Applicative f =>
((PrimExpr, PrimExpr) -> f PrimExpr)
-> (PrimExpr, PrimExpr) -> f PrimExpr
id))

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 = State Tag (columns', PrimQuery) -> Query columns'
forall a. State Tag (a, PrimQuery) -> Query a
Q.productQueryArr (State Tag (columns', PrimQuery) -> Query columns')
-> State Tag (columns', PrimQuery) -> Query columns'
forall a b. (a -> b) -> a -> b
$ do
  (columns
columns1, PrimQuery
primQuery1) <- Query columns -> State Tag (columns, PrimQuery)
forall a. Select a -> State Tag (a, PrimQuery)
Q.runSimpleSelect Query columns
q1
  (columns
columns2, PrimQuery
primQuery2) <- Query columns -> State Tag (columns, PrimQuery)
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) =
            PM [(Symbol, (PrimExpr, PrimExpr))] columns'
-> (columns', [(Symbol, (PrimExpr, PrimExpr))])
forall a r. PM [a] r -> (r, [a])
PM.run (Binaryspec columns columns'
-> ((PrimExpr, PrimExpr)
    -> PM [(Symbol, (PrimExpr, PrimExpr))] PrimExpr)
-> (columns, columns)
-> PM [(Symbol, (PrimExpr, PrimExpr))] columns'
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 = BinOp -> (PrimQuery, PrimQuery) -> PrimQuery
forall a. BinOp -> (PrimQuery' a, PrimQuery' a) -> PrimQuery' a
PQ.Binary BinOp
binop
            ( Bool -> Bindings PrimExpr -> PrimQuery -> PrimQuery
forall a. Bool -> Bindings PrimExpr -> PrimQuery' a -> PrimQuery' a
PQ.Rebind Bool
False (((Symbol, (PrimExpr, PrimExpr)) -> (Symbol, PrimExpr))
-> [(Symbol, (PrimExpr, PrimExpr))] -> Bindings PrimExpr
forall a b. (a -> b) -> [a] -> [b]
map (((PrimExpr, PrimExpr) -> PrimExpr)
-> (Symbol, (PrimExpr, PrimExpr)) -> (Symbol, PrimExpr)
forall a b. (a -> b) -> (Symbol, a) -> (Symbol, b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (PrimExpr, PrimExpr) -> PrimExpr
forall a b. (a, b) -> a
fst) [(Symbol, (PrimExpr, PrimExpr))]
pes) PrimQuery
primQuery1
            , Bool -> Bindings PrimExpr -> PrimQuery -> PrimQuery
forall a. Bool -> Bindings PrimExpr -> PrimQuery' a -> PrimQuery' a
PQ.Rebind Bool
False (((Symbol, (PrimExpr, PrimExpr)) -> (Symbol, PrimExpr))
-> [(Symbol, (PrimExpr, PrimExpr))] -> Bindings PrimExpr
forall a b. (a -> b) -> [a] -> [b]
map (((PrimExpr, PrimExpr) -> PrimExpr)
-> (Symbol, (PrimExpr, PrimExpr)) -> (Symbol, PrimExpr)
forall a b. (a -> b) -> (Symbol, a) -> (Symbol, b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (PrimExpr, PrimExpr) -> PrimExpr
forall a b. (a, b) -> b
snd) [(Symbol, (PrimExpr, PrimExpr))]
pes) PrimQuery
primQuery2
            )

  (columns', PrimQuery) -> State Tag (columns', PrimQuery)
forall a. a -> StateT Tag Identity a
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 = Binaryspec (Field_ n a) (Field_ n a)
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) = PackMap (PrimExpr, PrimExpr) PrimExpr (a, a) b -> Binaryspec a b
forall fields fields'.
PackMap (PrimExpr, PrimExpr) PrimExpr (fields, fields) fields'
-> Binaryspec fields fields'
Binaryspec ((a -> b)
-> PackMap (PrimExpr, PrimExpr) PrimExpr (a, a) a
-> PackMap (PrimExpr, PrimExpr) PrimExpr (a, a) b
forall a b.
(a -> b)
-> PackMap (PrimExpr, PrimExpr) PrimExpr (a, a) a
-> PackMap (PrimExpr, PrimExpr) PrimExpr (a, a) b
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 = PackMap (PrimExpr, PrimExpr) PrimExpr (a, a) a -> Binaryspec a a
forall fields fields'.
PackMap (PrimExpr, PrimExpr) PrimExpr (fields, fields) fields'
-> Binaryspec fields fields'
Binaryspec (PackMap (PrimExpr, PrimExpr) PrimExpr (a, a) a -> Binaryspec a a)
-> (a -> PackMap (PrimExpr, PrimExpr) PrimExpr (a, a) a)
-> a
-> Binaryspec a a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> PackMap (PrimExpr, PrimExpr) PrimExpr (a, a) a
forall a. a -> PackMap (PrimExpr, PrimExpr) PrimExpr (a, a) a
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 = PackMap (PrimExpr, PrimExpr) PrimExpr (a, a) b -> Binaryspec a b
forall fields fields'.
PackMap (PrimExpr, PrimExpr) PrimExpr (fields, fields) fields'
-> Binaryspec fields fields'
Binaryspec (PackMap (PrimExpr, PrimExpr) PrimExpr (a, a) (a -> b)
f PackMap (PrimExpr, PrimExpr) PrimExpr (a, a) (a -> b)
-> PackMap (PrimExpr, PrimExpr) PrimExpr (a, a) a
-> PackMap (PrimExpr, PrimExpr) PrimExpr (a, a) b
forall a b.
PackMap (PrimExpr, PrimExpr) PrimExpr (a, a) (a -> b)
-> PackMap (PrimExpr, PrimExpr) PrimExpr (a, a) a
-> PackMap (PrimExpr, PrimExpr) PrimExpr (a, a) b
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) = PackMap (PrimExpr, PrimExpr) PrimExpr (a, a) d -> Binaryspec a d
forall fields fields'.
PackMap (PrimExpr, PrimExpr) PrimExpr (fields, fields) fields'
-> Binaryspec fields fields'
Binaryspec (((a, a) -> (b, b))
-> (c -> d)
-> PackMap (PrimExpr, PrimExpr) PrimExpr (b, b) c
-> PackMap (PrimExpr, PrimExpr) PrimExpr (a, a) d
forall a b c d.
(a -> b)
-> (c -> d)
-> PackMap (PrimExpr, PrimExpr) PrimExpr b c
-> PackMap (PrimExpr, PrimExpr) PrimExpr a d
forall (p :: * -> * -> *) a b c d.
Profunctor p =>
(a -> b) -> (c -> d) -> p b c -> p a d
dimap (a -> b
f (a -> b) -> (a -> b) -> (a, a) -> (b, b)
forall b c b' c'. (b -> c) -> (b' -> c') -> (b, b') -> (c, c')
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 = b -> Binaryspec a b
forall a. a -> Binaryspec a a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
  **** :: forall a a b.
Binaryspec a (a -> b) -> Binaryspec a a -> Binaryspec a b
(****) = Binaryspec a (b -> c) -> Binaryspec a b -> Binaryspec a c
forall 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
(<*>)

-- }