{-# 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))
class ProductProfunctor p => PRec p rs where
type PRecContra p rs :: [Type]
type PRecCo p rs :: [Type]
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