{-# OPTIONS_GHC -fno-warn-orphans #-}
module Composite.Opaleye.ProductProfunctors where

import Composite.Record ((:->)(Val), Rec((:&), RNil))
import Data.Functor.Identity (Identity(Identity))
import Data.Profunctor (dimap)
import Data.Profunctor.Product (ProductProfunctor, (***!))
import qualified Data.Profunctor.Product as PP
import Data.Profunctor.Product.Default (Default(def))

-- |Type class implementing traversal of a record, yanking individual product profunctors @Record [p a b]@
-- (though with distinct @a@ and @b@ at each position) up to @p (Record as) (Record bs)@.
--
-- This is similar to the @pN@ functions on tuples provided by the @product-profunctors@ library.
class ProductProfunctor p => PRec p rs where
  -- |Record fields @rs@ with the profunctor removed yielding the contravariant parameter. E.g. @PRecContra p '[p a b] ~ '[a]@
  type PRecContra p rs :: [*]
  -- |Record fields @rs@ with the profunctor removed yielding the covariant parameter. E.g. @PRecContra p '[p a b] ~ '[a]@
  type PRecCo     p rs :: [*]

  -- |Traverse the record, transposing the profunctors @p@ within to the outside like 'traverse' does for Applicative effects.
  --
  -- Roughly equivalent to @Record '[p a b, p c d, …] -> p (Record '[a, c, …]) (Record '[b, d, …])@
  pRec :: Rec Identity rs -> p (Rec Identity (PRecContra p rs)) (Rec Identity (PRecCo p rs))

instance ProductProfunctor p => PRec p '[] where
  type PRecContra p '[] = '[]
  type PRecCo     p '[] = '[]

  pRec :: Rec Identity '[]
-> p (Rec Identity (PRecContra p '[]))
     (Rec Identity (PRecCo p '[]))
pRec Rec Identity '[]
RNil = (Rec Identity '[] -> ())
-> (() -> Rec Identity '[])
-> p () ()
-> p (Rec Identity '[]) (Rec Identity '[])
forall (p :: * -> * -> *) a b c d.
Profunctor p =>
(a -> b) -> (c -> d) -> p b c -> p a d
dimap (() -> Rec Identity '[] -> ()
forall a b. a -> b -> a
const ()) (Rec Identity '[] -> () -> Rec Identity '[]
forall a b. a -> b -> a
const Rec Identity '[]
forall u (a :: u -> *). Rec a '[]
RNil) p () ()
forall (p :: * -> * -> *). ProductProfunctor p => p () ()
PP.empty

instance (ProductProfunctor p, PRec p rs) => PRec p (s :-> p a b ': rs) where
  type PRecContra p (s :-> p a b ': rs) = (s :-> a ': PRecContra p rs)
  type PRecCo     p (s :-> p a b ': rs) = (s :-> b ': PRecCo     p rs)

  pRec :: Rec Identity ((s :-> p a b) : rs)
-> p (Rec Identity (PRecContra p ((s :-> p a b) : rs)))
     (Rec Identity (PRecCo p ((s :-> p a b) : rs)))
pRec (Identity (Val p) :& Rec Identity rs
rs) =
    (Rec Identity ((s :-> a) : PRecContra p rs)
 -> (a, Rec Identity (PRecContra p rs)))
-> ((b, Rec Identity (PRecCo p rs))
    -> Rec Identity ((s :-> b) : PRecCo p rs))
-> p (a, Rec Identity (PRecContra p rs))
     (b, Rec Identity (PRecCo p rs))
-> p (Rec Identity ((s :-> a) : PRecContra p rs))
     (Rec Identity ((s :-> b) : PRecCo p rs))
forall (p :: * -> * -> *) a b c d.
Profunctor p =>
(a -> b) -> (c -> d) -> p b c -> p a d
dimap (\ (Identity (Val a) :& Rec Identity rs
aRs) -> (a
a, Rec Identity rs
aRs))
          (\ (b
b, Rec Identity (PRecCo p rs)
bRs) -> ((s :-> b) -> Identity (s :-> b)
forall a. a -> Identity a
Identity (b -> s :-> b
forall (s :: Symbol) a. a -> s :-> a
Val b
b) Identity (s :-> b)
-> Rec Identity (PRecCo p rs)
-> Rec Identity ((s :-> b) : PRecCo p rs)
forall u (a :: u -> *) (r :: u) (rs :: [u]).
a r -> Rec a rs -> Rec a (r : rs)
:& Rec Identity (PRecCo p rs)
bRs))
          (p a b
p p a b
-> p (Rec Identity (PRecContra p rs)) (Rec Identity (PRecCo p rs))
-> p (a, Rec Identity (PRecContra p rs))
     (b, Rec Identity (PRecCo p rs))
forall (p :: * -> * -> *) a b a' b'.
ProductProfunctor p =>
p a b -> p a' b' -> p (a, a') (b, b')
***! Rec Identity rs
-> p (Rec Identity (PRecContra p rs)) (Rec Identity (PRecCo p rs))
forall (p :: * -> * -> *) (rs :: [*]).
PRec p rs =>
Rec Identity rs
-> p (Rec Identity (PRecContra p rs)) (Rec Identity (PRecCo p rs))
pRec Rec Identity rs
rs)

instance ProductProfunctor p => Default p (Rec Identity '[]) (Rec Identity '[]) where
  def :: p (Rec Identity '[]) (Rec Identity '[])
def = (Rec Identity '[] -> ())
-> (() -> Rec Identity '[])
-> p () ()
-> p (Rec Identity '[]) (Rec Identity '[])
forall (p :: * -> * -> *) a b c d.
Profunctor p =>
(a -> b) -> (c -> d) -> p b c -> p a d
dimap (() -> Rec Identity '[] -> ()
forall a b. a -> b -> a
const ()) (Rec Identity '[] -> () -> Rec Identity '[]
forall a b. a -> b -> a
const Rec Identity '[]
forall u (a :: u -> *). Rec a '[]
RNil) p () ()
forall (p :: * -> * -> *). ProductProfunctor p => p () ()
PP.empty

instance forall p s a b rsContra rsCo. (ProductProfunctor p, Default p a b, Default p (Rec Identity rsContra) (Rec Identity rsCo))
      => Default p (Rec Identity (s :-> a ': rsContra)) (Rec Identity (s :-> b ': rsCo)) where
  def :: p (Rec Identity ((s :-> a) : rsContra))
  (Rec Identity ((s :-> b) : rsCo))
def =
    (Rec Identity ((s :-> a) : rsContra) -> (a, Rec Identity rsContra))
-> ((b, Rec Identity rsCo) -> Rec Identity ((s :-> b) : rsCo))
-> p (a, Rec Identity rsContra) (b, Rec Identity rsCo)
-> p (Rec Identity ((s :-> a) : rsContra))
     (Rec Identity ((s :-> b) : rsCo))
forall (p :: * -> * -> *) a b c d.
Profunctor p =>
(a -> b) -> (c -> d) -> p b c -> p a d
dimap (\ (Identity (Val a) :& Rec Identity rs
aRs) -> (a
a, Rec Identity rs
aRs))
          (\ (b
b, Rec Identity rsCo
bRs) -> ((s :-> b) -> Identity (s :-> b)
forall a. a -> Identity a
Identity (b -> s :-> b
forall (s :: Symbol) a. a -> s :-> a
Val b
b) Identity (s :-> b)
-> Rec Identity rsCo -> Rec Identity ((s :-> b) : rsCo)
forall u (a :: u -> *) (r :: u) (rs :: [u]).
a r -> Rec a rs -> Rec a (r : rs)
:& Rec Identity rsCo
bRs))
          (p a b
step p a b
-> p (Rec Identity rsContra) (Rec Identity rsCo)
-> p (a, Rec Identity rsContra) (b, Rec Identity rsCo)
forall (p :: * -> * -> *) a b a' b'.
ProductProfunctor p =>
p a b -> p a' b' -> p (a, a') (b, b')
***! p (Rec Identity rsContra) (Rec Identity rsCo)
recur)
    where
      step :: p a b
      step :: p a b
step = p a b
forall (p :: * -> * -> *) a b. Default p a b => p a b
def
      recur :: p (Rec Identity rsContra) (Rec Identity rsCo)
      recur :: p (Rec Identity rsContra) (Rec Identity rsCo)
recur = p (Rec Identity rsContra) (Rec Identity rsCo)
forall (p :: * -> * -> *) a b. Default p a b => p a b
def