{-# LANGUAGE MultiParamTypeClasses, FlexibleContexts #-}

module Opaleye.Internal.Binary where

import           Opaleye.Internal.Column (Column(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 = String
-> Tag
-> (PrimExpr, PrimExpr)
-> PM [(Symbol, (PrimExpr, PrimExpr))] PrimExpr
forall primExpr.
String -> Tag -> primExpr -> PM [(Symbol, primExpr)] PrimExpr
PM.extractAttr String
"binary"

newtype Binaryspec columns columns' =
  Binaryspec (PM.PackMap (HPQ.PrimExpr, HPQ.PrimExpr) HPQ.PrimExpr
                         (columns, columns) columns')

runBinaryspec :: Applicative f => Binaryspec columns columns'
                 -> ((HPQ.PrimExpr, HPQ.PrimExpr) -> f HPQ.PrimExpr)
                 -> (columns, columns) -> f columns'
runBinaryspec :: 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 (Column a) (Column a)
binaryspecColumn :: Binaryspec (Column a) (Column a)
binaryspecColumn = PackMap
  (PrimExpr, PrimExpr) PrimExpr (Column a, Column a) (Column a)
-> Binaryspec (Column a) (Column a)
forall columns columns'.
PackMap (PrimExpr, PrimExpr) PrimExpr (columns, columns) columns'
-> Binaryspec columns columns'
Binaryspec (((Column a, Column a) -> (PrimExpr, PrimExpr))
-> (PrimExpr -> Column a)
-> PackMap
     (PrimExpr, PrimExpr) PrimExpr (Column a, Column a) (Column a)
forall s a b t. (s -> a) -> (b -> t) -> PackMap a b s t
PM.iso ((Column a -> PrimExpr)
-> (Column a, Column a) -> (PrimExpr, PrimExpr)
forall t b. (t -> b) -> (t, t) -> (b, b)
mapBoth Column a -> PrimExpr
forall a. Column a -> PrimExpr
unColumn) PrimExpr -> Column a
forall pgType. PrimExpr -> Column pgType
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 :: BinOp
-> Binaryspec columns columns'
-> Query columns
-> Query columns
-> Query columns'
sameTypeBinOpHelper BinOp
binop Binaryspec columns columns'
binaryspec Query columns
q1 Query columns
q2 = (((), Tag) -> (columns', PrimQuery, Tag)) -> Query columns'
forall a b. ((a, Tag) -> (b, PrimQuery, Tag)) -> QueryArr a b
Q.productQueryArr ((), Tag) -> (columns', PrimQuery, Tag)
q where
  q :: ((), Tag) -> (columns', PrimQuery, Tag)
q ((), Tag
startTag) = (columns'
newColumns, PrimQuery
newPrimQuery, Tag -> Tag
T.next Tag
endTag)
    where (columns
columns1, PrimQuery
primQuery1, Tag
midTag) = Query columns -> ((), Tag) -> (columns, PrimQuery, Tag)
forall a b. QueryArr a b -> (a, Tag) -> (b, PrimQuery, Tag)
Q.runSimpleQueryArr Query columns
q1 ((), Tag
startTag)
          (columns
columns2, PrimQuery
primQuery2, Tag
endTag) = Query columns -> ((), Tag) -> (columns, PrimQuery, Tag)
forall a b. QueryArr a b -> (a, Tag) -> (b, PrimQuery, Tag)
Q.runSimpleQueryArr Query columns
q2 ((), Tag
midTag)

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

instance Default Binaryspec (Column a) (Column a) where
  def :: Binaryspec (Column a) (Column a)
def = Binaryspec (Column a) (Column a)
forall a. Binaryspec (Column a) (Column a)
binaryspecColumn

-- {

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

instance Functor (Binaryspec a) where
  fmap :: (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 columns columns'.
PackMap (PrimExpr, PrimExpr) PrimExpr (columns, columns) columns'
-> Binaryspec columns columns'
Binaryspec ((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 :: a -> Binaryspec a a
pure = PackMap (PrimExpr, PrimExpr) PrimExpr (a, a) a -> Binaryspec a a
forall columns columns'.
PackMap (PrimExpr, PrimExpr) PrimExpr (columns, columns) columns'
-> Binaryspec columns columns'
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 (f :: * -> *) a. Applicative f => a -> f a
pure
  Binaryspec PackMap (PrimExpr, PrimExpr) PrimExpr (a, a) (a -> b)
f <*> :: 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 columns columns'.
PackMap (PrimExpr, PrimExpr) PrimExpr (columns, columns) columns'
-> Binaryspec columns columns'
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 (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 :: (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 columns columns'.
PackMap (PrimExpr, PrimExpr) PrimExpr (columns, columns) columns'
-> Binaryspec columns columns'
Binaryspec (((a, a) -> (b, b))
-> (c -> d)
-> PackMap (PrimExpr, PrimExpr) PrimExpr (b, b) c
-> PackMap (PrimExpr, PrimExpr) PrimExpr (a, 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 (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 :: b -> Binaryspec a b
purePP = b -> Binaryspec a b
forall (f :: * -> *) a. Applicative f => a -> f a
pure
  **** :: Binaryspec a (b -> c) -> Binaryspec a b -> Binaryspec a c
(****) = Binaryspec a (b -> c) -> Binaryspec a b -> Binaryspec a c
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
(<*>)

-- }