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