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

import Composite.Record ((:->)(Val), Rec((:&), RNil))
import Data.Functor.Identity (Identity(Identity))
import Data.Kind (Type)
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 :: [Type]
  -- |Record fields @rs@ with the profunctor removed yielding the covariant parameter. E.g. @PRecContra p '[p a b] ~ '[a]@
  type PRecCo     p rs :: [Type]

  -- |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 = forall (p :: * -> * -> *) a b c d.
Profunctor p =>
(a -> b) -> (c -> d) -> p b c -> p a d
dimap (forall a b. a -> b -> a
const ()) (forall a b. a -> b -> a
const forall {u} (a :: u -> *). Rec a '[]
RNil) 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 a b
p) :& Rec Identity rs
rs) =
    forall (p :: * -> * -> *) a b c d.
Profunctor p =>
(a -> b) -> (c -> d) -> p b c -> p a d
dimap (\ (Identity (Val a
a) :& Rec Identity rs
aRs) -> (a
a, Rec Identity rs
aRs))
          (\ (b
b, Rec Identity (PRecCo p rs)
bRs) -> (forall a. a -> Identity a
Identity (forall (s :: Symbol) a. a -> s :-> a
Val b
b) 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 forall (p :: * -> * -> *) a b a' b'.
ProductProfunctor p =>
p a b -> p a' b' -> p (a, a') (b, b')
***! 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 = forall (p :: * -> * -> *) a b c d.
Profunctor p =>
(a -> b) -> (c -> d) -> p b c -> p a d
dimap (forall a b. a -> b -> a
const ()) (forall a b. a -> b -> a
const forall {u} (a :: u -> *). Rec a '[]
RNil) 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 =
    forall (p :: * -> * -> *) a b c d.
Profunctor p =>
(a -> b) -> (c -> d) -> p b c -> p a d
dimap (\ (Identity (Val a
a) :& Rec Identity rs
aRs) -> (a
a, Rec Identity rs
aRs))
          (\ (b
b, Rec Identity rsCo
bRs) -> (forall a. a -> Identity a
Identity (forall (s :: Symbol) a. a -> s :-> a
Val b
b) 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 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 = 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 = forall (p :: * -> * -> *) a b. Default p a b => p a b
def