{-# LANGUAGE MultiParamTypeClasses, FlexibleContexts #-}

module Opaleye.SQLite.Internal.Binary where

import           Opaleye.SQLite.Internal.Column (Column(Column))
import qualified Opaleye.SQLite.Internal.Tag as T
import qualified Opaleye.SQLite.Internal.PackMap as PM

import qualified Opaleye.SQLite.Internal.HaskellDB.PrimQuery as HPQ

import           Data.Profunctor (Profunctor, dimap)
import           Data.Profunctor.Product (ProductProfunctor, empty, (***!))
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 ((forall (f :: * -> *).
 Applicative f =>
 ((PrimExpr, PrimExpr) -> f PrimExpr)
 -> (Column a, Column a) -> f (Column a))
-> PackMap
     (PrimExpr, PrimExpr) PrimExpr (Column a, Column a) (Column a)
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
f (Column e, Column e')
                                           -> (PrimExpr -> Column a) -> f PrimExpr -> f (Column a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PrimExpr -> Column a
forall a. PrimExpr -> Column a
Column ((PrimExpr, PrimExpr) -> f PrimExpr
f (PrimExpr
e, PrimExpr
e'))))

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
  empty :: Binaryspec () ()
empty = Binaryspec () ()
forall (p :: * -> * -> *). Applicative (p ()) => p () ()
PP.defaultEmpty
  ***! :: Binaryspec a b -> Binaryspec a' b' -> Binaryspec (a, a') (b, b')
(***!) = Binaryspec a b -> Binaryspec a' b' -> Binaryspec (a, a') (b, b')
forall (p :: * -> * -> *) a a' b b'.
(Applicative (p (a, a')), Profunctor p) =>
p a b -> p a' b' -> p (a, a') (b, b')
PP.defaultProfunctorProduct

-- }